asked on

Automation - Access form on Button Click - Email Merge

I currently am modifying someone elses database. This is what exists now.

1) There is a button on a form that runs a macro.

2) The Macro runs a query that exports the results to an excel file.

3) The user then goes to a Mail merge word template and opens it and is prompted to run a query that grabs the data from the excel file to merge it into the document.
4) The user Copies the mail merged document into the body of the email and looks up the email address in the above excel file and sends the email.

I am trying automate the whole process to where it sends the email to the users draft folder. I found a solution that I am trying to modify to our needs. I posted a link to what I have found below.

The difference in this is I don't want to choose an email address or a file name or the title. I want to get the address from the excel file and the name of the file is always the same and so will the title of the email. So there is one button click.

http://www.tek-tips.com/faqs.cfm?fid=6950

Since the mail merge is already created on button click I am thinking the tasks that I need to add are:

1) Open the word doc and click yes to run the merge.
2) Copy the doc into email drafts with email address and subject included.

Here is the code I have so far. It is not yet working but I think I am on the right track.

A little newer at the coding thing so any suggestions are appreciated.

Option Compare Database
' Set Constants
Const WORD_TEMPLATE = "C:\Documents and Settings\kmoyer\Desktop\McDonalds\POSS Mail Merge.Doc"
Const POSS_DIR = "C:\Documents and Settings\kmoyer\Desktop\McDonalds"
Const DEFAULT_EMAIL = "kmoyer@LPL.com"


Private Sub Cmd_EmailPoss_Click()

' Runs Macro that runs a query to Export data to excel file which holds Client ifo for merge.

On Error GoTo Err_Cmd_EmailPOSS_Click

Dim stDocName As String

stDocName = "mcr_Export Letter POSS"
DoCmd.RunMacro stDocName


Dim sFile As String
Dim i As Integer
Dim itm As Object
Dim ID As String
Dim wd As Word.Application
Dim Doc As Word.Document
Dim objApp As Outlook.Application
Dim l_Msg As MailItem
Dim oReceipt As Outlook.Recipient

' Open file

sFile = WORD_TEMPLATE

sFile = "C:\Documents and Settings\kmoyer\Desktop\McDonalds\POSS Mail Merge.Doc"

Set wordapp = CreateObject("Word.Application")

'Open template document
wordapp.Documents.Open sFile
wordapp.Visible = True

Set wordapp = Nothing

Clear_Lists

'Copy to outlook

'get email address record set

Set rs = CurrentDb.OpenRecordset("SELECT [Email] FROM _
"C:\Documents and Settings\kmoyer\Desktop\McDonalds\Export Records_POSS.xls ", dbOpenSnapshot, dbSeeChanges)" & _

Exit Sub
End Select

[censored] = " Client Name" ' Set title.

' Display message, title

sSubject = ("Client Name", [censored])

Set rs = Nothing
Exit Sub


sFile = C:\Documents and Settings\kmoyer\Desktop\McDonalds\POSS Mail Merge.Doc

Set wd = CreateObject("Word.Application")

Set Doc = wd.Documents.Open(FileName:=sFile, ReadOnly:=True)
Set itm = Doc.MailEnvelope.Item
With itm
.To = DEFAULT_EMAIL
.Subject = sSubject
.Save
ID = .EntryID
End With

'clear references
Doc.Close wdDoNotSaveChanges
wd.Quit False

Set itm = Nothing
Set Doc = Nothing
Set wd = Nothing

' start email and get saved item
Set objApp = CreateObject("Outlook.Application")

Set l_Msg = objApp.GetNamespace("MAPI").GetItemFromID(ID)

With l_Msg

'Loop over recipients
Do While Not rs.EOF
Set oReceipt = .Recipients.Add(rs.Fields("Email"))
oReceipt.Type = olCC
rs.MoveNext
Loop

rs.Close
Set rs = Nothing


.Display
End With


'clear references

Set oReceipt = Nothing
Set l_Msg = Nothing
Set objApp = Nothing

