HELP__VBA Code to change Attachment file name for each loop. 1

[debq]

I am trying to automate a report distribution process using Access and Outlook 2007 and VBA. I have created a form for the user to enter a range of dates. I also have Query which points to the form as criteria. I would like to open the form, choose a range of dates and have the form open a report which will calculate scores per clinic, print the report to PDF, ADDING THE NAME OF THE CLINIC AS THE ATTACHMENT NAME then attach the report to an Outlook email. I am also trying to Loop the code through all clinics listed on the source tables.
My issue is that I cannot get the VBA code to set attachment name based on the clinic_name from the Recordsource MailList. My current code does not change the Attachment Name to the clinic_name from my query..... Please Help......
This is the complete code that I have so far:

Option Compare Database
Option Explicit

Public Function SendEMail()

Dim db As DAO.Database
Dim MailList As DAO.Recordset
Dim MyOutlook As Outlook.Application
Dim MyMail As Outlook.MailItem
Dim Subjectline As String
Dim BodyFile As String
Dim fso As FileSystemObject
Dim MyBody As TextStream
Dim MyBodyText As String
Dim MyNewBodyText As String


'==========================================================================
Set fso = New FileSystemObject

 ' Populate Subject Line
 
 Subjectline$ = InputBox$("Please enter the subject line for this mailing.", _
                 "Mystery Caller Survey Email All Reports!")

 ' If there's no subject, end Process.

If Subjectline$ = "" Then
    MsgBox "No subject line, no message." & vbNewLine & vbNewLine & _
        "Quitting...", vbCritical, "E-Mail Merger"
    Exit Function
End If
    
 ' Populate Body Text
 BodyFile$ = "F:\My UCLA Items\Mystery Caller\MystCallEmailScript.txt"

 ' If there's nothing to say, end process.

If BodyFile$ = "" Then
    MsgBox "No body, no message." & vbNewLine & vbNewLine & _
         "Quitting...", vbCritical, "No Message!"
    Exit Function
End If

 ' Check to make sure the file exists...
If fso.FileExists(BodyFile$) = False Then
    MsgBox "The body file isn't where you say it is. " & vbNewLine & vbNewLine & _
           "Quitting...", vbCritical, "No message!"
    Exit Function
End If

   ' Since we got a file, we can open it up.
    Set MyBody = fso.OpenTextFile(BodyFile, ForReading, False, TristateUseDefault)

   ' and read it into a variable.
    MyBodyText = MyBody.ReadAll

   ' and close the file.
    MyBody.Close

' Now, open Outlook for our own device..
    Set MyOutlook = New Outlook.Application
      
'=========================================================================
   ' Set up the database and query connections
  
    Set db = CurrentDb()
     
     
   Set MailList = db.OpenRecordset("Contacts1")
          
' Loop through the list of email addresses FROM Contacts1,
' adding them to e-mails and sending them.

    Do Until MailList.EOF

' This creates the e-mail
 
       Set MyMail = MyOutlook.CreateItem(olMailItem)
            
' This addresses it
    MyMail.To = MailList("email")
                        
'This gives it a subject
     MyMail.Subject = Subjectline$
            
'This gives it the body
        MyMail.Body = "Dear" & MailList("Contact_First") & "," & MyBodyText
        
 'This line will copy the "master" template into
 'a variable we can mess around with
 
 MyNewBodyText = MyBodyText
 
 MyNewBodyText = Replace(MyNewBodyText, "[[Contact_First]]", MailList("Contact_First"))
 
 
'=========================================================================
[b]'Set Attachment Name

Dim AttachmentName As String
Dim NewAttachmentName As String
 
AttachmentName = MailList("Clinic_Name") & ".pdf"

NewAttachmentName = AttachmentName
NewAttachmentName = Replace(NewAttachmentName, "[[Clinic_Name]]", MailList("Clinic_Name"))

   '  Setup Attachment Print to PDF
   DoCmd.OutputTo acOutputReport, "rptCallResultsPerClinic1", "PDFFormat(*.PDF)", "F:\temp\AttachmentName.pdf", True, "", , acExportQualityScreen
 [/b]  
   'This sends it!
   
    MyMail.Attachments.Add "F:\temp\AttachmentName.pdf", olByValue, 1, AttachmentName & ".pdf"
     
   MyMail.Save
     
    'And on to the next one...
    MailList.MoveNext

Loop
 
Set MyMail = Nothing

'MyOutlook.Quit
Set MyOutlook = Nothing

MailList.Close
Set MailList = Nothing
db.Close
Set db = Nothing
End Function

 

[Andrzejek]

Do you want something like:

[green]'Setup Attachment Print to PDF[/green]
   DoCmd.OutputTo acOutputReport, "rptCallResultsPerClinic1", "PDFFormat(*.PDF)", "F:\temp\[blue]" & AttachmentName,[/blue] True, "", , acExportQualityScreen

Have fun.

---- Andy

 

[debq]

