PDA

View Full Version : Embed Record Set Fields into Email Body as HTML


brorick
10-22-2007, 01:43 PM
Although I have the code to export my report as an HTML file and embed that into my email body, I have run into many limitations and headaches with this type of approach. I would prefer to embed the data directly into the body of my email as HTML. I have used this code and it has worked for my images: objOutlookMsg.HTMLBody = "<HTML><BODY><img src=" & "'File:C:\images\StarBlue.jpg'" & "/></BODY>"

I prefer to continue using the HTML format so that I can apply color to my font and include images. I am having difficulty looping through my query and displaying the results into my email body in the following format. The query will display all comments related to a specific LogID number (varLogID). I am at my wits end. : pray2: Any help is appreciated. Thank you.


varDate varTime varEmp
varComments

varDate varTime varEmp
varComments

varDate varTime varEmp
varComments





Sub SendHTMLMessage(Optional AttachmentPath)
Dim db As DAO.Recordset
Dim rst As DAO.Recordset
Dim objOutlookMsg As Outlook.MailItem
Dim fso As FileSystemObject
Dim MyBody As TextStream
Dim MyBodyText As String
Dim intCount As Integer
Dim ingCounter As Integer
Dim varEmp As String
Dim varDate As String
Dim varTime As String
Dim varComments As String
Dim varLogID As Integer

Set fso = New FileSystemObject
Dim strLocalPath As String
DoCmd.OutputTo acOutputReport, "Rpt_Bulletin", acFormatHTML, "C:\Bulletin.htm"

Set objOutlook = New Outlook.Application

Set db = CurrentDb()
Set rst = db.OpenRecordset("Qry_Bulletins")

varLogID = rst![LogID]
varEmp = rst![EmployeeName]
varDate = rst![Date]
varTime = rst![Time]
varComments = rst![Comments]

Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
With objOutlookMsg
.BodyFormat = olFormatHTML
strLocalPath = "C:\Bulletin.htm"
Set MyBody = fso.OpenTextFile(strLocalPath, ForReading, True, TristateMixed) ',
TristateUseDefault)


MyBodyText = MyBody.ReadAll
.HTMLBody = MyBodyText
MyBody.Close
rst.MoveNext

.Subject = strSQL
MyBodyText = varComments


rst.Close
Set rst = Nothing
datb.Close
Set datb = Nothing

objOutlookMsg.Display
End With
Set objOutlookMsg = Nothing
Set objOutlook = Nothing

End Sub
DarkSprout
10-25-2007, 04:17 AM
Inbed your data in a XML island within the HTML file.
DarkSprout
10-25-2007, 04:39 AM
EG: Module...

'Attribute VB_Name = "mdl_xml_Export"
'// by Darryl S. Drury ~ October 2007
' Exports MS Access Tables and Querys To the XML format using SubTags or Attributes for the field content
' Encludes a HTML Wrapper, so that XML data can be viewed on an IE5+ Browser
'bResult = export_as_xml(ObjectsName, [FilePath], [CompressFile?], [NewFileName], [SubTagName], _
[DataRootName], [StyleAsAttributeOrSubTag?], [StyleAsXMLorHTML?], [ColourStyle]) <-- Returns Boolean Value
'Defults:
'[FilePath] ~ the Desktop
'[CompressFile?] ~ LeaveOpenXML
'[NewFileName] ~ txtObjectName
'[SubTagName] ~ txtObjectName
'[DataRootName] ~ "dataroot"
'[StyleAsAttributeOrSubTag?] ~ StyleAsSubTag
'[StyleAsXMLorHTML?] ~ StyleAsXML
'[ColourStyle] ~ StyleGray (Only used with styleAsHTML)
'eg.
'?export_as_xml("tbl_CORE_Managers", , CompactXML, "CompanyManagers", , , StyleAsSubTag, styleAsHTML, StyleGray)
Option Compare Database
Option Explicit
'for export_as_xml
Public Enum SubTagStyle
StyleAsSubTag = &O1 ' <T>
StyleAsAttribute = &O2 ' =
End Enum
'for export_as_xml
Public Enum WrapperStyle
StyleAsXML = False
styleAsHTML = True
End Enum
'for export_as_xml
Public Enum CompactDataSet
CompactXML = True
LeaveOpenXML = False
End Enum
'for export_as_xml
Public Enum TableColour
StyleGray = &O1
StyleBlue = &O2
StyleOlive = &O3
StyleSalmon = &O4
StyleCream = &O5
StyleTurquoise = &O6
End Enum
Private Const DBLINE = vbNewLine & vbNewLine
'- Replace the invalid chrs from Field Values -
Private Function SpecialCharacters(text As String) As String
text = Replace(text, Chr(38), "&amp;") 'ampersand
text = Replace(text, Chr(60), "&lt;") 'less than
text = Replace(text, Chr(62), "&gt;") 'greater than
text = Replace(text, Chr(39), "&apos;") 'apostrophe
text = Replace(text, Chr(34), "&quot;") 'quotation mark
SpecialCharacters = Trim(text)
End Function
' - Remove invalid chrs from Field Names -
Private Function CleanCharacters(text As String) As String
text = Replace(text, Chr(60), "") 'less than
text = Replace(text, Chr(62), "") 'greater than
text = Replace(text, Chr(32), Chr(95)) 'Space
text = Replace(text, Chr(47), "") 'fwd slash
text = Replace(text, Chr(92), "") 'bck slash
CleanCharacters = Trim(text)
End Function
Private Function LoadTemplate(FileName As String) As String
'- Load and read file contents -
On Error GoTo ErrorHandle
Dim iFile As Integer
iFile = FreeFile
LoadTemplate = ""

