Attach multiple files to an email

Hi guys i have this code

Const msoFileDialogOpen = 1
Set fso = CreateObject("Scripting.FileSystemObject")
Set objWord = CreateObject("Word.Application")
Set WshShell = CreateObject("WScript.Shell")
strInitialPath = WshShell.ExpandEnvironmentStrings("%USERPROFILE%") & "\Desktop\"
objWord.ChangeFileOpenDirectory (strInitialPath)
With objWord.FileDialog(msoFileDialogOpen)
.Title = "Select the file to process"
.AllowMultiSelect = True
.Filters.Clear
.Filters.Add "All Files", "*.*"
.Filters.Add "Excel Files", "*.xls;*.xlsx"
.Filters.Add "Text Files", "*.txt"
.Filters.Add "Various Files", "*.xls;*.doc;*.vbs"
 If .Show = -1 Then
For Each File In .SelectedItems
Set objFile = fso.GetFile(File)

filepath = objFile
Next
Else
End If
End With

This code allow me to attach 1 file to email, however i can only attach 1 file how can i do to attach multiple files?

Thanks,

Hi there,

Try the following code and see if it does what you want:

Option Explicit


'=========================================================================================
'=========================================================================================


Public Sub LaunchOutlook()

    Const iMAIL_ITEM    As Integer = 0

    Dim objMailItem     As Object
    Dim vaFileNames     As Variant
    Dim objOutlook      As Object
    Dim iFileNo         As Integer

    On Error Resume Next
        Set objOutlook = GetObject(Class:="Outlook.Application")
    On Error GoTo 0

    If objOutlook Is Nothing Then
        Set objOutlook = CreateObject(Class:="Outlook.Application")
    End If

    vaFileNames = mvaFilenames()

    With objOutlook

        Set objMailItem = .CreateItem(iMAIL_ITEM)
        With objMailItem

            .To = "This is the Addressee name"
            .Subject = "This is the Subject of the email"
            .Body = "This is the body of the email"

'           Disable error handling for the next step - this avoids an error which
'           occurs if the cancel button on the "Select Profile" dialog box is pressed
            On Error Resume Next

                If Not IsEmpty(vaFileNames) Then

                    For iFileNo = 1 To UBound(vaFileNames, 1)
                        .Attachments.Add vaFileNames(iFileNo)
                    Next iFileNo

                End If

            On Error GoTo 0

        .Display

        End With

    End With

    Set objMailItem = Nothing

End Sub


'=========================================================================================
'=========================================================================================


Private Function mvaFilenames() As Variant

    Const iFILE_DIALOG_OPEN As Integer = 1

    Dim strInitialPath      As String
    Dim vaFileNames         As Variant
    Dim vFileName           As Variant
    Dim iFileNo             As Integer

    Dim objShell            As Object
    Dim objWord             As Object
    Dim objFSO              As Object

    Set objShell = CreateObject("WScript.Shell")
    Set objWord = CreateObject("Word.Application")
    Set objFSO = CreateObject("Scripting.FileSystemObject")

    strInitialPath = objShell.ExpandEnvironmentStrings("%USERPROFILE%") & "\Desktop\"

    objWord.ChangeFileOpenDirectory (strInitialPath)

    With objWord.FileDialog(msoFileDialogOpen)

        .Title = "Select the file to process"
        .AllowMultiSelect = True
        .Filters.Clear
        .Filters.Add "All Files", "*.*"
        .Filters.Add "Excel Files", "*.xls;*.xlsx"
        .Filters.Add "Text Files", "*.txt"
        .Filters.Add "Various Files", "*.xls;*.doc;*.vbs"

        If .Show = -1 Then

             ReDim vaFileNames(1 To .SelectedItems.Count)
             iFileNo = 1

            For Each vFileName In .SelectedItems

                vaFileNames(iFileNo) = objFSO.getfile(vFileName)
                iFileNo = iFileNo + 1

            Next

        End If

    End With

    mvaFilenames = vaFileNames

End Function

I hope this helps - please let me know how you get on with it.

Regards,

Greg M