Macros to add attachments to an outlook e-mail

gbaker · #1 02-26-2016, 07:50 AM

I would like to know get some code to be able to find .pdf files from my network and attach them to an e-mail by using a macro.

gmayor · #2 02-26-2016, 10:18 PM

How would this differ from the inbuilt function to attach files to messages?

gbaker · #3 02-29-2016, 05:54 AM

hI gmayor
It would be the same except more automated. I have a few colleague that I would like to add a macro so they can find the pdf's, attached them to an e-mail and send. I'm looking for automation.
Do you have code so I can do this. I don't know how to code in Outlook. Excel is easy because you can record Macro's.
Thanks GWB

gmayor · #4 03-01-2016, 10:27 PM

You will need to tell us more about 'the PDFs' as the inbuilt function is quite capable of adding finding and adding PDF attachments to a message.

For any greater automation to be worth the effort of programming the PDFs would have to be specified before hand and for multiple users, available from a common location or you are just expecting someone else to reinvent the wheel for you. Tell us more about your process.

gbaker · #5 03-02-2016, 06:00 AM

Whenever materials need to be ordered my collegues & myself have to send visuals of the artwork to the vendor. The visuals are in the form of PDF files that are locatd on our network. If we can click on a Macros that would locate the network path and then be able to choose the files (More than one) needed then we can just send them to the vendor without having to use the attach function for each pdf.

gmayor · #6 03-02-2016, 07:26 AM

The main problem is that the file brower used by the in-built function is better than the one used by Outlook VBA, so you have to cobble something together which may not be as convenient. e.g. Create a VBA userform with a list box and two command buttons beneath it. The sizes don't matter as they are set in the macro. Use the default names.

The first code block below is the Userform code.

Code:

Option Explicit

Private Sub CommandButton1_Click()
    Me.Hide
    Me.Tag = 1
End Sub

Private Sub CommandButton2_Click()
    Me.Hide
    Me.Tag = 0
End Sub

The following goes in an ordinary module and is run to call the userform from which you can pick the PDFs to add to a new message

Code:

Option Explicit

Sub AttachPDFs()
Dim olItem As Outlook.MailItem
Dim olAttachments As Outlook.Attachments
Dim strPath As String
Dim strFile As String
Dim i As Long
Dim oFrm As New UserForm1
    With oFrm
        .Caption = "Select files to attach"
        .Height = 272
        .Width = 240
        .CommandButton1.Caption = "Continue"
        .CommandButton1.Top = 210
        .CommandButton1.Width = 72
        .CommandButton1.Left = 132
        .CommandButton2.Caption = "Cancel"
        .CommandButton2.Top = 210
        .CommandButton2.Width = 72
        .CommandButton2.Left = 18
        .ListBox1.Top = 12
        .ListBox1.Left = 18
        .ListBox1.Height = 192
        .ListBox1.Width = 189
        .ListBox1.MultiSelect = fmMultiSelectMulti
        strPath = BrowseForFolder & Chr(92) 
        'If the files are always in the same folder you coiuld set strPath to that folder e.g.
        'strPath = "C:\Path\"
        strFile = Dir$(strPath & "*.pdf")
        While Not strFile = ""
            On Error GoTo err_Handler
            .ListBox1.AddItem strFile
            strFile = Dir$()
        Wend
        .Show
        If .Tag = 1 Then
            Set olItem = Application.CreateItem(olMailItem)
            Set olAttachments = olItem.Attachments
            For i = 0 To .ListBox1.ListCount - 1
                If .ListBox1.Selected(i) Then
                    olAttachments.Add strPath & .ListBox1.List(i), _
                                      olByValue, 1
                End If
            Next i

            olItem.Display
        End If
    End With
    Unload oFrm

lbl_Exit:
    Set olItem = Nothing
    Set olAttachments = Nothing
    Set oFrm = Nothing
    Exit Sub
err_Handler:
    MsgBox Err.Number & vbCr & Err.Description
    Err.Clear
    GoTo lbl_Exit
