Question

使用宏代码将文件夹的所有文件附加到Microsoft Outlook电子邮件

Dim fldName As String
Sub SendFilesbuEmail()
    ' From slipstick.me/njpnx
    Dim sFName As String

    i = 0

    fldName = "C:\Users\"

    sFName = Dir(fldName)

    Do While Len(sFName) > 0
        Call SendasAttachment(sFName)
        sFName = Dir
        i = i + 1
        Debug.Print fName
    Loop

    MsgBox i & " files were sent"
End Sub

Function SendasAttachment(fName As String)
    Dim olApp As Outlook.Application
    Dim olMsg As Outlook.MailItem
    Dim olAtt As Outlook.Attachments

    Set olApp = Outlook.Application
    Set olMsg = olApp.CreateItem(0) ' email
    Set olAtt = olMsg.Attachments

    ' attach file
    olAtt.Add (fldName & fName)

    ' send message
    With olMsg
        .Subject = "Here's that file you wanted"
        .To = "abcde@gmail.com"
        .HTMLBody = "Hi " & olMsg.To & ", <br /><br /> I have attached " & fName & " as you requested."
        .Send
    End With
End Function

我发送的文件为0，文档未通过电子邮件转移到Microsoft Outlook

Answer 1

要将所有文件附加到一个电子邮件中，请尝试修改代码。

实施例

Option Explicit
Dim FilesPath As String
Sub SendFilesbuEmail()
    Dim File As String
    Dim i As Long

    FilesPath = Environ("USERPROFILE") & "\Desktop\"
    'FilesPath = "C:\Users\Om3r\Desktop\FolderName\"
    File = Dir(FilesPath)

    Call SendasAttachment(File)

End Sub

Function SendasAttachment(File As String)
    Dim olApp As Object ' Outlook.Application
    Dim olMsg As Object ' Outlook.MailItem
    Dim Atmts As Object ' Outlook.Attachments

    Dim i As Long

    Set olApp = CreateObject("Outlook.Application")
    Set olMsg = olApp.CreateItem(0) ' email
    Set Atmts = olMsg.Attachments
    i = 0

    ' send message
    With olMsg

        Do While Len(File) > 0
            Atmts.Add (FilesPath & File)
            File = Dir
            i = i + 1
        Loop
        .Display
        .Subject = "Here's that file you wanted"
        .To = "alias@domain.com"
        .HTMLBody = "Hi " & olMsg.To & ", <br /><br /> I hav attch Files"
    End With

    MsgBox i & " Files were sent"

    Set olMsg = Nothing
    Set Atmts = Nothing


End Function

确保将FilesPath = Environ("USERPROFILE") & "\Desktop\FolderName\" FolderName更新为正确的文件夹名称。

您还可以使用FilesPath = "C:\Users\Om3r\Desktop\FolderName\"并确保更新Om3r和FolderName

使用Outlook宏通过电子邮件发送文件

1 个答案: