送Email帶多個附件

Question

我對 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. 使用 FileDialog 框，我希望出現的初始文件夾與當前工作簿的文件夾位置相同，以減少搜索文件的次數。

以下是我到目前為止所擁有的。 我想不通的是讓 FileDialog 框在 Workbook 原始文件夾中打開。

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

更新，這是我最終使用的

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