Outlook Attachment (1 Viewer)

david_johnson_CR

New member
Local time
Today, 03:55
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:
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 With

Entire 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
 

pbaldy

Wino Moderator
Staff member
Local time
Today, 01:55
Joined
Aug 30, 2003
Messages
36,118
The relevant tweaks that work for me:

Dim myattachments As Variant

Set myattachments = olItem.Attachments
myattachments.Add "C:\AccessAp\RedeemedException.pdf"
 

david_johnson_CR

New member
Local time
Today, 03:55
Joined
Dec 5, 2017
Messages
7
Worked! Thanks!! I knew it was probably something I was just missing. I really appreciate it.
 

pbaldy

Wino Moderator
Staff member
Local time
Today, 01:55
Joined
Aug 30, 2003
Messages
36,118
Happy to help and welcome to the site by the way!
 

Users who are viewing this thread

Top Bottom