Send email with attachments VBA - vba

Question

I have been having trouble getting this code to run, the idea is that it picks up every email in column C, and attaches the file path in cell D1.
However it keeps falling over with error
"Run time error 91 - Object variable or With block variable not set".
I have attempted to copy and adapt this code from 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
I'm relatively new to VBA (2 weeks) so an explanation/nudge in the right direction would be greatly appreciated

Answer 1

I amended the code as below and it appears to run, although I am not sure why so any comments to explain what was causing the issue would be greatly apprecaited by myself and future readers.
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
thanks