How to pull Excel file path using Outlook VBA? - excel

I am trying to create a macro in Outlook to pull the file path for the open Excel workbook into a hyperlink in my email.
For example, if a workbook with file path "C:\Desktop\Documents\Phones.xlsx" was open, there would be a link created in my email to that workbook.

If you just want the link to be the body of the email this should make it.
Sub hyperlink_zu_email()
'get path of active document
Dim spath As String
Dim sname As String
Dim scomplete As String
spath = Excel.Application.ActiveDocument.Path
sname = Excel.Application.ActiveDocument.Name
scomplete = Excel.Application.ActiveDocument.Path + "\" + Application.ActiveDocument.Name
'send Email
Dim mailmsg As Object
Dim OutLkApp As Object
Set OutLkApp = CreateObject("Outlook.Application")
Set mailmsg = OutLkApp.CreateItem(0)
With mailmsg
.To = "he#do.at"
.Subject = scomplete
.HTMLBody = "<a href='file:///" & scomplete & "'>" & sname & "</a>"
.Display
End With
End Sub
The "sname" part can be whatever you want, in this case it would take the name of the active document. This is what the link looks like for the guy who gets the mail.
But as #Foxfire And Burns And Burns mentioned, it will only work correctly if there is only one workbook opened.

Related

Open dialog box to add attachment for Outlook email, when attachment not found

I would like to attach a file, when sending Outlook email, with Excel VBA code.
Sometimes the attachment doesn't meet the path criteria in the code.
In this case, I get:
Cannot find this file, verify the path and file name are correct
Sub Confirmationemail()
MsgBox ("The confirmation email will be sent now")
Dim OutlookApp As Outlook.Application
Dim OutlookMail As Outlook.MailItem
Dim fs As Worksheet, bs As Worksheet
Dim Filename As String, Name As String, Name2 As String, Name3 As String, Reason As String
Dim Cost As String, PathFileName As String, PDFfile As String, FilePDF As String, NameA As String,
NameB As String
Dim linecount2 As Long
Set fs = Sheets("Frontsheet")
Set bs = Sheets("BoM")
linecount2 = 1
Cost = Round(bs.Range("E79")(linecount2, 1), 2)
Name = fs.Range("D10")
Name2 = fs.Range("D18")
Name3 = fs.Range("D38")
NameA = fs.Range("D16")
NameB = fs.Range("AA2")
If fs.Range("D38").Value = 3 Then
Reason = fs.Range("K8")
ElseIf fs.Range("D38").Value = 4 Then
Reason = fs.Range("P4")
Else
Reason = fs.Range("K4")
End If
Filename = Name & "_" & Name2
FilePDF = "DPP_" & Name & "_" & NameA & "_" & NameB & "_V" & Name3 & ".0.xlsm"
PDFfile = ThisWorkbook.Path & "/" & FilePDF & ".pdf"
Set OutlookApp = New Outlook.Application
Set OutlookMail = OutlookApp.CreateItem(olMailItem)
With OutlookMail
.BodyFormat = olFormatHTML
.Display
.HTMLBody = "The job is done"
.To = "xxx#xx.co.uk"
.CC = "yyy#yyy.co.uk; zzzz#zzz.co.uk;"
.Subject = Filename & "- Audit"
If Not Filename Like "?_V?" Then
MsgBox ("The attachment wasn't found. Add it manually.")
Else
.Attachments.Add PDFfile
End If
End With
End Sub
The name of my file is set in the FilePDF variable. Once this file name cannot be found (e.g. because of lack one symbol) I need some IF statement covering this situation.
I don't want to display the error. I would like to open the Outlook dialog for attaching a file.
I looked at When adding a file as attachment in Outlook using VBA how can I make the open folder dialog window the active window?
I found something like this:
If FD.Show = True Then
For Each vrtSelectedItem In FD.SelectedItems
.Attachments.Add vrtSelectedItem
Next
End If
Next I implemented something similar in my code:
If Not Filename Like "?_V?" Then
MsgBox ("The attachment wasn't found. Add it manually.")
Else
.Attachments.Add PDFfile
End If
Now I get the Msgbox, which is fine, but I still don't know how to trigger the MS Outlook dialog box for attachment selection.
Some solution here: How to open an Outlook excel attachment using Excel VBA, sent in a particular time range to a specific Outlook folder?
didn't bring an answer to me.
How can I open the Outlook dialog box from Excel VBA?
It looks like one of the solution is making the If statement inside of With OutlookMail section.
Next, we must set the variable for our manual attachment selection, where we use the Application.GetOpenFilename method as per the suggestion below.
https://www.mrexcel.com/board/threads/add-attachment-in-vba-macro-by-dialog-box.956227/
The Outlook section should look like this:
With OutlookMail
.BodyFormat = olFormatHTML
.Display
.HTMLBody = "The job is done"
.To = "xxx#xx.co.uk"
.CC = "yyy#yyy.co.uk; zzzz#zzz.co.uk;"
.Subject = Filename & "- Audit"
If Not Filename Like "?_V?" Then
MsgBox ("The attachment wasn't found. Add it manually.")
Dim Attac As Boolean ' variable for our attachment adding manually
Attac = Application.GetOpenFilename
.Attachments.Add Attac
Else
.Attachments.Add PDFfile
End If
End With
As a result, our add attachment dialog box is opened with our ActiveWorkbook path.
If we want to have a specified file extension, like .pdf, then we must precise it in the Application.GetOpenFilename method like this:
Attac = Application.GetOpenFilename("PDF Files, *.pdf")