If FolderExists(FileName) = False Then ' <--- Is file present?
MsgBox ("Document Not Found:-" & DBLINE & FileName), 48, ("Missing File")
Else
Open FileName For Binary Access Read As iFile
LoadTemplate = Input$(LOF(iFile), iFile)
Close #iFile
End If
Exit Function

ErrorHandle:
MsgBox Err.Description, vbInformation, "Error#" & Err.Number
End Function
Private Function CreateNewFile(NewFileName As String, FileContent As String) As Boolean
On Error GoTo ErrorHandle
If Nz(FileContent, "") = "" Then MsgBox "No Data To Create The File With", 48, "Error": Exit Function
Dim FileNum As Integer
FileNum = FreeFile ' next file number
Open NewFileName For Output As #FileNum ' creates the file
Print #FileNum, FileContent ' write information at the end of the text file
Close #FileNum ' close the file
CreateNewFile = (Err.Number = 0)
Exit Function
ErrorHandle:
MsgBox Err.Description, vbInformation, "Error#" & Err.Number
End Function
Private Function FolderExists(DirectoryAndFileName) As Boolean
FolderExists = (Len(Dir(DirectoryAndFileName, vbDirectory)) <> 0)
End Function
Private Function TrailingSlash(varIn As Variant) As String
TrailingSlash = IIf(Len(varIn) > 0&, IIf(Right(varIn, 1&) = "\", varIn, varIn & "\"), varIn)
End Function
'- Gets the Desktop's path -
Private Function DeskTopPath() As String
DeskTopPath = TrailingSlash(CreateObject("WScript.Shell").SpecialFolders("Desktop"))
End Function
Public Function export_as_xml(txtObjectName As String, Optional FilePath As String, _
Optional CompressFile As CompactDataSet, _
Optional FileName As String, _
Optional SubTag As String, _
Optional RootName As String, _
Optional TagStyle As SubTagStyle = StyleAsSubTag, _
Optional Wrapper As WrapperStyle, _
Optional TheTableColor As TableColour) As Boolean
On Error GoTo ExitMe
Dim iFile As Integer, NewLine As String, ErrorNumber As Long ' for open file
Dim rs As DAO.Recordset, fld As Variant, FieldName As String ' for open record
Dim C34 As String, tS4 As String, tS8 As String, ot As String, ct As String, os As String, cs As String, strCreationCode As String ' Consts
Dim HTML_Title As String, BackColor As String ' HTML Variables
' - Create HTML Doc Title -
HTML_Title = IIf(Nz(FileName, "") = "", txtObjectName, FileName)
HTML_Title = Replace(HTML_Title, ".HTML", ""): HTML_Title = Replace(HTML_Title, ".html", "")
HTML_Title = Replace(HTML_Title, ".XML", ""): HTML_Title = Replace(HTML_Title, ".xml", "")
' - Create FileName -
FilePath = IIf(Nz(FilePath, "") <> "", FilePath, DeskTopPath)
FilePath = IIf(LCase(Right(FilePath, 4)) <> ".xml", TrailingSlash(FilePath) & _
IIf(Nz(FileName, "") <> "", Replace(Nz(FileName, ""), ".xml", ""), txtObjectName) & IIf(Wrapper = styleAsHTML, ".html", ".xml"), FilePath)
' - Create SubTag -
SubTag = IIf(Nz(SubTag, "") <> "", SubTag, txtObjectName)
' - Create Root Name -
RootName = Replace(Nz(RootName, ""), Chr(32), "")
RootName = IIf(RootName <> "", RootName, "dataroot")
ot = "<" ' open tag
ct = ">" ' close tag
os = "</" ' open slash
cs = "/>" ' close slash
tS4 = String(4, 32) ' 4 spaces
tS8 = String(8, 32) ' 8 spaces
C34 = Chr(34) ' " quotation mark
strCreationCode = "=DarkSprout="
Set rs = CurrentDb.OpenRecordset(txtObjectName, dbOpenDynaset)
If rs.EOF And rs.BOF Then GoSub ExitMe
BackColor = Choose(TheTableColor + 1, "#EEEEEE", "#EEEEEE", "#ABCDEF", "#BBB456", "#FEDCBA", "#EEECCC", "#3B9C9C")
iFile = FreeFile
Open FilePath For Output As #iFile ' create/overwrite file as text
Select Case Wrapper
Case StyleAsXML ' XML doc header
Print #iFile, "<?xml version=" & C34 & "1.0" & C34 & " encoding=" & C34 & "windows-1252" & C34 & " standalone=" & C34 & "yes" & C34 & "?>" ' Codeing
Print #iFile, "<!-- xml doc uses " & IIf(TagStyle = StyleAsSubTag, "Sub Tags", "Attributes") & " to hold field values -->"
Print #iFile, "<" & RootName ' data start
' - following lines: Create doc Attributes -
Print #iFile, tS4 & "xmlns:xsi = " & C34 & "http://www.w3.org/2001/XMLSchema-instance" & C34
Print #iFile, tS4 & "generated = " & C34 & Format(Now(), "yyyy-mm-ddThh:nn:ss") & C34
Print #iFile, tS4 & "createdby = " & C34 & Replace(Application.CurrentProject.Name, ".mdb", "") & C34 & ">"

Case styleAsHTML ' HTML wrapper head
Print #iFile, "<HTML>"
Print #iFile, "<HEAD>"
Print #iFile, "<TITLE>" & HTML_Title & ": DataTable" & "</TITLE>"
Print #iFile, "</HEAD>"
' - following line: Start Body Text, Build Body Title -
Print #iFile, "<BODY><h1 style=" & C34 & "background-color:" & BackColor & "; color:#000000; font-family:Verdana, Arial; font-size:20pt; text-align:center; letter-spacing: 10pt" & C34 & ">" & HTML_Title & "</h1>"
Print #iFile, ""
Print #iFile, "<XML ID=" & C34 & "xmlDataIsland" & C34 & " generated = " & C34 & Format(Now(), "yyyy-mm-ddThh:nn:ss") & C34 & " createdby = " & C34 & Replace(Application.CurrentProject.Name, ".mdb", "") & C34 & ">"
Print #iFile, "<XML_TABLE>"
End Select

rs.MoveFirst
Select Case TagStyle
Case StyleAsSubTag ' <T>SubTag
Do While Not rs.EOF
Print #iFile, tS4 & ot & SubTag & ct ' open <subtag>
For Each fld In rs.Fields
FieldName = CleanCharacters(fld.Name)
Print #iFile, tS8 & ot & FieldName & ct & SpecialCharacters(Nz(fld.Value, "")) & os & FieldName & ct ' place <fieldname>fieldvalue</fieldname>
Next fld
Print #iFile, tS4 & os & SubTag & ct ' close </subtag>
rs.MoveNext
Loop

Case StyleAsAttribute ' =Attribute
Do While Not rs.EOF
NewLine = ot & SubTag ' build tag start <<>>
For Each fld In rs.Fields
NewLine = NewLine & " " & CleanCharacters(fld.Name) & " = " & C34 & SpecialCharacters(Nz(fld.Value, "")) & C34 ' add each new attribute
Next fld
Print #iFile, NewLine & cs ' place attribute(s) and close />
rs.MoveNext
Loop
End Select
If Wrapper = styleAsHTML Then Print #iFile, "</XML_TABLE>"
Print #iFile, "</" & IIf(Wrapper = styleAsHTML, "XML", RootName) & ">" ' XML data end
' - following lines: Create HTML wrapper footer
If Wrapper = styleAsHTML Then
rs.MoveFirst
Print #iFile, ""
Print #iFile, "<TABLE DATASRC=" & C34 & "#xmlDataIsland" & C34 & " BORDER=" & C34 & "1" & C34 & " CELLPADDING=" & C34 & "3" & C34 & " CELLSPACING=" & C34 & "1" & C34 & " BGCOLOR=" & C34 & BackColor & C34 & ">"
Print #iFile, tS4 & "<THEAD>"
For Each fld In rs.Fields
Print #iFile, tS8 & "<TD>" & CleanCharacters(fld.Name) & "</TD>"
Next fld
Print #iFile, tS4 & "</THEAD>"
Print #iFile, tS4 & "<TR>"
rs.MoveFirst
For Each fld In rs.Fields
Print #iFile, tS8 & "<TD bgcolor=" & C34 & "#FFFFFF" & C34 & "><DIV DATAFLD=" & C34 & CleanCharacters(fld.Name) & C34 & "></DIV></TD>"
Next fld
Print #iFile, tS4 & "</TR>"
Print #iFile, "</TABLE>"
Print #iFile, "</BODY>"
Print #iFile, tS4 & "<FONT SIZE=" & C34 & "2" & C34 & " FACE=" & C34 & "VERDANA" & C34 & " COLOR=" & C34 & "GRAY" & C34 & "><b>Creation Code: " & strCreationCode & "</b></FONT>"
Print #iFile, "</HTML>"
End If
ExitMe:
ErrorNumber = Err.Number
Close #iFile
rs.Close
Set rs = Nothing
If (CompressFile = CompactXML) And (ErrorNumber = 0) Then
If XMLCompression(FilePath) = False Then
MsgBox "XML Compression Failed:" & DBLINE & "Please Check File Contents in an XML Parser - Data Maybe Corrupt", 16, "XML Compression"
End If
End If
export_as_xml = (ErrorNumber = 0)
DoEvents
End Function
Public Function XMLCompression(Optional PathAndFileName As String) As Boolean
' Removes all spaces and linefeeds from a text file - xml doc SHOULD remain well formed and valid.
If Not FolderExists(PathAndFileName) Then PathAndFileName = vbNullString
If Nz(PathAndFileName, "") = "" Then GoSub ExitMe
Dim FileText As String, strREPLACE As String, L7Char As String
Dim i As Long, boolSTART As Boolean
FileText = LoadTemplate(PathAndFileName)
boolSTART = False
For i = 1 To Len(FileText)
strREPLACE = Mid(FileText, i, 1)
L7Char = Right(L7Char, 6) & strREPLACE
If L7Char = "</BODY>" Then Exit For
If strREPLACE = ">" Then boolSTART = True: GoSub JumpNext
If strREPLACE = "<" Then boolSTART = False: GoSub JumpNext
If (boolSTART = True) And (strREPLACE = Chr(32) Or strREPLACE = Chr(10) Or strREPLACE = Chr(13)) Then
Mid(FileText, i, 1) = Chr(250)
End If
JumpNext:
Next i
FileText = Replace(FileText, Chr(250), "")
Call CreateNewFile(PathAndFileName, FileText)
ExitMe:
XMLCompression = (Err.Number = 0)
End Function
brorick
10-25-2007, 05:18 AM
DarkSprout, thank you for your assistance. I was beginning to give up hope that anyone would have a response. I have been searching for some guidance in many places for a couple of weeks. This looks very promising. I am looking forward to giving it a try. I will let you know the results.
brorick
10-25-2007, 05:38 AM
DarkSprout, I have placed the code into the module and I have to admit I am not quite sure where to proceed from there. I am not sure if this is an issue, but I noticed that the only line of code that appeared in red was the first line that references,

Attribute VB_Name = "mdl_xml_Export"

I commented that code out assuming that everything prior to the reference of Option Compare Database appeared to be commented out. After looking over the remainder of the code I thought maybe I would begin at the Private Function LoadTemplate(FileName As string) As String. I thought it is here where I would reference the query or table. I am not sure. Where should I begin? Thanks again in advance.
DarkSprout
10-25-2007, 05:51 AM
Attribute VB_Name = "mdl_xml_Export" Is the bas file inport name - just remove it

Use:
Dim bResult As boolean

...

bResult = export_as_xml("Table/QueryName", , LeaveOpenXML, _ "NewFileName", , , StyleAsSubTag, styleAsHTML, StyleGray)

When you type bResult = export_as_xml(
The VBA Editor will prompt you for all of the required fields
The First Field is the only one that is a must - the rest are Optional.
you will need Wrapper = styleAsHTML

Please read the Notes at the head of the Code Listing.

=DarkSprout=
DarkSprout
10-26-2007, 02:05 AM
Test MDB Attached ~ Go forth and be Wise.

=DarkSprout=
brorick
10-26-2007, 12:27 PM
DarkSprout, you did it. This database example is perfect. :bow: Thank you for your assistance and guidance. Have a great weekend.