将多个文件或整个目录附加到电子邮件

Question

我正在尝试通过 Excel VBA 发送一封带有多个附件的 Outlook 电子邮件。

如果我指定一个附件/文件的路径，则代码有效。如果我确切地知道它们是什么，我也可以添加多个附件，但我不会。将有不同的计数以及文件名。

我很想使用通配符发送，如下面的示例所示，但我认为我需要使用某种指向目录的循环。

我看了，但我还没有看到任何适合我的情况的东西。

Private Sub Command22_Click()
    Dim mess_body As String
    Dim appOutLook As Outlook.Application
    Dim MailOutLook As Outlook.MailItem
    Set appOutLook = CreateObject("Outlook.Application")
    Set MailOutLook = appOutLook.CreateItem(olMailItem)

    Set appOutLook = CreateObject("Outlook.Application")
    Set MailOutLook = appOutLook.CreateItem(olMailItem)
    With MailOutLook
        .BodyFormat = olFormatRichText
        .To = "test@test.org"
        .Subject = "test"
        .HTMLBody = "test"
        .Attachments.Add ("H:\test\Adj*.pdf")
        '.DeleteAfterSubmit = True
        .Send
    End With
    MsgBox "Reports have been sent", vbOKOnly
End Sub

Answer 1

试试这个

Private Sub Command22_Click()
    Dim mess_body As String, StrFile As String, StrPath As String
    Dim appOutLook As Outlook.Application
    Dim MailOutLook As Outlook.MailItem
    
    Set appOutLook = CreateObject("Outlook.Application")
    Set MailOutLook = appOutLook.CreateItem(olMailItem)

    '~~> Change path here
    StrPath = "H:\test\"
    
    With MailOutLook
        .BodyFormat = olFormatRichText
        .To = "test@test.org"
        .Subject = "test"
        .HTMLBody = "test"

        '~~> *.* for all files
        StrFile = Dir(StrPath & "*.*")
        
        Do While Len(StrFile) > 0
            .Attachments.Add StrPath & StrFile
            StrFile = Dir
        Loop
        
        '.DeleteAfterSubmit = True
        .Send
    End With
    
    MsgBox "Reports have been sent", vbOKOnly
End Sub

Answer 2

我来自比利时，我的英语不是很好。 我稍微更改了 Siddharth Rout 的代码，它可以工作。 非常非常感谢悉达多！！找这个很久了

Private Sub Knop99_Click()

Dim mess_body 作为字符串，StrFile 作为字符串，StrPath 作为字符串 将 ÒutApp 调暗为对象 将 Outmail 作为对象调暗

Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.LogOn

Set Outmail = OutApp.CreateItem(0)

'~~> Wijzig hiet het pad
StrPath = "E:\Documenten\Conntracten\Test\Digitaal verstuurde contracten\"

With Outmail
     .To = '"test@test.org"
    .Subject = "test"
    .Body = "test"

    '~~> *.* Alle bestanden in de geselecteerde map worden als bijlage bij de email gevoegd
    StrFile = Dir(StrPath & "*.*")

    Do While Len(StrFile) > 0
        .Attachments.Add StrPath & StrFile
        StrFile = Dir
    Loop
    
    MsgBox "De conceptmail staat klaar", vbOKOnly

    .DeleteAfterSubmit = True
    
   ' MsgBox "De conceptmail staat klaar", vbOKOnly
    
    .Display
End With
 
Set Outmail = Nothing
Set OutApp = Nothing

结束子