Option Compare Database
Option Explicit

Private strStartHTML As String
Public strRptName As String

' Oliver Stohr, Access MVP has graciously given us permission
' to make his code available. I also included his comments
' from his blog.
' By Oliver Stohr, Access MVP
' http://www.access-freak.com/blog.html#BlogEntryAugust200802

' Modified by Patrick Wood
' http://gainingaccess.net
' I added a couple of other Procedures
' that can be helpful with Emailing Reports

' I added the basFileExists and the IsAppThere
' Functions so the code will work for everyone

' The Report Name must be a minimum of 7 characters to identify the files
' varPath is a Folder Path where the outputed files are saved.  It must
' already exist and the trailing slash must be included.

' To maintain spaces between Records on my Report I added a bound textbox
' and made the forecolor white, effectively making it invisible

' This could also be done with the Report's Footer so you will not see
' the page numbers every few lines

' you can test it in the Immediate Window
' Example:
' Call RptEmailHTML("C:\", "rptApptCalPortrait")
'---------------------------------------------------------------------------------------
' Procedure : RptEmailHtml
' DateTime  : 9/15/2008 13:57
' Author    : Patrick Wood & Unknown
' Purpose   : Send a Report as HTML in the body of an Email
' Arguments : strRptName the name of the Report you want to send
'           : varPath is a Folder Path that must exist--must include slash at end
'---------------------------------------------------------------------------------------
'
Public Function RptEmailHtml(varPath As Variant, strRptName As String)
On Error GoTo Err_RptEmailHtml

    Dim HTMLFile As String 'HTML name to hold formatting of Report
    Dim i As Integer
    Dim strBody As String
    Dim strTemp As String
    Dim strflLeft As String
    Dim strFirstFile As String
    Dim arrFiles
    
    ' We need a way to identify the Exported Report HTML files
    If Len(strRptName & vbNullString) < 7 Then
        Call MsgBox("The Report Name needs to be at least 7 characters long              " _
                    & vbCrLf & "              so the files being used can be verified." _
                    , vbExclamation, "                 Please Make Your Report Name Longer")
        GoTo Exit_RptEmailHtml
    End If
    
    ' Set a name for the first HTML file
    HTMLFile = varPath & strRptName & ".HTML"
    ' Use the first file's path and name to get
    ' the HEAD HTML in the ReadHTMLFile Sub
    strFirstFile = HTMLFile
    
    ' Create the File(s)
    ' Creates one file for each Report Page
    DoCmd.OutputTo acOutputReport, strRptName, acFormatHTML, _
    HTMLFile, False
    
    ' Get a value to identify the Files
    strflLeft = Left(strRptName, 7)
    
        arrFiles = Array(dir(varPath, vbNormal))    ' Retrieve the first entry.
            Do While arrFiles(i) <> 0 ' Start the loop.
                If strflLeft = Left(arrFiles(i), 7) Then
                    strTemp = ReadHTMLFile(varPath & arrFiles(i), strFirstFile)
                    strBody = strBody & "<P></P><P></P>" & strTemp
                    Debug.Print varPath & arrFiles(i)
                End If
'                Debug.Print varPath & arrFiles(i)
                ' An Expected Error occurs when there are no more files
                On Error GoTo StepOut ' Get out of the Loop
            arrFiles(i) = dir    ' Get next entry.
        Loop
StepOut:
    ' Clear the Error
    Err.Number = 0
    
    ' Add the start of the HTML to the BODY
    strBody = strStartHTML & strBody
    
    ' We have gathered all the HTML from all the files so make the email.
    SendHTMLMail (strBody)

Exit_RptEmailHtml:
    Exit Function

Err_RptEmailHtml:
    Call MsgBox(Err.Description & vbCrLf & "Error Number: " & Err.Number & vbCrLf & _
    " In procedure RptEmailHtml of Module basEmail")
    Resume Exit_RptEmailHtml
            
End Function

Sub SendHTMLMail(strBodyText)
    
    Dim strTo As String 'recipiants
    Dim olApp As Object  ' New Outlook.Application
    Dim olMail As Object ' Outlook.MailItem
    Dim strSubject As String 'Email subject
    Dim strMsg As String 'Email greeting

    If isAppThere("Outlook.Application") = False Then
        ' Outlook is not open, create a new instance
        Set olApp = CreateObject("Outlook.Application")
    Else
        ' Outlook is already open--use this method
        Set olApp = GetObject(, "Outlook.Application")
    End If

    ' Create the New Email Item
    Set olMail = olApp.CreateItem(0) ' olMailitem = 0
    
    strMsg = "Here is the Report I Promised."
    strSubject = "My Report HTML in Email Body Test"

    With olMail
       .To = "joe@irjoe.com"
       .Subject = "My Report HTML in Email Body Test"
       '.BodyFormat = olFormatRichText
       .HTMLBody = strMsg & strBodyText & "</BODY>" & vbNewLine & "</HTML>"
    End With
    olMail.Display
    'olMail.Send

