troubleshooting Question

Attach Excel Files to Outlook Emails from Access

Avatar of shieldsco
shieldscoFlag for United States of America asked on
OutlookMicrosoft AccessVBA
13 Comments1 Solution92 ViewsLast Modified:
I am trying to attach an external Excel files to emails from a folder using the following code.  The file name is in an Access table. For each email there is a related Excel file with the name of file equal to the tblTempShipNotice.Adjudicator. The email address is in the same table.


 
  Dim sMail                 As String
    Dim objOutlook            As Object
    Dim rs                    As DAO.Recordset
    Dim sSQL                  As String
    Dim strName               As String
    Dim sSubj                 As String
    Dim sBody                 As String
    Dim sTo                   As String
    Dim strCC                 As String
    Dim sCC                   As String

    'Get Email Addres
'    sSQL = "SELECT tblTempShipNotice.Email, tblTempShipNotice.Lname FROM tblTempShipNotice;"
    sSQL = "SELECT tblTempShipNotice.Email, tblTempShipNotice.Lname, Concatenate(""SELECT Emails FROM tblFO WHERE FO='"" & Nz([FO],""~999"") & ""';"","";"") AS CCEmails " & vbCrLf & _
           "FROM tblTempShipNotice;"

    Set rs = CurrentDb.OpenRecordset(sSQL, dbOpenSnapshot)
    With rs
        If .RecordCount <> 0 Then
            Set objOutlook = CreateObject("Outlook.Application")
            Do While Not .EOF
                'Initialize the variable for each loop
                strName = ""
                sMail = ""
                sSubj = ""
                'Populate the variables with our record data
                strName = Nz(rs![Lname], "")
                sMail = sMail & ";" & Nz(rs("Email"), "")
                strCC = Nz(rs![CCEmails], "")
                If strCC <> "" Then strCC = strCC & ";"
                Call Outlook_SendEmail(objOutlook, sMail, strCC, sCC, sSubj)

                .MoveNext
            Loop
            Set objOutlook = Nothing
        End If
    End With
End Sub

Function Outlook_SendEmail(ByVal objOutlook As Object, _
                           ByVal sMail As String, _
                           ByVal strCC As String, _
                           ByVal sCC As String, _
                           ByVal sSubj As String)
    Dim objEmailMessage       As Object

    Set objEmailMessage = objOutlook.CreateItem(0)
    With objEmailMessage
        .To = sMail
        If strCC & "" <> "" Then
            .cc = sCC
        End If
        .cc = strCC
        .Subject = sSubj
        .SentOnBehalfOfName = "OSOMHAHQSerialClaims@hhs.gov"
        'Set body format to HTML
        .BodyFormat = olFormatHTML
        .Subject = "Serial Claims Initiative - All Claims Approved for Payment by CMS in Appeal(s) Assigned to You - - [Serial Claims Spreadsheet #[Numbering -based on the number of CMS Identified Spreadsheet]"
        sBody = "As part of the Serial Claims Initiative (SCI), CMS has indicated its intent to pay all of the related claims in an appeal(s) currently assigned to you. The Medicare Appeals Contractor has identified existing claims for coverage of the same durable medical equipment, for the same beneficiary, in identical or near-identical circumstances. A notification from the Medicare Appeals Contractor has been included for your information. " & _
                "<br><br>Please find attached a template for a fully favorable stipulated decision which you may wish to use for this appeal.  Though all claims must be, and continue to be, adjudicated separately by OMHA, you may wish to utilize this template to promote consistency among decisions across the agency. <br><br>Thank you for your consideration and if you have questions, please do not hesitate to contact me. <br><br>" & sBody & "</table><br><b><i><br>Thank you,<br><br>LLLL R. Mel<br>Branch Chief, Special Initiatives Branch " & _
                "<br>Field Operations Division<br>Department Services<br>XXX Davis Highway, Suite 2001<br>Mrto, VA  22222<br>Phone: (999) 777-7799<br><br></i></div></body></html>"
        .HTMLBody = sBody
        .Display
    End With
    Set objEmailMessage = Nothing
End Function

Public Function GetCCadresses(ByVal mail As String) As String
    Dim sql As String
    sql = vbNullString
    sql = sql & "SELECT tblFO.Emails  AS cc" & vbCrLf
    sql = sql & "FROM tblFO INNER JOIN tblTempShipNotice" & vbCrLf
    sql = sql & "ON tblFO.FO = tblTempShipNotice.FO" & vbCrLf
    sql = sql & "WHERE tblTempShipNotice.Email = """ & mail & """;"

    Dim db As DAO.Database
    Set db = CurrentDb

    Dim rs As DAO.Recordset
    Set rs = db.OpenRecordset(sql, dbOpenSnapshot)

    Dim cc As String
    While Not rs.EOF
        cc = cc & rs("cc") & ";"    '// adjust to fit your needs
        rs.MoveNext
    Wend
    rs.Close
    GetCCadresses = cc
End Function
ASKER CERTIFIED SOLUTION
Join our community to see this answer!
Unlock 1 Answer and 13 Comments.
Start Free Trial
Learn from the best

Network and collaborate with thousands of CTOs, CISOs, and IT Pros rooting for you and your success.

Andrew Hancock - VMware vExpert
See if this solution works for you by signing up for a 7 day free trial.
Unlock 1 Answer and 13 Comments.
Try for 7 days

”The time we save is the biggest benefit of E-E to our team. What could take multiple guys 2 hours or more each to find is accessed in around 15 minutes on Experts Exchange.

-Mike Kapnisakis, Warner Bros