End Sub

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
Dim ShellApp As Object
    Set ShellApp = CreateObject("Shell.Application"). _
                   BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0

    Set ShellApp = Nothing
    Select Case Mid(BrowseForFolder, 2, 1)
        Case Is = ":"
            If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
        Case Is = "\"
            If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
        Case Else
            GoTo Invalid
    End Select
lbl_Exit:
    Set ShellApp = Nothing
    Exit Function
Invalid:
    BrowseForFolder = False
    GoTo lbl_Exit
End Function

gbaker · #7 03-02-2016, 07:42 AM

Hi
I got the following syntax error when I ran it.

HTML Code:

[COLOR="Red"]Dim olAttachments As Outlook.Attachments Dim strPath As String Dim strFile As String Dim i As Long Dim oFrm As New UserForm1[/COLOR]

Here is what I have for code including the STRPath

HTML Code:

Sub AttachPDFs()
Dim olItem As Outlook.MailItem
Dim olAttachments As Outlook.Attachments Dim strPath As String Dim strFile As String Dim i As Long Dim oFrm As New UserForm1
    With oFrm
        .Height = 272
        .Width = 240
        .CommandButton1.Caption = "Continue"
        .CommandButton1.Top = 210
        .CommandButton1.Width = 72
        .CommandButton1.Left = 132
        .CommandButton2.Caption = "Cancel"
        .CommandButton2.Top = 210
        .CommandButton2.Width = 72
        .CommandButton2.Left = 18
        .ListBox1.Top = 12
        .ListBox1.Left = 18
        .ListBox1.Height = 192
        .ListBox1.Width = 189
        .ListBox1.MultiSelect = fmMultiSelectMulti
        strPath = fngn.com \ us \ Projects \ CSServer
        'If the files are always in the same folder you coiuld set strPath to that folder e.g.
        'strPath = "C:\Path\"
        strFile = Dir$(strPath & "*.pdf")
        While Not strFile = ""
            On Error GoTo err_Handler
            .ListBox1.AddItem strFile
            strFile = Dir$()
        Wend
        .Show
        If .Tag = 1 Then
            Set olItem = Application.CreateItem(olMailItem)
            Set olAttachments = olItem.Attachments
            For i = 0 To .ListBox1.ListCount - 1
                If .ListBox1.Selected(i) Then
                    olAttachments.Add strPath & .ListBox1.List(i), _
                                      olByValue, 1
                End If
            Next i

            olItem.Display
        End If
    End With
    Unload oFrm

lbl_Exit:
    Set olItem = Nothing
    Set olAttachments = Nothing
    Set oFrm = Nothing
    Exit Sub
err_Handler:
    MsgBox Err.Number & vbCr & Err.Description
    Err.Clear
    GoTo lbl_Exit
End Sub

gmayor · #8 03-02-2016, 09:55 PM

The item has not pasted correctly (see the layout in my post). Each DIM statement should be on a new line.

gbaker · #9 03-03-2016, 07:45 AM

Hi
I think I am still missing something. The box comes up but it doesn't go to the directory. The box is empty. Do I have the StrPath set up correctly. Do I need to add the path somewhere else under brwose for folder?

Here is what I have now:

HTML Code:

Option Explicit