Sending multiple worksheets in same workbook via VBA macro through Outlook Email?

I would like to copy multiple worksheets (for example, Sheet71, Sheet76, Sheet60, and Sheet77) that are located within one workbook into another workbook to send in an email to a recipient that is outlined within my email key sheet on Sheet 71.
These emails will be sent to individuals to outline their bonus pay.
Therefore, it is critical that the recipients only receive their own or who they are responsible for.
I have figured out how to send one single worksheet to one recipient, but cannot figure out how to accomplish this with multiple worksheets without using the name on the worksheet (Pierce Group Matrix, Shuff Matrix, Gamble Matrix, and Reed Matrix) versus Sheet71, Sheet76, Sheet60, and Sheet77 in VBA.
I need to be able to reference within the macro to the sheet number rather than the name, because turnover does happen.
Below is the code that I wrote to send an email to one individual in my email key sheet (Sheet81) with one worksheet but it only sends Sheet 71.
I have tried the Array keyword and multiple other keywords but can't seem to get it to work.
I need to reference to the Sheet number rather than the Sheet name because the names are changed when people are replaced.
I would prefer to make a copy like the below code does, but I am open to try a Select command if that will work.
Sub Mail()
Dim OutlookApp As Object
Dim Mess As Object, Recip
Recip = Sheet81.[C35].Value
newDate = MonthName(Month(DateAdd("m", -1, Date)), False)
' Make a copy of the active worksheet
' and save it to a temporary file
Sheet71.Copy
Set WB = ActiveWorkbook
Filename = WB.Worksheets(1).Name
On Error Resume Next
Kill "C:\" & Filename
On Error GoTo 0
WB.SaveAs Filename:="C:\" & Filename
Set OutlookApp = CreateObject("Outlook.Application")
Set Mess = OutlookApp.CreateItem(olMailItem)
With Mess
.Subject = (newDate + " Matrix")
.Body = ("Attached is your " + newDate + " bonus matrix. Thanks! Neil")
.to = Recip
.Attachments.Add WB.FullName
.Display
.Send
End With
ActiveWorkbook.Close
Set OutlookApp = Nothing
Set Mess = Nothing
End Sub
In this method, I elected to create a new sub routine called sendMultMails. This will create a collection of worksheets that you choose to add. Since you do not want to use the sheet name as the reference, I used the sheet's CodeName.
So, add your sheets to the collection and loop that collection. Within the loop, you will call your other routine Mail, passing the sheet as a parameter.
Sub sendMultMails()
Dim wsColl As New Collection, ws As Worksheet
Rem: Add your worksheets to the collection via the worksheet's CodeName
With wsColl
.Add Sheet71
.Add Sheet76
.Add Sheet60
.Add Sheet77
End With
Rem: loop through each collection item, calling the Mail Routine
For Each ws In wsColl
Mail ws
Next
End Sub
Rem: Added an argument for you to pass the ws obj to this routine
Sub Mail(ws As Worksheet)
Dim OutlookApp As Object
Dim Mess As Object, Recip
Recip = ws.Range("C35").Value
newDate = MonthName(Month(DateAdd("m", -1, Date)), False)
' Make a copy of the active worksheet
' and save it to a temporary file
ws.Copy
Set WB = ActiveWorkbook
Filename = WB.Worksheets(1).Name
On Error Resume Next
Kill "C:\" & Filename
On Error GoTo 0
WB.SaveAs Filename:="C:\" & Filename
Set OutlookApp = CreateObject("Outlook.Application")
Set Mess = OutlookApp.CreateItem(olMailItem)
With Mess
.Subject = (newDate + " Matrix")
.Body = ("Attached is your " + newDate + " bonus matrix. Thanks! Neil")
.to = Recip
.Attachments.Add WB.FullName
.Display
.Send
End With
ActiveWorkbook.Close
Set OutlookApp = Nothing
Set Mess = Nothing
End Sub
You could use the WB.Worksheets(1).CodeName to reference the Sheet number.
the CodeName property is read-only
You can reference a particular sheet as Worksheets("Fred").Range("A1") where Fred is the .Name property or as Sheet1.Range("A1") where Sheet1 is the codename of the worksheet.
For more information, you could refer to this link:
Excel tab sheet names vs. Visual Basic sheet names