Exit_Cmd_EmailPOSS_Click:
Exit Sub

Err_Cmd_EmailPOSS_Click:
MsgBox Err.Description
Resume Exit_Cmd_EmailPOSS_Click

End Sub

Open in new window

Nick67

Hi kmoyer9717,

Wow, sounds like you've got a lot of extra steps in there. Why is excel used at all? Have the mail merge use the Access query as the data source--unless you are doing some hand editing of the recipients. Why is it using Word instead of an Access Report -- is there hand editing too?

Anyway, this sub pulls the client's email address from the table, attachs some files that exist, and pastes the content of one of the files into the body of the email message

Public Sub CreateAnEmail(ClientName As String)
On Error Resume Next

Dim db As Database
Dim rs As Recordset
Dim ClientEmail As String
Dim DisplayMsg As Boolean
Dim AttachmentPath As String
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
Dim objOutlookExplorers As Outlook.Explorers
Dim myarray() As String
Dim myaddresses() As String
Dim x As Integer
Dim fs As Object
Dim BuiltPath As String
Dim response As Integer
Dim WasOpen As Boolean

DisplayMsg = True
'AttachmentPath = "c:\somefolder\somefile.doc"
MsgBox "The email is about to be created!" & vbCrLf & _
        "If nothing appears to be happening, the Outlook security box may be hiding behind an open window." & vbCrLf & _
        "Click the Outlook icon on the taskbar to bring it to the front, if necessary."

Set objOutlook = GetObject(, "Outlook.Application")
'MsgBox Err.Number & " " & Err.Description
If Err.Number = 429 Then 'Outlook was already open
    Err.Clear
    WasOpen = False
    ' Create the Outlook session.
    Set objOutlook = CreateObject("Outlook.Application")
    
Else
    WasOpen = True
End If
    Dim ns As Outlook.NameSpace
    Dim Folder As Outlook.MAPIFolder
    Set ns = objOutlook.GetNamespace("MAPI")
    Set Folder = ns.GetDefaultFolder(olFolderInbox)
    Set objOutlookExplorers = objOutlook.Explorers
    
If WasOpen = False Then
    objOutlook.Explorers.Add Folder
    Folder.Display
    'done opening
End If

AppActivate "Microsoft Outlook"
    'For x = 1 To objOutlook.Explorers.count
        'objOutlookExplorers.Item(x).WindowState = olMaximized
        'objOutlookExplorers.Item(x).Activate
   ' Next x



' Create the message.
'Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
With objOutlookMsg
    If Not ClientName Like "*@*" Then
        Set db = CurrentDb
'if you don't pass in a valid email, it goes looking to tblClients for a matching name
'it will carry on and not pre-address the email if it finds nothing

        Set rs = db.OpenRecordset("select [client email] from tblclients where [client name] = " & Chr(34) & ClientName & Chr(34) & ";", dbOpenDynaset, dbSeeChanges)
        If rs.RecordCount <> 0 Then
            ClientEmail = Nz(rs![Client Email], "")
        Else
            ClientEmail = ""
        End If
        rs.Close
        db.Close
        Set db = Nothing
        Set rs = Nothing
    Else
        ClientEmail = ClientName
    End If
   
'My [Client Email] field is memo, and multiple emails separated by semi-colons are stored in it
 
    If Nz(ClientEmail, "") <> "" Then
    ' Add the To recipient(s) to the message.
    myaddresses = Split(ClientEmail, ";")
    For x = LBound(myaddresses) To UBound(myaddresses)
        Set objOutlookRecip = .Recipients.Add(myaddresses(x))
        objOutlookRecip.Type = olTo
    Next x
    End If
  
