The sub that is shooting the error is "SendExceptionEmail" it is called from within sub "cmd_send_report"
Thanks
Code:
Sub SendExceptionEmail(vDETAIL_01 As String, vDetail_02 As String)
'On Error GoTo eh
'define as an object late binding for differnet version of access
'
Dim olApp As New Outlook.Application
Set olApp = New Outlook.Application
Dim olFolder As Outlook.MAPIFolder
Dim olMail As Outlook.MailItem
Dim olNameSpace As Outlook.Namespace
Dim sFile As String
Dim lFile As Long
Dim sHtml As String
Dim olNewMail As Object
Set olNameSpace = olApp.GetNamespace("MAPI")
Set olFolder = olNameSpace.GetDefaultFolder(olFolderOutbox)
Set olNewMail = olApp.CreateItem(olMailItem)
' Output the report to HTML in the temp directory
sFile = "C:\Users\smith\Temp_Rpt\Open_Contract " & Format(Date, "yyyymmdd") & ".html"
' DoCmd.OpenReport "rpt_Email_Contracts", acViewPreview, , "Email_Contracts!EMAIL = '" & rst!EMAIL & "'"
DoCmd.OpenReport "rpt_Email_Contracts", acViewPreview, , "EMAIL = '" & rst!EMAIL & "'"
DoCmd.OutputTo acOutputReport, "rpt_Email_Contracts", acFormatHTML, sFile
DoCmd.Close
'Read in the HTML File
lFile = FreeFile
Open sFile For Input As lFile
sHtml = Input$(LOF(lFile) - 1, lFile)
Close lFile
'Put the file contents in the email body
olNewMail.To = vDETAIL_01
olNewMail.Subject = vDetail_02
olNewMail.HTMLBody = sHtml
olNewMail.Display
With olNewMail
.To = vDETAIL_01
.Subject = vDetail_02
olNewMail.HTMLBody = sHtml
.Send
End With
ex:
Set olApp = Nothing
Set olNewMail = Nothing
Set olFolder = Nothing
Set olNameSpace = Nothing
Exit Sub
eh:
Resume ex
End Sub
Private Sub cmd_send_report_Click()
On Error GoTo Err_Email_Report_Click
Dim stWhere As String '-- Criteria for DLookup
Dim varTo As Variant '-- Address for SendObject
Dim stText As String '-- E-mail text
Dim stSubject As String '-- Subject line of e-mail
Dim varEstimator As Variant
Dim strBody As String
Dim sHtml As String
Dim rst As DAO.Recordset
Set rst = CurrentDb.OpenRecordset("Select EMAIL FROM Email_Contracts_Header")
Do While Not rst.EOF
varTo = rst![EMAIL]
rst.MoveNext
stSubject = "Contracts waiting for your Approval"
'____________________________________________________________________
SendExceptionEmail (varTo), (stSubject)
'_____________________________________________________________________
Loop
' DoCmd.Close
On Error GoTo Err_Execute
' CurrentDb.Execute strSQL, dbFailOnError
On Error GoTo 0
Exit Sub
Err_Execute:
Resume Next
Exit_EMail_Report_Click:
Exit Sub
Err_Email_Report_Click:
MsgBox Err.Description
Resume Exit_EMail_Report_Click
End Sub