使用VBA将文件附加到电子邮件

Question

我正在尝试编写一个宏，以自动生成并发送电子邮件到地址列表，同时在每个文件上附加一个特定文件。
我对VBA编码还是有点绿色，我在下面“套用了”，但是在弄清楚如何正确读取文件路径时遇到了麻烦。

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("List")

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:C1")

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

        With OutMail
            .To = cell.Value
            .Subject = "Curent Week Supplies"
            .Body = "Good Morning" & Cells(cell.Row, "A").Value _
                & vbNewLine & vbNewLine & _
                    "Please find attached this week's CWS file." & _
                vbNewLine & vbNewLine & _
                    "If you have any queries concerning this then please feel free to contact us." & _
                vbNewLine & vbNewLine & _
                    "Best regards"

            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
        End With

        Set OutMail = Nothing
    End If
Next cell

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

当宏尝试附加文件时，它陷入了这个问题：-

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

Answer 1

您可以尝试吗？：

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("List")

Set OutApp = CreateObject("Outlook.Application")

For Each cell In sh.Range("B1:B" & sh.Range("c1048576").End(xlUp).Row)

    'Enter the path/file names in the C:Z column in each row
    Set rng = sh.Range("C1:C" & sh.Range("c1048576").End(xlUp).Row)

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

        With OutMail
            .To = cell.Value
            .Subject = "Curent Week Supplies"
            .Body = "Good Morning" & Cells(cell.Row, "A").Value _
                & vbNewLine & vbNewLine & _
                    "Please find attached this week's CWS file." & _
                vbNewLine & vbNewLine & _
                    "If you have any queries concerning this then please feel         free to contact us." & _
                vbNewLine & vbNewLine & _
                    "Best regards"

            'For Each FileCell In sh.Range("C1:C" &     sh.Range("c1048576").End(xlUp).Row)
            'If IsEmpty(FileCell.Value) Then Exit For

             .Attachments.Add cell.Offset(0, 1).Value
            'Next FileCell

            'Take a look before send
            '.display

            .Send
        End With

        Set OutMail = Nothing
    End If
Next cell

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