'added all the recipients with the above loop  
    
   
    'can't do this, the mail never gets sent
    ' Add the from recipient(s) to the message.
    'Set objOutlookRecip = .Recipients.Add("me@mydomain.com")
    'objOutlookRecip.Type = olOriginator
    
    ' Add the CC recipient(s) to the message.
    Set objOutlookRecip = .Recipients.Add("me@mydomain.com")
    objOutlookRecip.Type = olCC

   ' Add the BCC recipient(s) to the message.
    Set objOutlookRecip = .Recipients.Add("me@mydomain.com")
    objOutlookRecip.Type = olBCC
    
   ' Set the Subject, Body, and Importance of the message.
         .Subject = "This is your email"
         .Body = "This is an automated sending by me as requested." & vbCrLf & vbCrLf & _
   "Please respond to me@mydomain.com  with any inquiries"
   '.Importance = olImportanceHigh  'High importance

          
'to paste a document's contents in you need HTML formatted email messages

        .BodyFormat = olFormatHTML
        Dim ts As Object
        Set fs = CreateObject("Scripting.FileSystemObject")
        If fs.FileExists( "c:\somefolder\somefile.doc")= False Then
            GoTo skipHTML
        End If
        Set ts = fs.GetFile("c:\somefolder\somefile.doc").OpenAsTextStream(1, -2)
        .HTMLBody = "<p>This is an automated sending by me@mydomain.com as requested. </p>Please respond to me@mydomain.com with any inquiries.</P><br><br>"
        .HTMLBody = .HTMLBody & ts.ReadAll
    End If
    
skipHTML:
    
   ' Add attachments to the message.
        AttachmentPath =  "c:\somefolder\somefile.doc"
    If Not IsMissing(AttachmentPath) Then
        Set objOutlookAttach = .Attachments.Add(AttachmentPath)
    End If
    
            
   ' Resolve each Recipient's name.
   For Each objOutlookRecip In .Recipients
       objOutlookRecip.Resolve
   Next

   ' Should we display the message before sending?
   If DisplayMsg Then
       .Display
   Else
       .Save
       .Send
   End If
End With




Set objOutlook = Nothing

End Sub

Open in new window

Helen Feddema

Yes, you don't need Excel. And maybe you don't need Word either. Why not just paste the data from the Access record directly into the email message? If you need formatting, you can do this using the HTMLBody property of the email, as in the code sample below.

Public Sub CreateEmails()
'Created by Helen Feddema 31-Jan-2010
'Last modified by Helen Feddema 7-Feb-2010

