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!