Formatting Outlook text from Access VBA
Wayne
notifying recipients of new problem reports:
1) Generate an Access report containing the columnar data and export it
to a .rtf file.
2) Using Word, convert the columnar data in the .rtf file to table.
3) Copy the table from Word and paste it in a new Outlook email
(default format is RTF).
I created a command button in the Access application which opens a new
Outlook mail message and successfully populates the To, Subject, and
Body. However, since the default font is Arial, the columns (separated
by tabs) do not line up.
I also tried using SendObject, but he doesn't want the recipients to
have to open an attachment.
Is there a way to have the VBA modify the font (to Courier) and tab
locations in the current mail item like you can with a Word object?
Does anyone have a better idea?
Appreciate any help,
Wayne
Ron2005
It may give you some ideas and you can go from there.
Lyle Fairfield
1. I think it's nuts to send out a report by e-mail. Send out alink and
let the person click on the link and see the report at his or her
leisure. He or she doesn't have to send anything byt the link to other
people so that they can see the report. And there may be time saved in
not having to upload the report more than nce, although that may not be
true.
How to do? Some code. If you want courier modify the code to have any
style you want.
This is run in Northwind.mdb.
Public Sub UploadReportAsHTML( _
ByVal ReportName As String, _
ByVal Server As String, _
Optional ByVal UserName As String, _
Optional ByVal PassWord As String, _
Optional ByVal NumberofPagesAllowed As Long = 10)
Dim Buffer As String
Dim Position As Long
Dim FileNumber As Integer
Dim Heading As String
Dim HTML As String
Dim HTMLFullPath As String
Dim Skelton As String
Dim TempDirectory As String
Dim Truncate As Long
TempDirectory = Environ$("temp")
If Len(TempDirectory) = 0 Then TempDirectory = CurDir$()
TempDirectory = TempDirectory & "\"
Skelton = Format(Now(), "mmmddyyyyhhnnss")
HTMLFullPath = TempDirectory & Skelton & ".html"
DoCmd.OutputTo acOutputReport, ReportName, acFormatHTML, HTMLFullPath
HTMLFullPath = Dir$(TempDirectory & Skelton & "*.html")
While Len(HTMLFullPath) <> 0 And NumberofPagesAllowed <> 0
HTMLFullPath = TempDirectory & HTMLFullPath
FileNumber = FreeFile()
Open HTMLFullPath For Binary As #FileNumber
Buffer = String(LOF(FileNumber), vbNullChar)
Get #FileNumber, , Buffer
Close #FileNumber
Position = InStr(Buffer, "<BODY>") + 6
If Len(Heading) = 0 Then
Heading = Left(Buffer, Position)
Else
Buffer = Mid$(Buffer, Position + 1)
End If
Position = InStr(Buffer, "</TABLE>")
While Position <> 0
Truncate = Position
Position = InStr(Truncate + 1, Buffer, "</TABLE>")
Wend
HTML = HTML & Left(Buffer, Truncate + 7)
HTML = HTML & vbNewLine & "<HR>"
HTMLFullPath = Dir$()
NumberofPagesAllowed = NumberofPagesAllowed - 1
Wend
If Len(HTMLFullPath) <> 0 And NumberofPagesAllowed = 0 Then _
HTML = HTML & vbNewLine & "<P style=FONT-WEIGHT:700>" _
& vbNewLine _
& "Partial Report: Additional Pages not Shown" _
& vbNewLine _
& "<P>"
On Error Resume Next
Kill HTMLFullPath
On Error GoTo 0
HTMLFullPath = Dir$(TempDirectory & Skelton & "*.html")
HTML = HTML & vbNewLine & "</BODY>" & vbNewLine & "</HTML>"
FileNumber = FreeFile
Open HTMLFullPath For Binary As #FileNumber
Put #FileNumber, , HTML
Close #FileNumber
UploadFile HTMLFullPath, Replace(ReportName, " ", "") & ".html",
Server, UserName, PassWord
SendReportAsHTMLExit:
Close
Exit Sub
SendReportAsHTMLErr:
With Err
MsgBox .Description, vbCritical, "Error " & .Number
End With
Resume SendReportAsHTMLExit
End Sub
Public Sub UploadFile( _
ByVal FromPath As String, _
ByVal ToFile As String, _
ByVal Server As String, _
Optional ByVal UserName As String, _
Optional ByVal PassWord As String)
Dim r As ADODB.Record
Dim s As ADODB.Stream
Set r = New ADODB.Record
Set s = New ADODB.Stream
r.Open Server & "/" & ToFile, , adModeWrite, adCreateOverwrite, ,
UserName, PassWord
With s
.Open r, , adOpenStreamFromRecord
.Type = adTypeBinary
.LoadFromFile FromPath
.Close
End With
r.Close
End Sub
Private Sub test()
UploadReportAsHTML "Products By Category", "http://www.ffdba.com"
End Sub
The result can be seen at http://ffdba.com/productsbycategory.html
Yeah I know ... it doesn't work ... oh well ... it works here and
that's good enough for me. BTW ... the web server needs to be a
microsofty web server.
Ron2005
This may give you an idea as to how to format the data into a table
then you would not have to worry about the font.
You will have to brush up on your html coding though.
The key to it all is the bodyformat and the htmlbody part.
=========================================
Set o = CreateObject("Outlook.Application")
'Set o = CreateObject("Word.Application")
Set m = o.CreateItem(0)
m.To = Forms![HiddenKey]![HManagerEmail]
If Not IsNull(Forms![HiddenKey]![HCopyEmail]) Then
m.CC = Forms![HiddenKey]![HCopyEmail]
End If
m.Subject = "Defect Analysis for " & Forms![HiddenKey]![HCompany] &
" - SR: " & Forms![HiddenKey]![HSr]
m.bodyformat = 2
m.htmlbody = Chr(13) & Chr(13) & _
"<body><Table><tr><td><b> Date: </b></td><td>" & Date &
"</td></tr>" & _
"<tr><td><b>Manager: </b></td><td>" &
Forms![HiddenKey]![HManager] & "</td></tr>" & _
"<tr><td><b>Name: </b></td><td>" &
Forms![HiddenKey]![HCompany] & "</td></tr>" & _
"<tr><td><b>PCS ID #:</b></td><td>" &
Forms![HiddenKey]![HSr] & "</td></tr>" & _
"<tr><td><b>Site ID: </b></td><td>" &
Forms![HiddenKey]![HSiteID] & "</td></tr>" & _
"<tr><td><b>SDD: </b></td><td>" &
Forms![HiddenKey]![HSDD] & "</td></tr>" & _
"<tr><td><b>Inv Dte: </b></td><td>" &
Forms![HiddenKey]![HInvoiceDate] & "</td></tr>" & _
"<tr><td><b>Inv #: </b></td><td>" &
Forms![HiddenKey]![HInvoice] & "</td></tr>" & _
"<tr><td><b>Defect #: </b></td><td>" &
Forms![HiddenKey]![HDefect] & "</td></tr>" & _
"<tr><td><b>IDMS #: </b></td><td>" &
Forms![HiddenKey]![HIDMS] & "</td></tr>" & _
"<tr><td><b>Reason: </b></td><td>" &
Forms![HiddenKey]![Hreasonfordefect] & "</td></tr>" & _
"<tr><td></td><td></td></tr>" & _
"<tr><td></td><td></td></tr>" & _
"</Table></body>"
' m.send ' to send it instead of displaying it.
m.Display
=================================================
Ron
Ron2005
to send and stick each of the fields between the <td> and </td> entries
( these are the cell definitions for each row.
Sort of like this
<Table> 'start table
<tr> 'Start row
<td> </td> ' start and then stop a cell within a row.
<td> </td> ' start and then stop a cell within a row.
<td> </td> ' start and then stop a cell within a row.
</tr> ' end the row definition
<tr> 'Start row
<td> </td> ' start and then stop a cell within a row.
<td> </td> ' start and then stop a cell within a row.
<td> </td> ' start and then stop a cell within a row.
</tr> ' end the row definition
</table> ' end the table definition.
Ron2005
The following link is to a HTML reference page that covers the above
and a whole lot more.
http://www.html-reference.com/
The in there you will also find perhaps another alternative to the
table thought. It is an html
reference to text format <tt>
http://www.html-helper.net/tutorial003.htm
and also
http://www.html-reference.com/TT.htm
Hope all of this has given you some ideas.
Ron
Wayne
Thanks for the help. Unfortunately, I don't believe the link would
be acceptable for a few reasons, including the fact that the
'enhancement' would increase the steps recipients must currently
perform in order to access the data. These reports generally contain
less than 10 lines so sending the text as an email is preferred.
Ron,
Thanks for your help as well. I was able to get this running at work
today using much of your example, however, 'bodyformat = 2' was not
known by the object. We're using Office 2000, so I'm not sure if
that makes a difference. Either way, it doesn't appear that I needed
it.
I created a condensed version here at home using Office XP (Access
2002) and provide the code below in case anyone is interested:
Dim strSQL, strHeader, strText As String
Dim dbs As Database, rst As DAO.Recordset
Dim olkApp As Outlook.Application
Dim objMailItem As Outlook.MailItem
strText = ""
DoCmd.SetWarnings False
DoCmd.RunSQL ("DELETE * FROM tblNewPraers_Temp")
'The make table query below gets all records from tblNewPraers
matching
'user-specified dates and puts them in tblNewPraers_Temp
DoCmd.OpenQuery ("qryNewPraers")
Set dbs = CurrentDb()
Set rst = dbs.OpenRecordset("tblNewPraers_Temp")
If (rst.BOF = True And rst.EOF = True) Then
MsgBox ("No new PRAERs between " & Me.StartDate & " and " &
Me.EndDate)
GoTo Exit_cmdGenNewPraerEmail_Click
Else
rst.MoveFirst
End If
Set olkApp = New Outlook.Application
Set objMailItem = olkApp.CreateItem(olMailItem)
objMailItem.Recipients.Add "NewPraerGroup"
objMailItem.Recipients.ResolveAll
objMailItem.Subject = "New PRAERS - " & Now()
'Email header
strHead = "<Body>" _
& "<Font Face=Arial Size=2>" _
& "The following PRAERs are today's arrivals:" _
& "<p></p>" _
& "<Table Border>" _
& "<tr>" _
& "<td><Font Size=2><b>PRAER</td>" _
& "<td><Font Size=2><b>SYSTEM</td>" _
& "<td><Font Size=2><b>TITLE</td>" _
& "</tr>"
While Not rst.EOF
'Add each entry to the body
strText = strText _
& "<tr>" _
& "<td><Font Size=2>" & rst!PRAER & "</td>" _
& "<td><Font Size=2>" & rst!System & "</td>" _
& "<td><Font Size=2>" & rst!Title & "</td>" _
& "</tr>"
rst.MoveNext
Wend
'Add end of the body
strText = strText & "</Table></Body></Font>"
objMailItem.HTMLBody = strHead & strText
objMailItem.Display
Set olkApp = Nothing
Set objMailItem = Nothing
DoCmd.SetWarnings True
Ron2005
We are using Outlook 2003 so bodyformat may not be relavent to the
earlier version.
Ron
FMS Development Team
Our new Total Access Emailer product addresses your need directly.
Rather than sending a report to RTF, it will let you directly use
filtered reports in HTML format as your email message.
Visit our web site for a FREE preview of Total Access Emailer 2003,
version 11.5. It will also let you embed data from tables and queries
in your message or as attachments.
Luke Chung
President
FMS, Inc.
http://www.fmsinc.com