On Error GoTo ErrorHandler

   Dim appOutlook As New Outlook.Application
   Dim dtePickup As Date
   Dim dteSold As Date
   Dim msg As Outlook.MailItem
   Dim rstAll As DAO.Recordset
   Dim rstSingle As DAO.Recordset
   Dim strBody As String
   Dim strCompany As String
   Dim strEMail As String
   Dim strFCFNumber As String
   Dim strGrade1 As String
   Dim strGrade2 As String
   Dim strHeader As String
   Dim strHTMLBody As String
   Dim strLine1 As String
   Dim strLine2 As String
   Dim strNotes As String
   Dim strQueryAll As String
   Dim strQuerySingle As String
   Dim strSignature As String
   Dim strSubject As String
   
   Set dbs = CurrentDb
   strQueryAll = "qrySendEmails"
   Set rstAll = dbs.OpenRecordset(strQueryAll)
   strQuerySingle = "qryTempEmail"
   strSignature = "</table><br><br><font face='Book Antiqua', size=5>" _
      & "<align='left'><u>John Doe</u></font><br>" _
      & "<font face='Arial', size=3><br>" _
      & "VP of Sales and Marketing<br>" _
      & "JD Inc.<br>" _
      & "Ph: 555-112-9601<br>" _
      & "Fx: 555-112-9422<br>"
   Debug.Print "Signature: "; strSignature
   
   Do While Not rstAll.EOF
      'Create filtered recordset for this customer
      lngSupplierID = Nz(rstAll![CustomerID])
      
      If lngSupplierID <> 0 Then
         strSQL = "SELECT * FROM " & strQueryAll & " WHERE " _
            & "[CustomerID] = " & lngSupplierID & ";"
      End If
   
      Debug.Print "SQL for " & strQuerySingle & ": " & strSQL
      lngCount = CreateAndTestQuery(strQuerySingle, strSQL)
      Debug.Print "No. of items found: " & lngCount
      If lngCount = 0 Then
         strPrompt = "No records found; canceling"
         strTitle = "Canceling"
         MsgBox strPrompt, vbOKOnly + vbCritical, strTitle
         GoTo ErrorHandlerExit
      Else
         'Create email for this customer
         strHTMLBody = ""
         strHeader = "<font face='Arial', size=3>" _
            & "Please schedule the following: <br><br>" _
            & "<table width='791' border='1'>" _
            & "   <tr>" _
            & "      <td width='283'height='26' nowrap valign='bottom'" _
            & "align='left'><font face='Arial', size=3><strong>Grade</strong></font></td>" _
            & "      <td width='127' height='26'nowrap valign='bottom'" _
            & "align='left'><font face='Arial', size=3><strong>FCF Pickup #</strong></font>" _
            & "      <td width='144'height='26' nowrap valign='bottom'" _
            & "align='left'><font face='Arial', size=3><strong>Pickup Date</strong></font></td>" _
            & "      <td width='237'height='26' nowrap valign='bottom'" _
            & "align='left'><font face='Arial', size=3><strong>Notes</strong></font></td>" _
            & "   </tr>"

         Set rstSingle = dbs.OpenRecordset(strQuerySingle)
         strEMail = Nz(rstSingle![EmailAddress])
         strCompany = Nz(rstSingle![strCompany])
         strSubject = "Loads for " & strCompany
         
         'Create email for this customer
         Set msg = appOutlook.CreateItem(olMailItem)
         msg.To = strEMail
         msg.Subject = strSubject
         msg.BodyFormat = olFormatHTML
         
         'Process loads per customer
         Debug.Print "Processing load(s) for " & strCompany
         strBody = ""
         
         Do While Not rstSingle.EOF
            strLine1 = ""
            strLine2 = ""
            strGrade1 = ""
            strGrade2 = ""
            strSlipNo = Nz(rstSingle![SlipNo])
            dteSold = Nz(rstSingle![DateSold])
            dtePickup = Nz(rstSingle![ScheduledPickup])
            strFCFNumber = Nz(rstSingle![FCFNumber])
            strGrade1 = Nz(rstSingle![Grade1])
            Debug.Print "Grade 1: " & strGrade1
            strGrade2 = Nz(rstSingle![Grade2])
            Debug.Print "Grade 2: " & strGrade2
            strNotes = Nz(rstSingle![Notes])
            
            'Create line of body text
            strLine1 = "<font face='Arial', size=3" _
               & "   <tr>" _
               & "      <td width='283'valign='bottom' align='left'>" & strGrade1 & "</td>" _
               & "      <td width='127' valign='bottom' align='left'>" & strFCFNumber _
               & "      <td width='144'valign='bottom' align='left'>" _
               & Format(dtePickup, "m/d/yyyy") & "</td>" _
               & "      <td width='237'valign='bottom' align='left'>" & strNotes & "</td>" _
               & "   </tr></font>"
            Debug.Print "Line 1: " & strLine1
            
            If strGrade2 <> "" Then
               strLine2 = "<font face='Arial', size=3>" _
                  & "   <tr>" _
                  & "      <td width='283'valign='bottom' align='left'>" & strGrade2 & "</td>" _
                  & "      <td width='127' valign='bottom' align='left'>" & strFJDNumber _
                  & "      <td width='144'valign='bottom' align='left'>" _
                  & Format(dtePickup, "m/d/yyyy") & "</td>" _
                  & "      <td width='237'valign='bottom' align='left'>" _
                  & strNotes & "</font></td>" _
                  & "   </tr>"
            End If
            Debug.Print "Line 2: " & strLine2
         
            strHTMLBody = strHTMLBody & strLine1 & strLine2
            rstSingle.MoveNext
         Loop
         
         strHTMLBody = strHeader & strHTMLBody & strSignature
         Debug.Print "Message HTML body: " & strHTMLBody
         
         msg.HTMLBody = strHTMLBody
         msg.Display
         
      End If
      rstAll.MoveNext
   Loop
   
