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