Прикрепление файлов к электронной почте с помощью 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