ErrorHandlerExit:
   Exit Sub

ErrorHandler:
   MsgBox "Error No: " & Err.Number _
      & " in CreateEmails procedure; " _
      & "Description: " & Err.Description
   Resume ErrorHandlerExit

End Sub

Open in new window

kmoyer9717

ASKER

Hi All,

This is just what I needed to wrap my brain around this. The database was built by someone else years ago and I had alot of the same questions with the mail merge part. Seems like alot of steps.

Not sure what I was thinking trying to build on what was already there. Much easier to redo the process.

I will work on your suggestions and respond back once finished.

Thanks so much for the input as this validated my thoughts and gets my brain functioning.

Kelly

kmoyer9717

ASKER

I started from scratch and created my letter based on a query as a report. I used the date as a parameter but really want the current record on the form where my email button is located.

I think I am getting myself confused a bit.

Since I am not using the attachment file and I am using a report within access I am not sure what I need to do with the report. Do I replace the file Attachment path with:

DoCmd.OpenReport "Rpt_POSS_Email_LETTER", acViewReport, "", "[Reports]![Rpt_POSS_Email_LETTER]![ACCOUNT_NUM]=[Forms]![frm_RESOLUTION_ALL_OLD]![ACCOUNT_NUM] And [Reports]![Rpt_POSS_Email_LETTER]![ACT_DATE]=[Forms]![frm_RESOLUTION_ALL]![RCVD_DATE]", acNormal

I am stuck at this point and not sure what I need next.

Help please! It is much appreciated.

Kelly

Nick67

Hey,

There are a bunch of different ways to go about it. If the underlying query returns only the record that you want, then all the filtering becomes unnecessary.

dim stdocname as string
stdocname = "Rpt_POSS_Email_LETTER"
DoCmd.OpenReport stdocname, acViewReport, acNormal

In the underlying query, put your parameters as Forms!MyForm!MyControl and put a command button in the details part of the form. If you are in continuous records mode on the form (are you?), the button will replicate on each detail line, but the report query will pick up the current values for each of your parameters.

You'll then get your report.

What method are you going to use to email it? If you are in Access 2007 or later, you can save out the report to PDF with no added hassle. I have code on the go for Access 2003 using doPDF as the PDF generator. Will you need the contents of the report pasted into the body of the email message still?

Nick67

kmoyer9717

ASKER

Thanks for responding so fast.

There is a form and a subform . The form is a single form and the subform is continuous.

As far as the email goes the letter(Report) needs to be copied into a draft email, get the email address from qry or form, and the subject line is clientName so the user can just review and send it.

I appologize for seeming not so smart in this area. I am newer at the coding thing. I have shocked myself with some of the things that I have been able figure out but I still don't have a complete grasp on it all .

Thanks for helping me with this.

Kelly

Nick67

Ok,

So the cmd button needs to go on the subform. The parameters for the reports query get a liitle snakier in syntax. Instead of forms!myform!mycontrol they need to be

forms!myform!mysubform.Forms!mycontrol

That gets a little ugly.

Easier by far is to put hidden controls on the parent form.
Then, in the Click Event of the button you can put

me.parent.myhiddencontrol.value = me.mycontrol.value.

The parameters in the query can then be

forms!myform!myhiddencontrol

Which is a lot easier to debug :)

Are you using Access 2007 or later?

Nick67

kmoyer9717

ASKER

Thanks I am going to try the hidden Controls.

I am using Access 2007.

Nick67

That makes saving out your report as a PDF simple after you have the free add-in installed then:

Private Sub SaveAsOfficePDF(stdocname As String)
Dim FormatValue As String
If Application.Version > 11 Then 'Access 2007 or later
    FormatValue = "PDF Format (*.pdf)"
Else
    exit sub