Thank you sooooo much Andy!!!! That totally rocks!! I am new to VBA and will work on a problem for days before asking for help.. So your reply ends my many day struggle. Now I am on to my next fix and challenge..

Thanks again

Debra

 

[Andrzejek]

You are welcome, glad to help.

In your code:

'Set Attachment Name

Dim AttachmentName As String
Dim NewAttachmentName As String
 
AttachmentName = MailList("Clinic_Name") & ".pdf"

NewAttachmentName = AttachmentName
NewAttachmentName = Replace(NewAttachmentName, "[[Clinic_Name]]", MailList("Clinic_Name"))

Why have 2 AttachmentName variables? You have 2 that, at the end, contain the same info: Attachment File Name, right?

Consider:

Private Const strPath As String = "F:\temp\"
Dim AttachmentName As String
... 
AttachmentName = MailList("Clinic_Name") & ".pdf"

'  Setup Attachment Print to PDF
   DoCmd.OutputTo acOutputReport, "rptCallResultsPerClinic1", "PDFFormat(*.PDF)", strPath & AttachmentName, True, "", , acExportQualityScreen
   
   'This sends it!
   
    MyMail.Attachments.Add strPath & AttachmentName, olByValue, 1, AttachmentName

Also, if your F:\ drive is a network server, consider UNC name, not the letter drive, something like:[tt]
Private Const strPath As String = [blue]"\\ntsvr7\temp\"[/blue][/tt]


Have fun.

---- Andy

 

[debq]

Thanks so much for the additional help.

I added the following to my Declarations section

Private Const strPath As String = "F:\temp\"
Dim AttachmentName As String

And added the remainder to replace the "Set Attachment name section.

But I am now getting a compile error "Invalid attribute in Sub or Function"

Have I added the code to the correct sections?? Or do I need to declare the constant as a Function??

Thanks so much for your help

Debra

 

[debq]

Ok... I got it......

Dim strPath As String
strPath = "G:\temp\"
Dim AttachmentName As String
...
AttachmentName = MailList("Clinic_Name") & ".pdf"

'  Setup Attachment Print to PDF
   DoCmd.OutputTo acOutputReport, "rptCallResultsPerClinic_EmailAll", "PDFFormat(*.PDF)", strPath & AttachmentName, True, "", , acExportQualityScreen
   
   'This sends it!
   
    MyMail.Attachments.Add strPath & AttachmentName, olByValue, 1, AttachmentName

 

[Andrzejek]

If you use Constant, you need to have it in General Declaration portion of your code:

Option Compare Database
Option Explicit
[blue]
Private Const strPATH As String = "F:\temp\"
[/blue]
Public Function SendEMail()
...

The good side of Const is that you canNOT re-assign its value in code, ie:[tt]
strPATH = "C:\SomeFolder\"[/tt]
that's why it is a constant. Just the 'safety' issue.

But you are fine declaring it and using it as you have it now.


Have fun.

---- Andy

 

[debq]

I have one more issue.(I did post this as a new Thread also as it is kind of a new issue I think)

My code will now do the following:

1. Add the Subject Line
2. Add the Body Text
3. Add the "Dear" + "Contact_First" and "To:Email"
4. Loop through all "Contact_First" and "email"
5. And Saves all email in my Outlook Draft folder

My Code will not Print my report based upon the date range entered into my form "frmEmailAllReports"
And
It will not add the Attachment to the email after creating the report for each clinic based upon the query "qryMyEmailAddresses"
And
It does not add a copy of the attachment to my "temp" folder.
Please Help.....
Here is my current code:

'Sources: "frmEmailAllReports" = txtStartDate, txtEndDate, cboClinic_Name
'.......: "Contacts1" = Table including Clinic_Name, Email,Contact_First, Contact_Last
'.......: "Results" = Table including Clinic_Name, Call Results
'.......: "qryMyEmailAddresses" SELECT Results.Clinic_Name, Results.Clinic_Staff_Name, Results.Time_of_Call, Results.Length_of_Call, Results.Date_of_call,
            'Results.TimeOnHold, Results.Hold, Results.First_Available_Date, Results.Promptness, Results.ID_self, Results.ID_dept, Results.Offered_Assistance,
            'Results.Tone, Results.Pace, Results.Respect, Results.Connected, Results.Hold_protocol, Results.Exit, Results.Call_Terminated, Results.Comments,
            'Contacts1.Contact_First, Contacts1.Contact_Last, Contacts1.Email FROM Results INNER JOIN Contacts1 ON Results.Clinic_Name = Contacts1.Clinic_Name
            'WHERE (((Results.Clinic_Name)=[Form]![frmEmailAllReports]![txtClinic_Name]) AND ((Results.Date_of_call) Between [Form].[frmEmailAllReports].
            '[(StartDate)] And [Form].[frmEmailAllReports].[(EndDate)]));
'.......: "qryMystCallbyFPGClinicOverallEmailAll" SELECT * From Results WHERE (((Results.Date_of_call) Between [FORM]![frmEmailAllReports]![StartDate] And
            '[FORM]![frmEmailAllReports]![EndDate]));

