送Email带多个附件

Question

I am very new to VBA. I trying to have a Button that will generate an Outlook HTML formatted Email to send to the designated email address (designated by cell) and be able to attach multiple files located in the same folder as the workbook. With the FileDialog box I would like the initial folder that comes up to be the same folder location as the current workbook to reduce having to search for the files.

Below is what I have so far. What I cant figure out is out to get the FileDialog box to open at the Workbook origin folder.

Private Sub CommandButton1_Click()
    Dim xStrFile As String
    Dim xFilePath As String
    Dim xFileDlg As FileDialog
    Dim xFileDlgItem As Variant
    Dim xOutApp As Outlook.Application
    Dim xMailOut As Outlook.MailItem
    Application.ScreenUpdating = False
    Set xOutApp = CreateObject("Outlook.Application")
    Set xMailOut = xOutApp.CreateItem(olMailItem)
    Set xFileDlg = Application.FileDialog(msoFileDialogFilePicker)
    If xFileDlg.Show = -1 Then
        With xMailOut
         .Display
            .To = Range("C14").Value
            .Subject = Range("B6").Value & " " & Range("B7").Value & " - " & Range("B9").Value & " Tile Estimate"
            .HTMLBody = Range("B14").Value & "," & "<br/>" & vbCrLf & "Here is our tile estimate for the" & Range("B6").Value & " " & Range("B7").Value & " - " & Range("B9").Value & " project. Please respond to this email to confirm that you have received the proposal." & .HTMLBody
                        For Each xFileDlgItem In xFileDlg.SelectedItems
                .Attachments.Add xFileDlgItem
            Next xFileDlgItem
            .Display
        End With
    End If
    Set xMailOut = Nothing
    Set xOutApp = Nothing
    Application.ScreenUpdating = True
End Sub

Private Sub CommandButton3_Click()

End Sub

Answer 1

Update, here is what I ended up using

Sub Email_1()


Dim xStrFile As String
    Dim xFilePath As String
    Dim xFileDlg As FileDialog
    Dim xFileDlgItem As Variant
    Dim xOutApp As Outlook.Application
    Dim xMailOut As Outlook.MailItem
    Application.ScreenUpdating = False
    Set xOutApp = CreateObject("Outlook.Application")
    Set xMailOut = xOutApp.CreateItem(olMailItem)
    Set xFileDlg = Application.FileDialog(msoFileDialogFilePicker)
    
    xFileDlg.Filters.Clear
    xFileDlg.Filters.Add "pdf files", "*.pdf"
    xFileDlg.AllowMultiSelect = True
    xFileDlg.InitialFileName = ThisWorkbook.Path
    
    If xFileDlg.Show = -1 Then
                              
        With xMailOut
         .Display
            .To = Range("C13").Value
            .Subject = Range("B5").Value & " " & Range("B6").Value & " - " & Range("B8").Value & " Tile Estimate"
            .HTMLBody = "<p style='font-family:calibri;font-size:12.0pt'>" & Range("B13").Value & "," & "<br/>" & vbCrLf & "Here is our tile estimate for the " & Range("B5").Value & " " & Range("B6").Value & " - " & Range("B8").Value & " project. Please respond to this email to confirm that you have received the proposal." & .HTMLBody
                        For Each xFileDlgItem In xFileDlg.SelectedItems
                .Attachments.Add xFileDlgItem
            Next xFileDlgItem
            .Display
        End With      
                
            End If
    Set xMailOut = Nothing
    Set xOutApp = Nothing
    Application.ScreenUpdating = True

End Sub