Sub RTFBodyX()
Const ForReading = 1, ForWriting = 2, ForAppending = 3
Dim fs, f
Dim RTFBody, strTo
Dim MyApp As New outlook.Application
Dim MyItem As outlook.MailItem
'DoCmd.OutputTo acOutputReport, "Report1", acFormatRTF, "C:\Docs\Report1.rtf"
DoCmd.OutputTo acOutputQuery, "Query1", acFormatRTF, "C:\Docs\Query1.rtf"
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.OpenTextFile("C:\Docs\Query1.rtf", ForReading)
RTFBody = f.ReadAll
f.Close
Set MyItem = MyApp.CreateItem(olMailItem)
With MyItem
.To = "me@email.com"
.Subject = "txtSubjectLine"
.Body = RTFBody
End With
MyItem.Display
End Sub![[ponder]](/data/assets/smilies/ponder.gif "[ponder] [ponder]")
This strange method you speak of intrest me Remou. I shall try it and return with a reply. Thank you.
Sub RTFBodyX()
Const ForReading = 1, ForWriting = 2, ForAppending = 3
Dim fs, f
Dim RTFBody, strTo
Dim MyApp As Outlook.Application
Dim MyItem As Outlook.MailItem
Set MyApp = CreateObject("Outlook.Application")
Set MyItem = MyApp.CreateItem(olMailItem)
Kill "C:\Query1.rtf"
DoCmd.OutputTo acOutputQuery, "notificationAPAsigned", acFormatRTF, "C:\Query1.rtf"
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.OpenTextFile("C:\Query1.rtf", ForReading)
RTFBody = f.ReadAll
f.Close
Set MyItem = MyApp.CreateItem(olMailItem)
With MyItem
.To = "lcjohnson@kvc.org"
.Subject = "txtSubjectLine"
.HTMLBody = RTFBody
'.Body = RTFBody
End With
MyItem.Display
End Sub![[thumbsup2]](/data/assets/smilies/thumbsup2.gif "[thumbsup2] [thumbsup2]")
RTFBody = RTFBody & f.ReadAllRTFBody = RTFBody & vbNewLine & f.ReadAll Const ForReading = 1, ForWriting = 2, ForAppending = 3
Dim fs, f 'file system object and rtf file to hold formatting of query
Dim outFile As String 'rtf name to hold formatting of query
Dim RTFBody As String 'query results to be read back into outlook
Dim RTFBody2 As String 'query results to be read back into outlook
Dim RTFBody3 As String 'query results to be read back into outlook
Dim strTo As String 'recipiants
Dim MyApp As New Outlook.Application
Dim MyItem As Outlook.MailItem
Dim strSubject As String 'Email subject
Dim strMsg As String 'Email greeting
Dim qryName As String 'Name of the query to be used
Dim cnt As Integer 'Number of recs in the query
Dim i As Integer 'Iteration variable
strMsg = "Below are some major accomplishments that have occurred in the Permanency department!"
strSubject = "Daily Good News from KVC Permanency"
outFile = "c:\QueryOutput.rtf"
Set fs = CreateObject("Scripting.FileSystemObject")
'***************** PERMANENCY **************************************************************
qryName = "*** PERMANENCIES ***"
If Dir(outFile) <> "" Then
Kill outFile
End If
DoCmd.RunMacro "CreateTempPermTable"
DoCmd.OutputTo acOutputQuery, qryName, acFormatHTML, outFile
cnt = DCount("*", qryName)
If cnt > 0 Then
Set f = fs.OpenTextFile(outFile, ForReading)
Do Until i = cnt + 1
RTFBody = f.ReadLine
i = i + 1
Loop
f.Close
End If
RTFBody = RTFBody & vbNewLine
i = 0
'***************** RELATIVE AND NON-RELATIVE KIN PLACEMENTS *********************************
qryName = "*** RELATIVE AND NON-RELATIVE KIN PLACEMENTS ***"
If Dir(outFile) <> "" Then
Kill outFile
End If
DoCmd.OutputTo acOutputQuery, qryName, acFormatHTML, outFile
cnt = DCount("*", qryName)
If cnt > 0 Then
Set f = fs.OpenTextFile(outFile, ForReading)
Do Until i = cnt + 1
RTFBody = f.ReadLine
i = i + 1
Loop
f.Close
End If
RTFBody = RTFBody & vbNewLine
i = 0
'***************** APA SIGNINGS ************************************************************
qryName = "*** APA SIGNINGS ***"
If Dir(outFile) <> "" Then
Kill outFile
End If
DoCmd.OutputTo acOutputQuery, qryName, acFormatHTML, outFile
cnt = DCount("*", qryName)
If cnt > 0 Then
Set f = fs.OpenTextFile(outFile, ForReading)
Do Until i = cnt + 1
RTFBody = f.ReadLine
i = i + 1
Loop
f.Close
End If
RTFBody = RTFBody & vbNewLine
'******************* SEND MAIL *************************************************************
Set MyItem = MyApp.CreateItem(olMailItem)
With MyItem
.To = "lcjohnson@kvc.org"
.Subject = "MyTestMailForGoodNews"
.BodyFormat = olFormatRichText
.HTMLBody = strMsg & RTFBody & "</BODY>" & vbNewLine & "</HTML>"
End With
MyItem.Display
'MyItem.SendSub Chas_Atlas()
Dim outFile As String 'rtf name to hold formatting of query
Dim qryName As String 'Name of the query to be used
Dim cnt As Integer 'Number of recs in the query
Dim astrQueries
Dim i, strBody, strTemp
astrQueries = Split("Query10,Query10,Query10", ",")
For i = 0 To UBound(astrQueries)
outFile = "c:\" & astrQueries(i) & ".rtf"
qryName = astrQueries(i)
If Dir(outFile) <> "" Then
Kill outFile
End If
DoCmd.OutputTo acOutputQuery, qryName, acFormatHTML, outFile
cnt = DCount("*", qryName)
If cnt > 0 Then
strTemp = ReadFile(outFile)
End If
strBody = strBody & "<P></P><P></P>" & strTemp
Next
SendMail (strBody)
End Sub
Sub SendMail(strBodyText)
Dim strTo As String 'recipiants
Dim MyApp As New Outlook.Application
Dim MyItem As Outlook.MailItem
Dim strSubject As String 'Email subject
Dim strMsg As String 'Email greeting
Set MyItem = MyApp.CreateItem(olMailItem)
strMsg = "Below are some major accomplishments that have occurred in the Permanency department!"
strSubject = "Daily Good News from KVC Permanency"
With MyItem
.To = "lcjohnson@kvc.org"
.Subject = "MyTestMailForGoodNews"
'.BodyFormat = olFormatRichText
.HTMLBody = strMsg & strBodyText & "</BODY>" & vbNewLine & "</HTML>"
End With
MyItem.Display
'MyItem.Send
End Sub
Function ReadFile(strFileName)
Const ForReading = 1, ForWriting = 2
Dim fso, f, r, i
Dim intNoLines, intStartLine
Dim strTemp
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.OpenTextFile(strFileName, ForReading)
Do While f.AtEndOfStream <> True
r = f.Readline
If Left(r, 7) = "<TABLE " Then intStartLine = f.Line
Loop
intNoLines = f.Line
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
ReadFile = strTemp
End Function