'.......: "rptMystCallsbyFPGClinicEmailAll_SubReport"  = Subreport to calculate % correct for ALl FPG Calls Correct
'.......: "rptMystCallsbyClinicEmailAll_Subreport" = SubReport to calculate Clinic level % correct
'.......: "rptMystCall_CallDetail_EmailAllSubReport" = Subreport to provide call details
'.......: "rptCallResultsPerClinic_EmailAll" = Main Report includes above three SubReports
'==============================================================================================================================

Option Compare Database
Option Explicit
Private Const strPath As String = "F:\temp\"
Dim AttachmentName As String


Public Function SendEMail()

On Error Resume Next

Dim db As DAO.Database
Dim MailList As DAO.Recordset
Dim MyOutlook As Outlook.Application
Dim MyMail As Outlook.MailItem
Dim Subjectline As String
Dim BodyFile As String
Dim fso As FileSystemObject
Dim MyBody As TextStream
Dim MyBodyText As String
Dim MyNewBodyText As String

Dim strSQL As String
Dim strQueryName As String
Dim qryDef As QueryDef
Dim StartDate As Date
Dim EndDate As Date

'==================================================================================
        Set fso = New FileSystemObject
' Populate Subject Line
 
        Subjectline$ = InputBox$("Please enter the subject line for this mailing.", _
                 "Mystery Caller Survey Email All Reports!")

' If there's no subject, end Process.

        If Subjectline$ = "" Then
         MsgBox "No subject line, no message." & vbNewLine & vbNewLine & _
        "Quitting...", vbCritical, "E-Mail Merger"
    Exit Function
End If
    
' Populate Body Text
        BodyFile$ = "F:\My UCLA Items\Mystery Caller\MystCallEmailScript.txt"
' If there's nothing to say, end process.

        If BodyFile$ = "" Then
         MsgBox "No body, no message." & vbNewLine & vbNewLine & _
         "Quitting...", vbCritical, "No Message!"
    Exit Function
End If

' Check to make sure the file exists...
        If fso.FileExists(BodyFile$) = False Then
         MsgBox "The body file isn't where you say it is. " & vbNewLine & vbNewLine & _
           "Quitting...", vbCritical, "No message!"
    Exit Function
End If

' Since we got a file, we can open it up.
        Set MyBody = fso.OpenTextFile(BodyFile, ForReading, False, TristateUseDefault)

' and read it into a variable.
        MyBodyText = MyBody.ReadAll

' and close the file.
         MyBody.Close

' Now, open Outlook for our own device..
         Set MyOutlook = New Outlook.Application
 
'====================================================================================
   ' Set up the database and query connections
 'set variable values
        Set db = CurrentDb
        strQueryName = "qryMyEmailAddresses"

'
'Notice below how we inserted the variable as a parameter value - Visual Basic will evaluate strMonth and insert the value for us.
        strSQL = "SELECT Results.Clinic_Name, Results.Date_of_Call FROM Results WHERE (((Results.Clinic_Name)=[Form]![frmEmailAllReports]![Clinic_Name])" _
        & "((Results.Date_of_call) Between [FORM]![frmEmailAllReports]![StartDate] And [FORM]![frmEmailAllReports]![EndDate])); LIKE '" & StartDate & EndDate & "';"
  
'Create query definition
         Set qryDef = db.CreateQueryDef(strQueryName, strSQL)

         Set MailList = db.OpenRecordset("Contacts1")
          
' Loop through the list of email addresses FROM Contacts1,
' adding them to e-mails and sending them.

         Do Until MailList.EOF

' This creates the e-mail
 
         Set MyMail = MyOutlook.CreateItem(olMailItem)
            
' This addresses it
          MyMail.To = MailList("email")
                        
'This gives it a subject
        MyMail.Subject = Subjectline$
'========================================================

 'This line will copy the "master" template into
 'a variable we can mess around with
 
         MyNewBodyText = MyBodyText
         MyNewBodyText = Replace(MyNewBodyText, "[[Contact_First]]", MailList("Contact_First"))
 
'This gives it the body
         MyMail.Body = "Dear" & "  " & MailList("Contact_First") & "," & MyNewBodyText
         
'============================================================
         AttachmentName = MailList("Clinic_Name") & ".pdf"
   
'  Setup Attachment Print to PDF
         
         DoCmd.OutputTo acOutputReport, "rptCallResultsPerClinic_EmailAll", "PDFFormat(*.PDF)", strPath & AttachmentName, True, "", , acExportQualityScreen
   
   'This sends it!
   
            MyMail.Attachments.Add strPath & AttachmentName, olByValue, 1, AttachmentName
            MyMail.Save
             
 'And on to the next one...
            MailList.MoveNext
        
            Loop
         
            Set MyMail = Nothing
        
'MyOutlook.Quit
            Set MyOutlook = Nothing
            MailList.Close
            Set MailList = Nothing
            db.Close
            Set db = Nothing
        
   End Function