End Sub

Function ReadHTMLFile(strFileName, strFirstFile As String)
   Const ForReading = 1, ForWriting = 2
   Dim fso, f, r, i
   Dim intNoLines, intStartLine
   Dim strTemp
   Dim intBody As Integer
   ' Open the file and find the Head and the Body
   ' of the file.  There may be several files but
   ' we will only use the first file's Head
   Set fso = CreateObject("Scripting.FileSystemObject")
   Set f = fso.OpenTextFile(strFileName, ForReading)
   Do While f.AtEndOfStream <> True
        r = f.ReadLine
        ' Make sure we have the starting file
        If strFileName = strFirstFile Then
            ' Build the starting string to add to our HTML later
            ' If "<BODY>" is in our string stop building
            If InStr(1, strStartHTML, "<BODY>") = 0 Then
                strStartHTML = strStartHTML & r
'                Debug.Print "strStartHTML = " & strStartHTML
            End If
        End If
'        If Left(r, 7) = "<TABLE " Then intStartLine = f.Line  ' OLD CODE
        ' Get the line number where Body of the HTML begins
         intBody = InStr(1, r, "<BODY>")
         If intBody > 0 Then intStartLine = f.Line + 1
   Loop
   ' Count the number of lines in the file
   intNoLines = f.Line
   
   ' Get the BODY HTML
   Set f = fso.OpenTextFile(strFileName, ForReading)
   i = 1
   Do While i <= intNoLines - 2
      If i >= intStartLine - 1 Then
          strTemp = strTemp & f.ReadLine
      Else
          f.ReadLine
      End If
      i = i + 1
   Loop
   f.Close
   ReadHTMLFile = strTemp
'   Debug.Print strTemp

End Function

'------------------------------------------------------------------
' By Oliver Stohr, Access MVP
' http://www.access-freak.com/blog.html#BlogEntryAugust200802
' Now this is already pretty nice and we don't need an attachment
' anymore. However, it does seem like a long workaround to get the
' final result with outputting a separate file and opening/closing
' it as well as deleting it later on. We can do better then that.
' Especially if we do not want to rely on an actual report to do
' the work. The next sample opens a recordset based on a query or
' table and loops through it to dynamically create the HTML output
' we need to pass along to our email message. This will also allow
' us more flexibility in formatting the data correctly, which is
' somewhat lost in the earlier approach. This sample uses an ADO
' recordset so make sure you have a reference to your latest
' Microsoft ActiveX Object Library set.
' Again you can just call this function from anywhere passing along
' the name of your table/query e.g.: ?HtmlNoReportEmail("qryCustomers")
'------------------------------------------------------------------
' Modified by Pat Wood
' Note: strMsg must be hardcoded and your Table or Query must include all
' fields in strMsg

Public Function HtmlNoReportEmail(strTblQryName As String)

    Dim olApp As Object  ' Outlook.Application
    Dim olMail As Object ' Outlook.MailItem
    Dim strMsg As String
    Dim sqlString As String
    Dim i As Integer
    Dim rowColor As String

    Dim rs As ADODB.Recordset
    Set rs = New ADODB.Recordset

    sqlString = "SELECT * FROM " & strTblQryName & ""
    rs.Open sqlString, CurrentProject.Connection, adOpenKeyset, adLockOptimistic

    strMsg = "<table border='1' cellpadding='3' cellspacing='3' style='border-collapse: collapse' bordercolor='#111111' width='800'>" & _
             "<tr>" & _
             "<td bgcolor='#7EA7CC'>&nbsp;<b>Appointment</b></td>" & _
             "<td bgcolor='#7EA7CC'>&nbsp;<b>Start Date</b></td>" & _
             "<td bgcolor='#7EA7CC'>&nbsp;<b>Start Time</b></td>" & _
             "<td bgcolor='#7EA7CC'>&nbsp;<b>End Date</b></td>" & _
             "<td bgcolor='#7EA7CC'>&nbsp;<b>End Time</b></td>" & _
             "<td bgcolor='#7EA7CC'>&nbsp;<b>Location</b></td>" & _
             "<td bgcolor='#7EA7CC'>&nbsp;<b>Notes</b></td>" & _
             "</tr>"

    i = 0

    Do While Not rs.EOF

        If (i Mod 2 = 0) Then
            rowColor = "<td bgcolor='#FFFFFF'>&nbsp;"
        Else
            rowColor = "<td bgcolor='#E1DFDF'>&nbsp;"
        End If

        strMsg = strMsg & "<tr>" & _
                 rowColor & rs.Fields("Appt") & "</td>" & _
                 rowColor & rs.Fields("ApptDate") & "</td>" & _
                 rowColor & rs.Fields("ApptTime") & "</td>" & _
                 rowColor & rs.Fields("EndDate") & "</td>" & _
                 rowColor & rs.Fields("EndTime") & "</td>" & _
                 rowColor & rs.Fields("Location") & "</td>" & _
                 rowColor & rs.Fields("ApptNotes") & "</td>" & _
                 "</tr>"

        rs.MoveNext
        i = i + 1
    Loop

    strMsg = strMsg & "</table>"

    If isAppThere("Outlook.Application") = False Then
        ' Outlook is not open, create a new instance
        Set olApp = CreateObject("Outlook.Application")
    Else
        ' Outlook is already open--use this method
        Set olApp = GetObject(, "Outlook.Application")
    End If

    ' Create the New Email Item
    Set olMail = olApp.CreateItem(0) ' olMailitem = 0
    
    With olMail
        .BodyFormat = 2  ' olFormatHTML = 2
        .HTMLBody = strMsg
        .Recipients.Add "joe@irjoe.com"
        .Subject = "Customer Data TEST"
        '.Send if you want to send it directly without displaying on screen
        .Display
    End With

    Set olApp = Nothing
    Set olMail = Nothing

