發送從Excel工作表中多個附件用VBA

Question

我有現有的代碼從一個表在我的Excel文件發送郵件 -

Sub CreateMail() 

    Dim objOutlook As Object 
    Dim objMail As Object 
    Dim rngTo As Range 
    Dim rngSubject As Range 
    Dim rngBody As Range 
    Dim rngAttach As Range 

    Set objOutlook = CreateObject("Outlook.Application") 
    Set objMail = objOutlook.CreateItem(0) 

    Application.ScreenUpdating = False 
    Worksheets("Mail List").Activate 

    With ActiveSheet 
     Set rngTo = .Range("B1") 
     Set rngSubject = .Range("B2") 
     Set rngBody = .Range("B3") 
     Set rngAttach = .Range("B4") 

    End With 

    With objMail 
     .To = rngTo.Value 
     .Subject = rngSubject.Value 
     .body = rngBody.Value 
     .Attachments.Add rngAttach.Value 
     .display 'Instead of .Display, you can use .Send to send the email _ 
        or .Save to save a copy in the drafts folder 
    End With 

    Set objOutlook = Nothing 
    Set objMail = Nothing 
    Set rngTo = Nothing 
    Set rngSubject = Nothing 
    Set rngBody = Nothing 
    Set rngAttach = Nothing 

End Sub 

不過，我想包括一些附件，因此 Set rngAttach = .Range("B4")不幫助做到這一點。

對此有何幫助？ 在此先感謝！

Answer 1

將循環中的.Attachments.Add語句括起來。像下面的東西可能會奏效

For i = 4 To 6 
     .Attachments.Add Range("B" & i).Value 
    Next i 

Answer 2

爲了使動態，你可以在B列i的上限設定爲最後一排

For i = 4 To Range("B" & rows.count).end(xlUp).row 
    .Attachments.Add Range("B" & i).Value 
Next i 

Answer 3

此更新的代碼：

1. 中查找文件名從B4
2. 使用Dir確保附加文件實際存在於指定路徑

3. 收拾工作表代碼（Activate是不必要的）

   Sub CreateMail() 
   
   Dim objOutlook As Object 
   Dim objMail As Object 
   Dim rngTo As Range 
   Dim rngSubject As Range 
   Dim rngBody As Range 
   Dim rngAttach As Range 
   Dim rng2 As Range 
   Dim ws As Worksheet 
   
   
   Set objOutlook = CreateObject("Outlook.Application") 
   Set objMail = objOutlook.CreateItem(0) 
   
   Application.ScreenUpdating = False 
   Set ws = Worksheets("Mail List") 
   
   With ws 
       Set rngTo = .Range("B1") 
       Set rngSubject = .Range("B2") 
       Set rngBody = .Range("B3") 
       Set rngAttach = ws.Range(ws.[b4], ws.Cells(Rows.Count, "B").End(xlUp)) 
   End With 
   
   With objMail 
       .To = rngTo.Value 
       .Subject = rngSubject.Value 
       .body = rngBody.Value 
       For Each rng1 In rngAttach.Cells 
        If Len(Dir(rng1)) > 0 Then .Attachments.Add rng1.Value 
       Next 
   
       .display 'Instead of .Display, you can use .Send to send the email _ 
          or .Save to save a copy in the drafts folder 
   End With 
   
   Set objOutlook = Nothing 
   Set objMail = Nothing 
   Set rngTo = Nothing 
   Set rngSubject = Nothing 
   Set rngBody = Nothing 
   Set rngAttach = Nothing 
   
   End Sub