Excel VBA Send Email Error!

ewheet2

Hello.

I have a VBA program that is supposed to Send a Selection from an excel workbook to hard coded email addresses.It is set up to run every morning at 8am. It never errors when I just run it but once I put it into production every fourth day I recieve the following error:

'Application error:
The instruction at "0x6508cb2a referenced memory at "0x00000008." The memory could not be read.'

Below is my code:

Sub Selection()
Application.OnTime TimeValue("08:00:00"), "Selection"
Dim rng1 As Range
Dim dateToFind As Date
Dim foundDate As Range
Dim Source As Range
Dim OutApp As Object
Dim OutMail As Object
Dim StrBody As String

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

dateToFind = CLng(Date)

With Sheets("Sheet1").Range("A:G")
Set foundDate = .Find(What:=dateToFind, _
After:=.Cells(.Cells.Count), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not foundDate Is Nothing Then
Application.Goto foundDate, True
Else
MsgBox "Nothing found"
End If
End With

ActiveCell.Select
Set TopCell = ActiveCell
Set BottomCell = Cells(ActiveCell.Row + 29, ActiveCell.Column)
Range(TopCell, BottomCell).Select

Set Source = Nothing
On Error Resume Next
Set Source = Range(TopCell, BottomCell)
On Error GoTo 0

If Source Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If

Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
StrBody = "Below is the Cross Functional Production schedule for today. Please note that if there is a problem with production, a notification will be sent." & "


"
With OutMail
.To = "ewheet2@uic.edu"
.CC = ""
.BCC = ""
.Subject = "Today's Production Calendar"
.HTMLBody = StrBody & RangetoHTML(Source)
.Send 'or .Display
End With
On Error GoTo 0

With Application
.EnableEvents = True
.ScreenUpdating = True
End With

Set OutMail = Nothing
Set OutApp = Nothing
End Sub

Function RangetoHTML(Source As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook

TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy;;;dd-mm-yy") & ".htm"

'Copy the range and create a new workbook to past the data in
Source.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With

'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With

'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")

'Close TempWB
TempWB.Close savechanges:=False

'Delete the htm file we used in this function
Kill TempFile

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function



Please help!