Microsoft Office Forums - View Single Post - [Solved] Macros to add attachments to an outlook e-mail

gmayor · 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