End If
DoCmd.OutputTo acOutputReport, stdocname, FormatValue, "c:\somepath\somefile" & ".pdf"

End Sub

Open in new window

Nick67

That'll leave getting the report into the body of the mail message.
Is that REALLY what you need -- 'cause that is tough -- and may be why they were kludging around with Word and Excel.

After you get your report working the way you want Export it as HTML and see how it looks.
Nailing in the report to the body of the mail message isn't hard IF the html export looks good.

If it doesn't...well, we'll blow up that bridge afterward.

Nick67

kmoyer9717

ASKER

Ok My report opens on button click. I didn't have to use hidden controls. The button is on the main form and the code below is what I used. I used this for a different database that I did that I had a similar issue to grab the current record for a report.

Dim strWhere As String
If Me.Dirty Then 'Save any edits.
Me.Dirty = False
End If
If Me.NewRecord Then 'Check there is a record to print
MsgBox "Select a record to print"
Else
strWhere = "[ID] = " & Me.[ID]
DoCmd.OpenReport "Rpt_POSS_Email_Letter", acViewPreview, , strWhere
End If
End Sub

Now that that worked I exported to HTML. It keeps the formatting pretty much but does not export my banner or my footer which are both pictures.

Thanks again for helping me.

Kelly

Nick67

That they are pictures is good :)
They can then get nailed into the .html body in the right spots.
Now you just need to sew it all up together in one piece

1. export the report to html --> so you can import that into the email message body
2. export it to pdf for attachment, if you want that
3. create an email
4. address it
5. add the .HTMLBody contents
6. add the attachment, if you want that
7. do something with the email message

Nick67

1. Send it to HTML
This sub will send "rptRecertDocs" in HTML to "c:\tempPdf\test.html",

Private Sub ExportMyReportToHTML_Click()
Dim stdocname As String
Dim FormatValue As String

FormatValue = acFormatHTML
stdocname = "rptRecertDocs"

DoCmd.OutputTo acOutputReport, stdocname, FormatValue, "c:\tempPdf\test.html", True
End Sub

Open in new window

Nick67

2. Send it to PDF
That code I've posted already.

Nick67

3. create an email mesaage
There are a few considerations here. In my own code, I left the possibility for multiple addresses to be used. I also left the possibility for multiple attachments to be added. The other thing that had to be accounted for was whether Outlook was open already.

The following is the first chunk of the code that gets and email started. It assumes you will be passing in a semicolon (;) delimited string with the file names of attachments and another semi-colon delimited string of email addresses It also assumes that those attachments will be staged in a folder called c:\tempPDF. All the declarations (DIM statements) for the whole code are done near the beginning

Public Sub CreateAnEmail(reportcaption As String, ClientName As String)
On Error Resume Next
Dim db As Database
Dim rs As Recordset
Dim ClientEmail As String
Dim DisplayMsg As Boolean
Dim AttachmentPath As String
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
Dim objOutlookExplorers As Outlook.Explorers
Dim myarray() As String
Dim myaddresses() As String
Dim x As Integer
Dim fs As Object
Dim BuiltPath As String
Dim response As Integer
Dim WasOpen As Boolean

'this splits the attachments string into an array for use later
myarray = Split(reportcaption, ";")
'MsgBox UBound(MyArray, 1)


DisplayMsg = True
'talk to the user
MsgBox "The email is about to be created!" & vbCrLf & _
        "If nothing appears to be happening, the Outlook security box may be hiding behind an open window." & vbCrLf & _
        "Click the Outlook icon on the taskbar to bring it to the front, if necessary."

Set objOutlook = GetObject(, "Outlook.Application")
'MsgBox Err.Number & " " & Err.Description
If Err.Number = 429 Then 'outlook may not be open
    Err.Clear
    WasOpen = False
    ' Create the Outlook session.
    Set objOutlook = CreateObject("Outlook.Application")
    
Else
    WasOpen = True
