I'm modifying code for auto sending emails that I rec'd from Hans years ago. It appears to be working with the exception of the pdf not being saved for the email to attach it. I'm at a loss.
I stripped down the database to try to upload but keep getting a size error. The code I'm using is:
Code: Select all
Private Sub cmdEmailPrint_Click()
Dim strWhere As String
Dim strSQL As String
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim strFilename As String
Dim outApp As Object
Dim outMsg As Object
Dim blnStart As Boolean
Dim arrNames As Variant
Dim i As Long
On Error Resume Next
' Try to get running instance of Outlook
Set outApp = GetObject(Class:="Outlook.Application")
If outApp Is Nothing Then
' If Outlook wasn't running, start it
Set outApp = CreateObject(Class:="Outlook.Application")
If outApp Is Nothing Then
' We failed to start Outlook, so get out
MsgBox "We can't start Outlook, sorry!", vbCritical
Exit Sub
End If
' Set a flag that we started Outlook
blnStart = True
End If
On Error GoTo ErrHandler
' Create the where-condition
strWhere = " WHERE EmailInvoiceSent = False"
strSQL = "SELECT ALL * FROM [tblInvoice AutoTemp]" & strWhere
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(strSQL, dbOpenDynaset)
Do While Not rst.EOF
glngInvoiceID = rst!InvoiceID
strFilename = gstrPath
' Export report to PDF
' ConvertReportToPDF "rptInvoiceAuto", , strFilename, , False
'Stops code until invoice is looked at
DoCmd.OpenReport ReportName:="rptInvoiceAuto", View:=acViewPreview, WindowMode:=acDialog
' Ask user for permission to send
If MsgBox("Do you want to email this invoice?", vbQuestion + vbYesNo) = vbYes Then
' Convert report to PDF
DoCmd.OutputTo acOutputReport, "rptInvoiceAuto", acFormatPDF, strFilename
' Create a new e-mail message
Set outMsg = outApp.CreateItem(0) ' olMailItem
With outMsg
' Use the e-mail address field
'Main Email
arrNames = Split(rst![Email], ",")
For i = 0 To UBound(arrNames)
.Recipients.Add arrNames(i)
Next i
' Change the subject as needed
.Subject = rst![Event Name] & " Invoice "
' Change the body text as needed& vbCrLf & vbCrLf & Me.comment3
.Body = "Please remit payment for the attached invoice" & vbCrLf & vbCrLf & "Sincerely," & vbCrLf & vbCrLf & "Rebecca Turner"
' Attach the PDF file
.Attachments.Add strFilename
' Use ONE of the two following lines, not both
.Send ' to edit the message before sending
End With
' Set EmailFaxSent field to True, and EmailDateTimeSent to Now
rst.Edit
rst!EmailInvoiceSent = True
rst!EmailInvoiceDateSent = Now
rst.Update
' Optional: delete the PDF file after creating the e-mail
' Delete or comment out the next line if you don't want to delete the file
Kill strFilename
End If
rst.MoveNext
Me.lbxInvoice.Requery
Loop
' Optional: requery the list box
'Updates Invoice sent that got missed above
' DoCmd.OpenQuery "qryUpdateInvoiceEmailSent"
'Updates Invoice sent that were skipped to place on hold
' DoCmd.OpenQuery "qryUpdateInvoiceEmailSentnot"
Me.lbxInvoice.Requery
'___________________________________________________________________________________
ExitHandler:
On Error Resume Next
rst.Close
Set rst = Nothing
Set dbs = Nothing
If blnStart Then
outApp.Quit
End If
Set outMsg = Nothing
Set outApp = Nothing
Exit Sub
ErrHandler:
If Err = 2501 Then
Resume Next
Else
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End If
End Sub
Code: Select all
Option Compare Database
Option Explicit
Public Const gstrPath = "C:\DyslexiaACT\Invoices\"
Public glngInvoiceID As Long
Leesha