david_johnson_CR
New member
- Local time
- Today, 12:32
- Joined
- Dec 5, 2017
- Messages
- 7
Greetings,
I know this is a popular topic but I've read dozens of the related posts and none help me solve this problem. The code works perfectly without adding the attachment. When I try to add the attachment line I get "Operation Failed" error message. None of the other posts help me understand why. I've included just the problematic code and then below I included the whole thing in case its necessary. Thank you so much in advance for any help you could provide.
I can't tell if I'm missing something or if there's some syntax or typographical problem. Thanks!
This is just the relevant code:
Entire module:
I know this is a popular topic but I've read dozens of the related posts and none help me solve this problem. The code works perfectly without adding the attachment. When I try to add the attachment line I get "Operation Failed" error message. None of the other posts help me understand why. I've included just the problematic code and then below I included the whole thing in case its necessary. Thank you so much in advance for any help you could provide.
I can't tell if I'm missing something or if there's some syntax or typographical problem. Thanks!
This is just the relevant code:
Code:
If Len(Date) = 2 Then
docname = "h:\pmo_processes\recovery_communications\2017-12-04_grant_TandC\" & r("cert_official_entity") & "-Grant_Terms_Notification-" & Year(Date) & "-" & Month(Date) & "-" & Day(Date) & ".pdf"
Else
docname = "h:\pmo_processes\recovery_communications\2017-12-04_grant_TandC\" & r("cert_official_entity") & "-Grant_Terms_Notification-" & Year(Date) & "-" & Month(Date) & "-0" & Day(Date) & ".pdf"
End If
Set olApp = CreateObject("Outlook.application")
Set olItem = olApp.CreateItem(0)
With olItem
.ReplyRecipients.Add GCEmail
.To = COEmail
' aBody(lCnt) = "<HTML><body>" & asPreTable & "</body></html>"
.Subject = "DR | " & COEntity & " | Grant Terms & Conditions Notice"
.CC = TeamLeadEmail & "; " & GCEmail & "; " & COEmailBackup & "; " & RCEmail
.bcc = "communications@crmail.getadvantage.com"
.htmlbody = "<HTML><body>" & asPreTable & "</body></html>"
.SentOnBehalfOfName = "recovery.communications@cohnreznick.com"
.Attachments.Add = docname 'This is the problem code line
.Save
End WithEntire module:
Code:
Private Sub Command0_Click()
On Error GoTo MergeButton_Err
Dim objWord As Word.Application
'Start Microsoft Word.
Dim d As DAO.Database
Dim r As Recordset
Dim f As Recordset
Dim docname As String
Set d = CurrentDb()
Set r = d.OpenRecordset("source_data")
Dim GCEmail As String
Dim RCEmail As String
Dim COEmail As String
Dim send_date As Date
Dim olApp As Object
Dim olItem As Variant
Dim asPreTable As String
Dim str_app_SQL As String
Dim email_log As DAO.Recordset
' Dim aBody() As String
Dim COEmailBackup As String
Dim TeamLeadEmail As String
' Set email_log = grant_terms_and_conditions_blast.OpenRecordset("sent_email_log")
Set grants_terms_and_conditions_blast = CurrentDb
Set email_log = CurrentDb.OpenRecordset("sent_email_log")
send_date = Date
If Not r.EOF Then
Do
Set objWord = CreateObject("Word.Application")
With objWord
'Make the application visible.
.Visible = True
'Open the document.
.Documents.Open ("H:\pmo_processes\recovery_communications\2017-12-04_grant_TandC\grant_terms_and_conditions_email_template.doc")
'Move to each bookmark and insert text from the form.
.ActiveDocument.Bookmarks("co_address").Select
.Selection.Text = (CStr(r.Fields("cert_official_address")))
.ActiveDocument.Bookmarks("co_street").Select
.Selection.Text = (CStr(r.Fields("cert_official_street")))
.ActiveDocument.Bookmarks("disaster").Select
.Selection.Text = (CStr(r.Fields("disasters")))
.ActiveDocument.Bookmarks("date_sending").Select
.Selection.Text = (Date)
.ActiveDocument.Bookmarks("co_entity").Select
.Selection.Text = (CStr(r.Fields("cert_official_entity")))
.ActiveDocument.Bookmarks("recov_coord_name").Select
.Selection.Text = (CStr(r.Fields("recov_coord_name")))
.ActiveDocument.Bookmarks("recov_coord_phone").Select
.Selection.Text = (CStr(r.Fields("recov_coord_phone")))
.ActiveDocument.Bookmarks("gc_email").Select
.Selection.Text = (CStr(r.Fields("grant_coord_email")))
.ActiveDocument.Bookmarks("gc_name").Select
.Selection.Text = (CStr(r.Fields("grant_coord_name")))
.ActiveDocument.Bookmarks("gc_phone").Select
.Selection.Text = (CStr(r.Fields("grant_coord_phone")))
.ActiveDocument.Bookmarks("co_name").Select
.Selection.Text = (CStr(r.Fields("cert_official_name")))
.ActiveDocument.Bookmarks("recov_coord_email").Select
.Selection.Text = (CStr(r.Fields("recov_coord_email")))
End With
If Len(Date) = 2 Then
docname = "h:\pmo_processes\recovery_communications\2017-12-04_grant_TandC\" & r("cert_official_entity") & "-Grant_Terms_Notification-" & Year(Date) & "-" & Month(Date) & "-" & Day(Date) & ".pdf"
Else
docname = "h:\pmo_processes\recovery_communications\2017-12-04_grant_TandC\" & r("cert_official_entity") & "-Grant_Terms_Notification-" & Year(Date) & "-" & Month(Date) & "-0" & Day(Date) & ".pdf"
End If
'Print the document in the foreground so Microsoft Word will not close
'until the document finishes printing.
' objWord.ActiveDocument.PrintOut Background:=False
' objWord.ActiveDocument.SaveAs FileName:=docname, _
' FileFormat:=wdExportFormatPDF
objWord.ActiveDocument.ExportAsFixedFormat docname, wdExportFormatPDF, False, wdExportOptimizeForPrint, wdExportAllDocument
'Close the document without saving changes.
objWord.ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
'Quit Microsoft Word and release the object variable.
objWord.Quit
Set objWord = Nothing
asPreTable = "Good Morning, <br>" _
& "<br>Please find attached the Grant Terms and Conditions Notification. <br><br>"
GCEmail = DLookup("grant_coord_email", "source_data", "source_data_ID = " & r!source_data_ID)
RCEmail = DLookup("recov_coord_email", "source_data", "source_data_ID = " & r!source_data_ID)
COEmail = DLookup("cert_official_email", "source_data", "source_data_ID = " & r!source_data_ID)
COEmailBackup = DLookup("cert_official_alt_email", "source_data", "source_data_ID = " & r!source_data_ID)
TeamLeadEmail = DLookup("CR_team_lead_email", "source_data", "source_data_ID = " & r!source_data_ID)
Set olApp = CreateObject("Outlook.application")
Set olItem = olApp.CreateItem(0)
With olItem
.ReplyRecipients.Add GCEmail
.To = COEmail
' aBody(lCnt) = "<HTML><body>" & asPreTable & "</body></html>"
.Subject = "DR | " & COEntity & " | Grant Terms & Conditions Notice"
.CC = TeamLeadEmail & "; " & GCEmail & "; " & COEmailBackup & "; " & RCEmail
.bcc = "communications@crmail.getadvantage.com"
.htmlbody = "<HTML><body>" & asPreTable & "</body></html>"
.SentOnBehalfOfName = "recovery.communications@cohnreznick.com"
.Attachments.Add = docname 'This is the problem code line
.Save
End With
email_log.AddNew
email_log!sent_email_log_from = "recovery.communications@cohnreznick.com"
email_log!sent_email_log_to = COEmail & "; " & "; " & RCEmail & "; " & GCEmail & TeamLeadEmail & "; " & COEmailBackup & "; "
email_log!sent_email_log_date_sent = Now()
email_log!sent_email_log_subject = "DR | " & COEntity & " | Grant Terms & Conditions Notice"
email_log!applicant_name = COEntity
email_log.Update
MsgBox "update complete"
r.MoveNext
Loop Until r.EOF
End If
Exit Sub
MergeButton_Err:
'If a field on the form is empty, remove the bookmark text, and
'continue.
If Err.Number = 94 Then
objWord.Selection.Text = ""
Resume Next '''
'
' 'If the Photo field is empty.
ElseIf Err.Number = 2046 Then
MsgBox "Please add a photo to this record and try again."
Else
MsgBox Err.Number & vbCr & Err.Description
End If
Exit Sub
End Sub