End If
    Dim ns As Outlook.NameSpace
    Dim Folder As Outlook.MAPIFolder
    Set ns = objOutlook.GetNamespace("MAPI")
    Set Folder = ns.GetDefaultFolder(olFolderInbox)
    Set objOutlookExplorers = objOutlook.Explorers
    
If WasOpen = False Then
    objOutlook.Explorers.Add Folder
    Folder.Display
    'done opening
End If

AppActivate "Microsoft Outlook"
    'For x = 1 To objOutlook.Explorers.count
        'objOutlookExplorers.Item(x).WindowState = olMaximized
        'objOutlookExplorers.Item(x).Activate
   ' Next x



' Create the message.
'Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)

Open in new window

Nick67

4. addressing
Continuing on in that same sub procedure, now the message needs to be addressed.
Split the ClientName string you passed in into an array and add a recipient for each array value
Add yourself as a CC and a BCC if you want

With objOutlookMsg
    ClientEmail = ClientName
    
    If Nz(ClientEmail, "") <> "" Then
    ' Add the To recipient(s) to the message.
    myaddresses = Split(ClientEmail, ";") 'split the string you passed in and add each of them a recipeints
    For x = LBound(myaddresses) To UBound(myaddresses)
        Set objOutlookRecip = .Recipients.Add(myaddresses(x))
        objOutlookRecip.Type = olTo
    Next x
    End If
   
        
    ' Add the CC recipient(s) to the message.
    Set objOutlookRecip = .Recipients.Add("me@mydomain.com")
    objOutlookRecip.Type = olCC

   ' Add the BCC recipient(s) to the message.
    Set objOutlookRecip = .Recipients.Add("me@mydomain.com")
    objOutlookRecip.Type = olBCC

Open in new window

Nick67

5. add the .HTMLBody contents
You could add a subject if you like.
its just .Subject = "Some Subject"

Next is the HTML Body

You can concatenate in any HTML you like, and then pull in the html file you exported in Step 1

.BodyFormat = olFormatHTML
        Dim ts As Object
        Set fs = CreateObject("Scripting.FileSystemObject")
        If fs.FileExists("c:\tempPDF\test.htm") = False Then
            GoTo skipHTML
        End If
'gets your export as a textstream
        Set ts = fs.GetFile("c:\tempPDF\Summary.htm").OpenAsTextStream(1, -2)
        .HTMLBody = "<p>This is an automated sending by me as requested. </p>Please respond to me with any inquiries.</P><br><br>"
'at this point pull in your header
'<img source = "c:\someplace\myheaderimage.jpg">
'pulls in the textstream
        .HTMLBody = .HTMLBody & ts.ReadAll
'at this point pull in your footer
'<img source = "c:\someplace\myfooterimage.jpg">

    End If
    
skipHTML:

Open in new window

Nick67

Gotta go for lunch.
It'll be a bit for the rest

kmoyer9717

ASKER

Just found out that I don't need the pictures in the email. They only used those when they faxed the letter. Hooray... I will bypass the .pdf as I don't need that part. Below is my code through the HTML creation.

Private Sub Cmd_EmailPoss_Click()

Dim strWhere As String
Dim FormatValue As String
Dim stdocname As String

If Me.Dirty Then 'Save any edits.
Me.Dirty = False
End If

If Me.NewRecord Then 'Check there is a record to print
MsgBox "Select a record to print"
Else
strWhere = "[ID] = " & Me.[ID]
DoCmd.OpenReport "Rpt_POSS_Email_Letter", acViewPreview, , strWhere
End If
FormatValue = acFormatHTML
stdocname = "Rpt_POSS_Email_Letter"

DoCmd.OutputTo acOutputReport, stdocname, FormatValue, "c:\temp\RptEmail.html", True
End Sub

Now I will create the email.

Thanks for this. Breaking it in pieces has really helped me tons to learn this.

ASKER CERTIFIED SOLUTION

Nick67

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

kmoyer9717

ASKER

Thanks for all the help. Below is my final code and it works the way I need it to.

The only thing that I have to resolve is when the html gets to the email it throws a couple of items off to the right. I will play with this to resolve.