Sub AttachPDFs()
Dim olItem As Outlook.MailItem
Dim olAttachments As Outlook.Attachments
Dim strPath As String
Dim strFile As String
Dim i As Long
Dim oFrm As New UserForm1
    With oFrm
        .Caption = "Select files to attach"
        .Height = 272
        .Width = 240
        .CommandButton1.Caption = "Continue"
        .CommandButton1.Top = 210
        .CommandButton1.Width = 72
        .CommandButton1.Left = 132
        .CommandButton2.Caption = "Cancel"
        .CommandButton2.Top = 210
        .CommandButton2.Width = 72
        .CommandButton2.Left = 18
        .ListBox1.Top = 12
        .ListBox1.Left = 18
        .ListBox1.Height = 192
        .ListBox1.Width = 189
        .ListBox1.MultiSelect = fmMultiSelectMulti
        strPath = "fngn.com\us\Projects\CSServer\Sponsor"
        'If the files are always in the same folder you coiuld set strPath to that folder e.g.
        strPath = "fngn.com\us\Projects\CSServer\Sponsor"
        strFile = Dir$(strPath & "*.pdf")
        While Not strFile = ""
            On Error GoTo err_Handler
            .ListBox1.AddItem strFile
            strFile = Dir$()
        Wend
        .Show
        If .Tag = 1 Then
            Set olItem = Application.CreateItem(olMailItem)
            Set olAttachments = olItem.Attachments
            For i = 0 To .ListBox1.ListCount - 1
                If .ListBox1.Selected(i) Then
                    olAttachments.Add strPath & .ListBox1.List(i), _
                                      olByValue, 1
                End If
            Next i

            olItem.Display
        End If
    End With
    Unload oFrm

lbl_Exit:
    Set olItem = Nothing
    Set olAttachments = Nothing
    Set oFrm = Nothing
    Exit Sub
err_Handler:
    MsgBox Err.Number & vbCr & Err.Description
    Err.Clear
    GoTo lbl_Exit
End Sub

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
Dim ShellApp As Object
    Set ShellApp = CreateObject("Shell.Application"). _
                   BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

    On Error Resume Next
    BrowseForFolder = ShellApp.self.path
    On Error GoTo 0

    Set ShellApp = Nothing
    Select Case Mid(BrowseForFolder, 2, 1)
        Case Is = ":"
            If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
        Case Is = "\"
            If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
        Case Else
            GoTo Invalid
    End Select
lbl_Exit:
    Set ShellApp = Nothing
    Exit Function
Invalid:
    BrowseForFolder = False
    GoTo lbl_Exit
End Function

gmayor · #10 03-04-2016, 03:58 AM

I suspect the problem relates to the network address. Does it work with a local drive? If so try mapping the network location to a local drive letter.

gbaker · #11 03-04-2016, 05:30 AM

Hi GMayor:
I mapped the network drive to a local drive letter and added it to the code. Still doesn't work. Thank you for all you help. We will have to just do it manually.
Here is what my code looks like now:

HTML Code:

Option Explicit

Sub AttachPDFs()
Dim olItem As Outlook.MailItem
Dim olAttachments As Outlook.Attachments
Dim strPath As String
Dim strFile As String
Dim i As Long
Dim oFrm As New UserForm1
    With oFrm
        .Caption = "Select files to attach"
        .Height = 272
        .Width = 240
        .CommandButton1.Caption = "Continue"
        .CommandButton1.Top = 210
        .CommandButton1.Width = 72
        .CommandButton1.Left = 132
        .CommandButton2.Caption = "Cancel"
        .CommandButton2.Top = 210
        .CommandButton2.Width = 72
        .CommandButton2.Left = 18
        .ListBox1.Top = 12
        .ListBox1.Left = 18
        .ListBox1.Height = 192
        .ListBox1.Width = 189
        .ListBox1.MultiSelect = fmMultiSelectMulti
        strPath = "X:\_sponsor_folder"
        'If the files are always in the same folder you coiuld set strPath to that folder e.g.
        strPath = "X:\_sponsor_folder"
        strFile = Dir$(strPath & "*.pdf")
        While Not strFile = ""
            On Error GoTo err_Handler
            .ListBox1.AddItem strFile
            strFile = Dir$()
        Wend
        .Show
        If .Tag = 1 Then
            Set olItem = Application.CreateItem(olMailItem)
            Set olAttachments = olItem.Attachments
            For i = 0 To .ListBox1.ListCount - 1
                If .ListBox1.Selected(i) Then
                    olAttachments.Add strPath & .ListBox1.List(i), _
                                      olByValue, 1
                End If
            Next i

            olItem.Display
        End If
    End With
    Unload oFrm