End Function

' ---------------------------------------------------------------
' By Oliver Stohr, Access MVP
' http://www.access-freak.com/blog.html#BlogEntryAugust200802
' If you ever want to add an image to the body without relying
' on an outside source for the image to display then you can
' actually attach them to the email message and refer to the
' attachmends within your HTML body e.g.:

' ---------------------------------------------------------------
Function ImageInEmailBody()

    Dim olApp As Outlook.Application
    Dim olMail As Outlook.MailItem
    Dim strMsg As String

    strMsg = strMsg & "<HTML><Body>" & "<img src='cid:freak01.gif'>" & "<br>" & "<img src='cid:freak02.gif' >" & "</BODY></HTML>"

    Set olApp = Outlook.Application
    Set olMail = olApp.CreateItem(olMailItem)

    With olMail
        .Attachments.Add ("c:\freak01.gif")
        .Attachments.Add ("c:\freak02.gif")
        .BodyFormat = olFormatHTML
        .HTMLBody = strMsg
        .Recipients.Add "user@email.com"
        .Subject = "YourSubject"
        '.Send if you want to send it directly without displaying on screen
        .Display
    End With

    Set olApp = Nothing
    Set olMail = Nothing

End Function

'-------------basFileExists Module Code-----------------

'---------------------------------------------------------------------------------------
' Procedure : DoesFileExist
' Purpose   : Determine if a specific File exists of any file type
' Arguments : strFileNamePath is the full path and file name:
' Usage     : DoesFileExist("C:\MyFiles\MyFileName.txt")
'---------------------------------------------------------------------------------------
'
Function DoesFileExist(strFileNamePath As String) As Boolean
Dim strMsg As String

    If Len(dir(strFileNamePath)) > 0 Then
        strMsg = strFileNamePath & " file exists."
        DoesFileExist = True
    Else
        strMsg = strFileNamePath & " file does not exist."
        DoesFileExist = False
    End If
    ' Debug.Print strMsg
    ' Debug.Print "DoesFileExist = " & DoesFileExist

End Function


Function FileExists(ByVal strFile As String, Optional bFindFolders As Boolean) As Boolean
    'Purpose:   Return True if the file exists, even if it is hidden.
    'Arguments: strFile: File name to look for. Current directory searched if no path included.
    '           bFindFolders. If strFile is a folder, FileExists() returns False unless this argument is True.
    'Note:      Does not look inside subdirectories for the file.
    'Author:    Allen Browne. http://allenbrowne.com June, 2006.
    Dim lngAttributes As Long

    'Include read-only files, hidden files, system files.
    lngAttributes = (vbReadOnly Or vbHidden Or vbSystem)

    If bFindFolders Then
        lngAttributes = (lngAttributes Or vbDirectory) 'Include folders as well.
    Else
        'Strip any trailing slash, so Dir does not look inside the folder.
        Do While Right$(strFile, 1) = "\"
            strFile = Left$(strFile, Len(strFile) - 1)
        Loop
    End If

    'If Dir() returns something, the file exists.
    On Error Resume Next
    FileExists = (Len(dir(strFile, lngAttributes)) > 0)
End Function

Function FolderExists(strPath As String) As Boolean
    On Error Resume Next
    FolderExists = ((GetAttr(strPath) And vbDirectory) = vbDirectory)
End Function

Function TrailingSlash(varIn As Variant) As String
    If Len(varIn) > 0 Then
        If Right(varIn, 1) = "\" Then
            TrailingSlash = varIn
        Else
            TrailingSlash = varIn & "\"
        End If
    End If
End Function

'---------------------------------------------------------------------------------------
' Procedure : isAppThere
' Author    : Rick Dobson, Ph.D - Programming Microsoft Access 2000
' Purpose   : To check if an Application is Open
' Arguments : appName The name of the Application
' Example   : isAppThere("Outlook.Application")
'---------------------------------------------------------------------------------------
'
Function isAppThere(appName) As Boolean
On Error Resume Next
    Dim objApp As Object
    
    isAppThere = True
    
    Set objApp = GetObject(, appName)
        If Err.Number <> 0 Then isAppThere = False

End Function