将单个附件从文件文件夹发送给另一个人

Question

我有一个包含50个文件的文件夹，并且我有50个电子邮件地址的列表。每个文件都转到不同的电子邮件地址。有没有办法编写执行此任务的宏？

下面的代码集存在两个问题：1）我在一个Excel文件中有3列数据：一个用于主题，一个用于发送电子邮件地址，第三个用于存储要附加附件的文件路径。

下面的代码不允许使用一组预定的主题参数。它还使用ROWS？的文件路径字段，而不是像发送到这样的列？令人困惑。

Sub Send_Files()
    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

Answer 1

这里是一个简单的例子，假设col A = Email, Col B = Subject & Col C = Path

Option Explicit
Public Sub Example()
   Dim olApp As Object
   Dim olMail As Object
   Dim olRecip As Object
   Dim olAtmt As Object
   Dim iRow As Long
   Dim Recip As String
   Dim Subject As String
   Dim Atmt As String

   iRow = 2

   Set olApp = CreateObject("Outlook.Application")

   Dim Sht As Worksheet
   Set Sht = ThisWorkbook.Worksheets("Sheet1")

   Do Until IsEmpty(Sht.Cells(iRow, 1))

      Recip = Sht.Cells(iRow, 1).Value
      Subject = Sht.Cells(iRow, 2).Value
      Atmt = Sht.Cells(iRow, 3).Value ' Attachment Path

      Set olMail = olApp.CreateItem(0)

      With olMail
         Set olRecip = .Recipients.Add(Recip)
        .Subject = Subject
        .Body = "Hi "
        .Display
         Set olAtmt = .Attachments.Add(Atmt)
         olRecip.Resolve
      End With

      iRow = iRow + 1

   Loop

   Set olApp = Nothing
End Sub