lbl_Exit:
    Set olItem = Nothing
    Set olAttachments = Nothing
    Set oFrm = Nothing
    Exit Sub
err_Handler:
    MsgBox Err.Number & vbCr & Err.Description
    Err.Clear
    GoTo lbl_Exit
End Sub

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
Dim ShellApp As Object
    Set ShellApp = CreateObject("Shell.Application"). _
                   BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

    On Error Resume Next
    BrowseForFolder = ShellApp.self.path
    On Error GoTo 0

    Set ShellApp = Nothing
    Select Case Mid(BrowseForFolder, 2, 1)
        Case Is = ":"
            If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
        Case Is = "\"
            If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
        Case Else
            GoTo Invalid
    End Select
lbl_Exit:
    Set ShellApp = Nothing
    Exit Function
Invalid:
    BrowseForFolder = False
    GoTo lbl_Exit
End Function

gmayor · #12 03-05-2016, 12:22 AM

I have recreated your folder on my network and provided you have the backslash at the end of the path (your's doesn't) it works OK

Code:

Option Explicit

Sub AttachPDFs()
Dim olItem As Outlook.MailItem
Dim olAttachments As Outlook.Attachments
Dim strPath As String
Dim strFile As String
Dim i As Long
Dim oFrm As New UserForm1
    With oFrm
        .Caption = "Select files to attach"
        .Height = 272
        .Width = 240
        .CommandButton1.Caption = "Continue"
        .CommandButton1.Top = 210
        .CommandButton1.Width = 72
        .CommandButton1.Left = 132
        .CommandButton2.Caption = "Cancel"
        .CommandButton2.Top = 210
        .CommandButton2.Width = 72
        .CommandButton2.Left = 18
        .ListBox1.Top = 12
        .ListBox1.Left = 18
        .ListBox1.Height = 192
        .ListBox1.Width = 189
        .ListBox1.MultiSelect = fmMultiSelectMulti
        'If the files are always in the same folder you could set strPath to that folder e.g.
        strPath = "X:\_sponsor_folder\"
        strFile = Dir$(strPath & "*.pdf")
        While Not strFile = ""
            On Error GoTo err_Handler
            .ListBox1.AddItem strFile
            strFile = Dir$()
        Wend
        .Show
        If .Tag = 1 Then
            Set olItem = Application.CreateItem(olMailItem)
            Set olAttachments = olItem.Attachments
            For i = 0 To .ListBox1.ListCount - 1
                If .ListBox1.Selected(i) Then
                    olAttachments.Add strPath & .ListBox1.List(i), _
                                      olByValue, 1
                End If
            Next i

            olItem.Display
        End If
    End With
    Unload oFrm

lbl_Exit:
    Set olItem = Nothing
    Set olAttachments = Nothing
    Set oFrm = Nothing
    Exit Sub
err_Handler:
    MsgBox Err.Number & vbCr & Err.Description
    Err.Clear
    GoTo lbl_Exit
End Sub

Rah786 · #13 02-14-2024, 07:40 AM

hello
sorry to resurrect this very old thread.

this is what i was exactly looking for and it worked!

I am a total beginner.

I would like to ask is there a way to modify the code to enable the user to attach the file and then automatically delete that specific file from the directory? Or if this is more simpler, to create a third command box which will delete the selected file from the list.

Many thanks

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Shortcut for downloading attachments in e-mail	paik1002	Outlook	4	12-11-2015 03:01 AM
Move and Delete Mail Without Attachments	rambler289	Outlook	1	09-29-2015 09:33 PM
Adding attachments to (e)mail-mege message	Roger Keeling	Mail Merge	2	05-23-2015 06:04 AM
Mail merge with personalized attachments	sharke	Outlook	0	07-01-2011 07:16 AM
Can't See Attachments When E-mail String is Saved to PDF	wineattorney	Outlook	1	03-29-2011 02:15 AM