Using VBA in Excel to reference an Outlook mailbox other than Inbox

Edit: I actually figured this out! I replaced the line
Set outlookInbox = outlookApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
with
Dim NS As Outlook.Namespace
Dim objOwner As Outlook.Recipient
Set NS = outlookApp.GetNamespace("MAPI")
Set objOwner = NS.CreateRecipient("sharedmailbox#companyname.com")
Objowner.Resolve
If objOwner.Resolved Then
MsgBox objOwner.Name 'You can comment this out if you want
Set outlookInbox = NS.GetSharedDefaultFolder(objOwner, olFolderInbox)
End If
Original Post: I have this code that I run in Excel VBA that searches for a specific sender and attachment name in my Outlook default Inbox. It then saves the attachment to a designated folder on my desktop while renaming the file with the date on which the email was received.
However, I want to edit the code so that it searches not in my default Inbox, but in a different, shared mailbox in my Outlook. Assume the email address at which this shared mailbox receives emails is sharedmailbox#companyname.com. This is obviously separate from my own personal email address.
How can I edit this code so it searches in this mailbox and not in my own Inbox?
Option Explicit
Sub GetLatestReport()
'Set a reference to Outlook's object library (Visual Basic >> Tools >> References >> check/select Microsoft Outlook Object Library)
Dim outlookApp As Outlook.Application
Dim outlookInbox As Outlook.MAPIFolder
Dim outlookRestrictItems As Outlook.Items
Dim outlookLatestItem As Outlook.MailItem
Dim outlookAttachment As Outlook.Attachment
Dim attachmentFound As Boolean
Const saveToFolder As String = "C:\Users\jalanger\Desktop\Demo" 'change the save to folder accordingly
Const senderName As String = "Langer, Jaclyn" 'change the sender name accordingly
Const attachmentName As String = "Report on ACBS LC for AMLS (Chandran Panicker)" 'change the attachment name accordingly
Dim SavePath As String
'Create an instance of Outlook
Set outlookApp = New Outlook.Application
'Get the inbox from Outlook
Set outlookInbox = outlookApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
'Filter the items from the inbox based on the sender
Set outlookRestrictItems = outlookInbox.Items.Restrict("[SenderName] = '" & senderName & "'")
'Check whether any items were found
If outlookRestrictItems.Count = 0 Then
MsgBox "No items were found from " & senderName & "!", vbExclamation
Exit Sub
End If
'Sort the filtered items by received time and in descending order
outlookRestrictItems.Sort Property:="[ReceivedTime]", Descending:=True
'Get the latest item from the filtered and sorted items
Set outlookLatestItem = outlookRestrictItems(1)
'Make sure that file extension at the end of this line is correct
SavePath = saveToFolder & "\" & attachmentName & " " & CStr(Format(outlookLatestItem.ReceivedTime, "Long Date")) & ".xls"
MsgBox SavePath
'Loop through each attachment from the latest item until specified file is found
attachmentFound = False
For Each outlookAttachment In outlookLatestItem.Attachments
If Left(UCase(outlookAttachment.FileName), Len(attachmentName)) = UCase(attachmentName) Then
outlookAttachment.SaveAsFile SavePath 'saveToFolder & "\" & outlookAttachment.DisplayName
attachmentFound = True
Exit For
End If
Next outlookAttachment
If attachmentFound Then
MsgBox "The attachment was found and saved to '" & saveToFolder & "'!", vbInformation
Else
MsgBox "No attachment was found!", vbExclamation
End If
Workbooks.Open FileName:=SavePath
End Sub
You can use the DeliveryStore property of the Account to get its inbox. For example:
Sub ResolveName()
Dim ns As NameSpace
Set ns = Application.Session
Dim acc As Account
Dim f As Folder
For Each acc In ns.accounts
MsgBox acc.UserName
If acc = "text#outlook.com" Then
Set f = acc.DeliveryStore.GetDefaultFolder(olFolderInbox)
MsgBox f.Items.count
End If
Next
End Sub
You can filter using acc = "text#outlook.com" or the acc.UserName property.
If you have a second account setup in Outlook (e.g. sharedmailbox#companyname.com) you could replace this line:
Set outlookInbox = outlookApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
with this:
Set outlookInbox = outlookApp.GetNamespace("MAPI").Accounts.Item(2).Session.GetDefaultFolder(olFolderInbox)
This will use the second account's Inbox.

MailItem.GetInspector.WordEditor in Office 2016 generates Application-defined or object defined error

I wrote an Excel macro to send email from a spreadsheet. It works on Office 2013, but not Office 2016.
I looked at the VBA differences between Office 2013 and 2016, but couldn't see anything about changes to the inspector or word editor for message objects.
Once it gets to .GetInspector.WordEditor it throws:
Run-time error '287':
Application-defined or object defined error
Here is the relevant part of the macro:
Sub SendEmail()
Dim actSheet As Worksheet
Set actSheet = ActiveSheet
'directories of attachment and email template
Dim dirEmail as String, dirAttach As String
' Directory of email template as word document
dirEmail = _
"Path_To_Word_Doc_Email_Body"
' Directories of attachments
dirAttach = _
"Path_To_Attachment"
' Email Subject line
Dim subjEmail As String
subjEmail = "Email Subject"
Dim wordApp As Word.Application
Dim docEmail As Word.Document
' Opens email template and copies it
Set wordApp = New Word.Application
Set docEmail = wordApp.Documents.Open(dirEmail, ReadOnly:=True)
docEmail.Content.Copy
Dim OutApp As Outlook.Application
Set OutApp = New Outlook.Application
Dim OutMail As MailItem
Dim outEdit As Word.Document
' The names/emails to send to
Dim docName As String, sendEmail As String, ccEmail As String, siteName As String
Dim corName As String
Dim row As Integer
For row = 2 To 20
sendName = actSheet.Cells(row, 1)
sendEmail = actSheet.Cells(row, 2)
ccEmail = actSheet.Cells(row, 3)
siteName = actSheet.Cells(row, 4)
Set OutMail = OutApp.CreateItem(olMailItem)
With OutMail
.SendUsingAccount = OutApp.Session.Accounts.Item(1)
.To = sendEmail
.CC = ccEmail
.Subject = subjEmail & " (Site: " & siteName & ")"
Set outEdit = .GetInspector.WordEditor
outEdit.Content.Paste
outEdit.Range(0).InsertBefore ("Dear " & sendName & "," & vbNewLine)
.Attachments.Add dirAttach
.Display
'.Send
End With
Debug.Print row
Set OutMail = Nothing
Set outEdit = Nothing
Next row
docEmail.Close False
wordApp.Quit
End Sub
Things I've tried based on suggestions:
Checked Outlook settings - default is HTML text
Moved .display over .GetInspector.WordEditor
Ensure Word is the default email editor. From the Inspector.WordEditor dox:
The WordEditor property is only valid if the IsWordMail method returns True and the EditorType property is olEditorWord . The returned WordDocument object provides access to most of the Word object model...
Further, ensure that Outlook is configured to send Rich Text or HTML emails, not plain text.
I am not entirely sure if I had the same issue as you, but the call to GetInspector started failing for me after upgrading Office 2016. So to be clear it worked with Office 2016 and then stopped working after the latest update.
The following workaround worked for me
dim item : set item = Addin.Outlook.CreateItemFromTemplate(Filename)
Outlook.Inspectors.Add(item) ' Outlook is the application object
it only appears to work if I add the item straight after creating it, setting properties on it and then adding it did not work.
Note: I have not tested with CreateItem instead of CreateItemFromTemplate. The second line was added and unnecessary prior to the Office update.
Problem:
For security purposes, the HTMLBody, HTMLEditor, Body and WordEditor properties all are subject to address-information security prompts because the body of a message often contains the sender's or other people's e-mail addresses. And, if Group Policy does not permit then these prompts do not come on-screen. In simple words, as a developer, you are bound to change your code, because neither registry changes can be made nor group policy can be modified.
Hence, if your code suddenly stopped working after migrating to Office 365 or for any other reasons, please refer to the solutions below. Comments have been added for easy understanding and implementation.
Solution 1:
If you have administrative rights then try the registry changes given at below link:
https://support.microsoft.com/en-au/help/926512/information-for-administrators-about-e-mail-security-settings-in-outlo
However, as developer, I recommend a code that's rather compatible with all versions of Excel instead of making system changes because system changes will be required on each end user's machine as well.
Solution 2: VBA Code
Code Compatible: Excel 2003, Excel 2007, Excel 2010, Excel 2013, Excel 2016, Office 365
Option Explicit
Sub Create_Email(ByVal strTo As String, ByVal strSubject As String)
Dim rngToPicture As Range
Dim outlookApp As Object
Dim Outmail As Object
Dim strTempFilePath As String
Dim strTempFileName As String
'Name it anything, doesn't matter
strTempFileName = "RangeAsPNG"
'rngToPicture is defined as NAMED RANGE in the workbook, do modify this name before use
Set rngToPicture = Range("rngToPicture")
Set outlookApp = CreateObject("Outlook.Application")
Set Outmail = outlookApp.CreateItem(olMailItem)
'Create an email
With Outmail
.To = strTo
.Subject = strSubject
'Create the range as a PNG file and store it in temp folder
Call createPNG(rngToPicture, strTempFileName)
'Embed the image in Outlook
strTempFilePath = Environ$("temp") & "\" & strTempFileName & ".png"
.Attachments.Add strTempFilePath, olByValue, 0
'Change the HTML below to add Header (Dear John) or signature (Kind Regards) using newline tag (<br />)
.HTMLBody = "<img src='cid:DashboardFile.png' style='border:0'>"
.Display
End With
Set Outmail = Nothing
Set outlookApp = Nothing
Set rngToPicture = Nothing
End Sub
Sub createPNG(ByRef rngToPicture As Range, nameFile As String)
Dim wksName As String
wksName = rngToPicture.Parent.Name
'Delete the existing PNG file of same name, if exists
On Error Resume Next
Kill Environ$("temp") & "\" & nameFile & ".png"
On Error GoTo 0
'Copy the range as picture
rngToPicture.CopyPicture
'Paste the picture in Chart area of same dimensions
With ThisWorkbook.Worksheets(wksName).ChartObjects.Add(rngToPicture.Left, rngToPicture.Top, rngToPicture.Width, rngToPicture.Height)
.Activate
.Chart.Paste
'Export the chart as PNG File to Temp folder
.Chart.Export Environ$("temp") & "\" & nameFile & ".png", "PNG"
End With
Worksheets(wksName).ChartObjects(Worksheets(wksName).ChartObjects.Count).Delete
End Sub
Try moving the editor to the first action...
...
With OutMail
Set outEdit = .GetInspector.WordEditor
outEdit.Content.Paste
.SendUsingAccount = OutApp.Session.Accounts.Item(1)
.To = sendEmail
.CC = ccEmail
.Subject = subjEmail & " (Site: " & siteName & ")"
...

VBA to save attachments (based on defined criteria) from an email with multiple accounts

Situation: I have a code that, given an input of sender email, will download all attachments from outlook email (if the sender is the one specified, it saves the .xls attachments).
Problem 1: In my outlook, I have access to 2 accounts (lets say personal and public). I want to be able to select from which of those accounts the code should download the attachments.
Question 1: Is it possible to do this kind of selection? From previous research I was able to find criteria regarding the type of attachments, and more, but nothing regarding multiple inboxes.
Problem 2: Among the attachments in this second inbox (public) I want to select only the files which have a worksheet with a certain "NAME". I know how to do an if to account for that, but don't know if its possible to read the file (and check if it has the wanted sheet) and only then download it.
Question 2: Could I access a file like this? Would it be possible to do this kind of criteria check?
Code so far:
Sub email()
Application.ScreenUpdating = False
On Error Resume Next
Dim olApp As New Outlook.Application
Dim olNameSpace As Object
Dim olMailItem As Outlook.MailItem
Dim olFolder As Object
Dim olFolderName As String
Dim olAtt As Outlook.Attachments
Dim strName As String
Dim sPath As String
Dim i As Long
Dim j As Integer
Dim olSubject As String
Dim olSender As String
Dim sh As Worksheet
Dim LastRow As Integer
ThisWorkbook.Worksheets("FileNames").Rows(2 & ":" & ThisWorkbook.Worksheets("FileNames").Rows.count).Delete
olFolderName = ThisWorkbook.Worksheets("Control").Range("D10")
olSender = ThisWorkbook.Worksheets("Control").Range("D16")
sPath = Application.FileDialog(msoFileDialogFolderPicker).Show
sPathstr = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
Set olNameSpace = olApp.GetNamespace("MAPI")
'check if folder is subfolder or not and choose olFolder accordingly
Set olFolder = olNameSpace.GetDefaultFolder(olFolderInbox).Folders(olFolderName)
If (olFolder = "") Then
Set olFolder = olNameSpace.GetDefaultFolder(olFolderInbox).Parent.Folders(olFolderName)
End If
'loop through mails
h = 2
For i = 1 To olFolder.Items.count
Set olMailItem = olFolder.Items(i)
If (InStr(1, olMailItem.SenderEmailAddress, olSender, vbTextCompare) <> 0) Then
With olMailItem
'loop through attachments
For j = 1 To .Attachments.count
strName = .Attachments.Item(j).DisplayName
'check if file already exists
If Not Dir(sPathstr & "\" & strName) = "" Then
.Attachments(j).SaveAsFile sPathstr & "\" & "(1)" & strName
ThisWorkbook.Worksheets("FileNames").Range("A" & h) = "(1)" & strName
Else
.Attachments(j).SaveAsFile sPathstr & "\" & strName
ThisWorkbook.Worksheets("FileNames").Range("A" & h) = strName
End If
h = h + 1
Next
End With
End If
Next
Application.ScreenUpdating = True
MsgBox "Download complete!", vbInformation + vbOKOnly, "Done"
End Sub
Every folder in Outlook has a unique path. Even if they're both called Inbox, the path to them is different. Select the first Inbox in Outlook and go to the Immediate Window (Alt+F11 then Ctrl+G). Type this and press enter
?application.ActiveExplorer.CurrentFolder.FolderPath
You'll get something like
\\dkusleika#copmany.com\Inbox
Now go back to Outlook and select the other Inbox. Return to the Immediate Window and execute the same command. Now you'll have the path to each Inbox. Maybe the second one looks like
\\DKPersonal\Inbox
You use GetDefaultFolder, which is very handy. But you can get to any folder, even default folders, by following their path directly.
Set olFolder = Application.GetNamespace("MAPI").Folders("dkusleika#company.com").Folders("Inbox")
Just chain Folders properties together until you get to the one you want.
As for Question 2, you can't inspect an Excel file without opening it. You'll have to download it to a temporary location, open it to see if it contains the worksheet, and move it to the final location if it does. Or download it to the final location and delete it if it doesn't have the sheet.

Resources