如何在Excel VBA发送Outlook邮件功能中添加浏览选择附件的功能

步骤1：用户表单新增附件选择功能 #

你需要先在现有的UserForm上添加3个控件：

• 列表框：名称设为lst_Attachments，用来显示用户已选择的附件路径
• 按钮1：名称设为btn_AddAttachment，显示文本为「添加附件」
• 按钮2：名称设为btn_RemoveAttachment，显示文本为「移除选中附件」

然后给两个按钮添加点击事件代码：

' 添加附件按钮点击事件
Private Sub btn_AddAttachment_Click()
    Dim fd As FileDialog
    Dim i As Integer
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .Title = "选择要上传的附件"
        .AllowMultiSelect = True ' 允许多选文件
        If .Show = -1 Then
            For i = 1 To .SelectedItems.Count
                ' 避免重复添加同一个文件
                Dim isExist As Boolean
                isExist = False
                For j = 0 To lst_Attachments.ListCount - 1
                    If lst_Attachments.List(j) = .SelectedItems(i) Then
                        isExist = True
                        Exit For
                    End If
                Next
                If Not isExist Then lst_Attachments.AddItem .SelectedItems(i)
            Next i
        End If
    End With
    Set fd = Nothing
End Sub

' 移除选中附件按钮点击事件
Private Sub btn_RemoveAttachment_Click()
    If lst_Attachments.ListIndex <> -1 Then
        lst_Attachments.RemoveItem lst_Attachments.ListIndex
    End If
End Sub

步骤2：修改原有邮件生成函数，添加附件批量导入逻辑 #

在原有的CreationMail函数中，添加遍历附件列表、批量添加到邮件的逻辑，修改后的完整代码如下：

Function CreationMail(criticité As String)
    Dim xFile As String
    Dim xFormat As Long
    Dim Wb As Workbook
    Dim Wb2 As Workbook
    Dim FilePath As String
    Dim FileName As String
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Dim rng As Range
    ' 新增附件遍历相关变量
    Dim attachPath As Variant
    
    Set Sheet1 = ThisWorkbook.Sheets("Formulaire")
    Set rng = Sheets("Formulaire").Range("C6:D11").SpecialCells(xlCellTypeVisible)
            
    Application.ScreenUpdating = False
    Set Wb = Application.ActiveWorkbook
    ActiveSheet.Copy
    Set Wb2 = Application.ActiveWorkbook
    Select Case Wb.FileFormat
    Case xlOpenXMLWorkbook:
    xFile = ".xlsx"
    xFormat = xlOpenXMLWorkbook
    Case xlOpenXMLWorkbookMacroEnabled:
    If Wb2.HasVBProject Then
        xFile = ".xlsm"
        xFormat = xlOpenXMLWorkbookMacroEnabled
        Else
        xFile = ".xlsx"
        xFormat = xlOpenXMLWorkbook
    End If
    Case Excel8:
        xFile = ".xls"
        xFormat = Excel8
    Case xlExcel12:
        xFile = ".xlsb"
        xFormat = xlExcel12
    End Select
    FilePath = Environ$("temp") & "\"
    FileName = "STATSAE" & "_" & Format(Now, "yymmdd") & "_" & Format(Now, "hhnnss")

    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)
    Wb2.SaveAs FilePath & FileName & xFile, FileFormat:=xFormat
            
    With OutlookMail
        .To = ";" & ";"
        .CC = ""
        If criticité = "Haute" Then
            .Importance = olImportanceHigh
        End If
        If criticité = "" Then
            .Importance = olImportanceNormal
        End If
        If criticité = "Faible" Then
            .Importance = olImportanceNormal
        End If
        .Subject = "Request" & Space(1) & FileName
        ' 添加原始表单附件
        .Attachments.Add Wb2.FullName
        ' 新增：遍历用户选择的附件，批量添加
        For Each attachPath In UserForm1.lst_Attachments.List ' 这里UserForm1改成你实际的表单名称
            ' 校验文件是否存在，避免报错
            If Dir(attachPath) <> "" Then
                .Attachments.Add attachPath
            End If
        Next
        .Body = "Please find the requested information" & vbCrLf & "Best Regards"
        .HTMLBody = RangetoHTML(rng)
        .Display
    End With
            
    Wb2.Close
    Kill FilePath & FileName & xFile
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
    Application.ScreenUpdating = True

End Function

注意事项 #

• 上面代码中的UserForm1需要替换成你实际使用的用户表单的名称
• 如果不需要多文件选择，把AllowMultiSelect = True改成False即可
• 代码自带重复文件校验、文件存在性校验，避免重复添加和报错

内容的提问来源于stack exchange，提问作者holy_spirit