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

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