Dim db As Database
Dim rs As Recordset
Dim ClientEmail As String
Dim DisplayMsg As Boolean
Dim AttachmentPath As String
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
Dim objOutlookExplorers As Outlook.Explorers
Dim myarray() As String
Dim myaddresses() As String
Dim x As Integer
Dim fs As Object
Dim BuiltPath As String
Dim response As Integer
Dim WasOpen As Boolean
Dim strWhere As String
Dim FormatValue As String
Dim stdocname As String

'This gets the current record

If Me.Dirty Then 'Save any edits.
Me.Dirty = False
End If

If Me.NewRecord Then 'Check there is a record to print
MsgBox "Select a record to print"
Else
strWhere = "[ID] = " & Me.[ID]
DoCmd.OpenReport "Rpt_POSS_Email_Letter", acViewPreview, , strWhere
End If

'This exports the letter to HTML

FormatValue = acFormatHTML
stdocname = "Rpt_POSS_Email_Letter"

DoCmd.OutputTo acOutputReport, stdocname, FormatValue, "c:\temp\RptEmail.html", True
DoCmd.Close acOutputReport, stdocname, acSaveNo

'This creates the email

DisplayMsg = True
AttachmentPath = "c:\Temp\RptEmail.HTML"
MsgBox "The email is about to be created!"

Set objOutlook = GetObject(, "Outlook.Application")
'MsgBox Err.Number & " " & Err.Description
If Err.Number = 429 Then 'Outlook was already open
Err.Clear
WasOpen = False
' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")

Else
WasOpen = True
End If
Dim ns As Outlook.Namespace
Dim Folder As Outlook.MAPIFolder
Set ns = objOutlook.GetNamespace("MAPI")
Set Folder = ns.GetDefaultFolder(olFolderInbox)
Set objOutlookExplorers = objOutlook.Explorers

If WasOpen = False Then
objOutlook.Explorers.Add Folder
Folder.Display
'done opening
End If

Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
With objOutlookMsg
If Me.[Txt_EMAIL] Like "*@*" Then
ClientEmail = Me.[Txt_EMAIL]
Else
ClientEmail = ""
End If

'My [Client Email] field is memo, and multiple emails separated by semi-colons are stored in it

If Nz(ClientEmail, "") <> "" Then
' Add the To recipient(s) to the message.
myaddresses = Split(ClientEmail, ";")
For x = LBound(myaddresses) To UBound(myaddresses)
Set objOutlookRecip = .Recipients.Add(myaddresses(x))
objOutlookRecip.Type = olTo
Next x
End If

'added all the recipients with the above loop

'can't do this, the mail never gets sent
'Add the from recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add("me@mydomain.com")
objOutlookRecip.Type = olOriginator

' Add the CC recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add("me@mydomain.com")
objOutlookRecip.Type = olCC

' Set the Subject, Body, and Importance of the message.
.Subject = Me.FIRST_NAME + " " + Me.LAST_NAME

'to paste a document's contents in you need HTML formatted email messages
.BodyFormat = olFormatHTML
Dim ts As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Set ts = fs.GetFile("c:\Temp\RptEmail.HTML").OpenAsTextStream(1, -2)
.BodyFormat = olFormatHTML
.HTMLBody = "</P><br><br>"
.HTMLBody = .HTMLBody & ts.ReadAll

' Save the message for review before sending.
.Save

Set objOutlook = Nothing

End With
End Sub

Thanks again Nick and I will award the points.

Kelly

kmoyer9717

ASKER

Thanks for explaining as you went this was a great learning experience for me.

Nick67

No Problem.
Thank Helen as well. Googling code examples that she has posted over time is what got me started with Access/Outlook coding. She has done nice, well documented code.

She has also books on the subject :)

I'm glad you got it beat into shape.

Nick67

kmoyer9717

ASKER

Also wanted to say thanks to Helen for sharing her knowledge over time.

I have been reading your stuff and you are amazing.

Kelly