Используйте перспективы Macro для отправки файлов по электронной почте

Question

Прикрепления всех файлов в папке с электронной почтой Outlook Microsoft с помощью кода макроса

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 по электронной почте

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