Question

我研究了这个主题，发现了很棒的代码 - 但并不是我需要的东西。我创建了一个Excel文件来设置一个范围，用于电子邮件分发附件到300个收件人 - 这很好。但我有多个附件需要转到同一个收件人。 A列是选择文件名的字段 - 为收件人1选取pdf。是否可以将B列用作收件人1的第二个pdf文件，如何将其循环？

Sub Mail_Report()
  Dim OutApp As Object
  Dim OutMail As Object

'Use presence of a Path to determine if a mail is sent.
  Set Rng = Range(Range("J2"), Range("J" & Rows.Count).End(xlUp))
  For Each cell In Rng
    Rw = cell.Row

    Path = cell.Value
    If Path <> "" Then 
    'Get Date info from Path
      'Dte = Right(Path, Len(Path) - InStrRev(Path, "\"))

    'Get Territory to check for filename (Column A)
      FilNmeStr = cell.Offset(0, -9).Value
   'Email Address
      ToName = cell.Offset(0, -5).Value
   'Subject Line
      SL = Cells(1, "K")

   'Create Recipient List
      For x = 1 To 4
        Recp = cell.Offset(0, -x).Value
        If Recp <> "" Then
          Recp = cell.Offset(0, -x).Value
        End If 
        RecpList = RecpList & ";" & Recp
      Next

      ccTo = RecpList

  'Get  Name
      FirstName = cell.Offset(0, -7).Value
      LastName = cell.Offset(0, -6).Value

  'Loop through files in Path to see if
      ClientFile = Dir(Path & "\*.*")

      Do While ClientFile <> ""
        If InStr(ClientFile, FilNmeStr) > 0 Then   
          AttachFile = Path & "\" & ClientFile      
          MailBody = "Hi " & FirstName & "," & vbNewLine & vbNewLine _
        End If
        ClientFile = Dir
      Loop

      Set OutApp = CreateObject("Outlook.Application")
      Set OutMail = OutApp.CreateItem(o)
      With OutMail
        .SentOnBehalfOfName = """TechSupport"" <TechSupport@anycompany.com>"
        .To = ToName
        .cc = ccTo
        .Subject = SL & " - " & cell.Offset(0, -9).Value
        .Body = MailBody
        .Attachments.Add (AttachFile)
        .Display
        '.Send
      End With
      Set OutMail = Nothing
      Set OutApp = Nothing
      RecpList = ""              
    End If
  Next
End Sub

Answer 1

以这种方式试试。

在Sheets（“Sheet1”）中创建一个列表：

In column A : Names of the people
In column B : E-mail addresses
In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)

宏将遍历“Sheet1”中的每一行，如果B列中有电子邮件地址和C列中的文件名：Z它将创建一个包含此信息的邮件并发送。

Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim FileCell As Range
    Dim rng As Range

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set sh = Sheets("Sheet1")

    Set OutApp = CreateObject("Outlook.Application")

    For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)

        'Enter the path/file names in the C:Z column in each row
        Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")

        If cell.Value Like "?*@?*.?*" And _
           Application.WorksheetFunction.CountA(rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)

            With OutMail
                .to = cell.Value
                .Subject = "Testfile"
                .Body = "Hi " & cell.Offset(0, -1).Value

                For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                    If Trim(FileCell) <> "" Then
                        If Dir(FileCell.Value) <> "" Then
                            .Attachments.Add FileCell.Value
                        End If
                    End If
                Next FileCell

                .Send  'Or use .Display
            End With

            Set OutMail = Nothing
        End If
    Next cell

    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

https://www.rondebruin.nl/win/s1/outlook/amail6.htm

MultiAttachment将varing文件分发给多个收件人

1 个答案: