發送帶有附件的電子郵件VBA

Question

我一直無法運行此代碼，其想法是它會提取C列中的每封電子郵件，並在單元格D1中附加文件路徑。 但是它不斷出錯

“運行時錯誤91-未設置對象變量或帶塊變量”。

我試圖從https://www.rondebruin.nl/win/s1/outlook/amail6.htm復制並改編此代碼

Sub Send_WeeklyUpdatePack()
'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
    Dim SourceFile As String
    Dim DestinationFile As String
    Dim strto As String

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

    ThisWorkbook.Sheets("Weekly Update Directory").Range("D1") = ThisWorkbook.Sheets("Automation").Range("D22") 'Picks up correct filepath

    Set sh = Sheets("Weekly Update Directory")

    Set OutApp = CreateObject("Outlook.Application")

    For Each cell In sh.Columns("C").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" Then
            strto = strto & cell.Value & ";"
        End If
    Next cell
    If Len(strto) > 0 Then strto = Left(strto, Len(strto) - 1)

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

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

            With OutMail
                .To = strto
                .Subject = "Weekly update pack"
                .Body = "Hi all," & vbNewLine & vbNewLine & "Please find attached the updated weekly pack." & vbNewLine & vbNewLine & "Kind Regards," & vbNewLine & vbNewLine & "VBA Noob"

                '& 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

                .Display  'Or use .Display/.Send
            End With

            Set OutMail = Nothing
        End If

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

我是VBA的新手（2周），所以向正確的方向進行解釋/調整將不勝感激

Answer 1

我修改了下面的代碼，它似乎可以運行，盡管我不確定為什么，因此我本人和將來的讀者都會非常感謝任何解釋原因的評論。

Sub Send_WeeklyUpdatePack()
'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
    Dim SourceFile As String
    Dim DestinationFile As String
    Dim strto As String

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

    ThisWorkbook.Sheets("Weekly Update Directory").Range("D1") = ThisWorkbook.Sheets("Automation").Range("D22")

    Set sh = Sheets("Weekly Update Directory")

    Set OutApp = CreateObject("Outlook.Application")

    For Each cell In sh.Columns("C").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" Then
            strto = strto & cell.Value & ";"
        End If
    Next cell
    If Len(strto) > 0 Then strto = Left(strto, Len(strto) - 1)

        'Enter the path/file names in the C:Z column in each row
            Set rng = ThisWorkbook.Sheets("Weekly Update Directory").Range("D1")
        'Set rng = ThisWorkbook.sh.Range("D1")

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

            With OutMail
                .To = strto
                .Subject = "Weekly update pack"
                .Body = "Hi all," & vbNewLine & vbNewLine & "Please find attached the updated weekly pack." & vbNewLine & vbNewLine & "Kind Regards," & vbNewLine & vbNewLine & "VBA Noob"

                '& 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

                .Display  'Or use .Display/.Send
            End With

            Set OutMail = Nothing
        'End If

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

謝謝