Output to RTF file

[hennep]

I want to create an rtf document containing a bitmap. the data for the bitmap is a byte array from the GetDIBits API.

Did anybody ever write code to output rich text in vba, I cannot get it to work.

I do not want to use the export functions from access. I am trying to create access documentation that contains screen bitmap's from objects in design mode. The code to capture the bitmap is already working. Writing to rtf is the problem, there is not much information available.

thanks,
Hennie

 

[Frink]

Hallo,

Writing RTF's eh? This is something I have done lots of, and it's quite easy, although I cheat a bit - why do something difficult when there's an easy way out?

Firstly I create a document in Word. Set up all the headers, footers, page layout etc. Also include some recognisable text in all the fonts you want to use. Then save it as RTF.
Edit it in a text editor and copy all the lines before your recognisable text into an Access routine called WriteRTFHead (which you pass the file Id of you open file), turning each line (with sensible line breaks) into a simple Print # Statement.
Then do the same for the lines after your recognisable text, into a routine called WriteRTFTail.
You can then Open a file for writing, call WriteRTFHead, write your data, then call WriteRTFTail, close the file and you have created you RTF file.
Here's my mdlRTF module:

Option Compare Database
Option Explicit
'
'mdlRTF provides functions to assist in the creation of Rich Text Format (RTF) documents
'ysnInitialiseReportFile should be called as soon as the file is opened for writing,
'and ysnCompleteReportFile should be called as the last thing before the file is closed.
'strFormatRTFString should be used whenever data not containing RTF codes is written to
'the file to ensure it is valid RTF, especially data input by the user.
'

'Write the RTF header to the opened file, including headers and footers
Public Function ysnInitialiseReportFile(ByVal pintFileNo As Integer, ByVal pstrLayoutName As String, Optional ByVal pstrPageHeading As String = "&quot As Boolean
On Error GoTo Err_ysnInitialiseReportFile

Dim dbDRAT As Database
Dim rstLayoutItemsLeft As Recordset
Dim rstLayoutItemsCentre As Recordset
Dim rstLayoutItemsRight As Recordset
Dim strSub_PageName As String
Dim strSub_VerticalPosition As String
Dim varCreateTime As Variant

ysnInitialiseReportFile = True
varCreateTime = Now

Set dbDRAT = CurrentDb
Set rstLayoutItemsLeft = dbDRAT.OpenRecordset("SELECT * FROM tblLayoutData WHERE txtLayoutName=""" & pstrLayoutName & """ AND txtHorizontalPositionName=""Left""", dbOpenSnapshot)
Set rstLayoutItemsCentre = dbDRAT.OpenRecordset("SELECT * FROM tblLayoutData WHERE txtLayoutName=""" & pstrLayoutName & """ AND txtHorizontalPositionName=""Centre""", dbOpenSnapshot)
Set rstLayoutItemsRight = dbDRAT.OpenRecordset("SELECT * FROM tblLayoutData WHERE txtLayoutName=""" & pstrLayoutName & """ AND txtHorizontalPositionName=""Right""", dbOpenSnapshot)

'Write the RTF file information
Print #pintFileNo, "{\rtf1\ansi\ansicpg1252\uc1 \deff0\deflang1033\deflangfe1033"
'Set up Fonts
Print #pintFileNo, "{\fonttbl"
Print #pintFileNo, "{\f0\froman\fcharset0\fprq2{\*\panose 02020603050405020304}Times New Roman;}"
Print #pintFileNo, "{\f1\fswiss\fcharset0\fprq2{\*\panose 020b0604020202020204}Arial;}"
Print #pintFileNo, "{\f2\fmodern\fcharset0\fprq1{\*\panose 02070309020205020404}Courier New;}"
Print #pintFileNo, "{\f33\fmodern\fcharset0\fprq1{\*\panose 020b0409020202030204}Letter Gothic;}}"
'Set up colours (0=Default, 1=Black, 2=Blue, 3=Cyan, 4=Light Green, 5=Magenta, 6=Red, 7=Yellow...
Print #pintFileNo, "{\colortbl;\red0\green0\blue0;\red0\green0\blue255;\red0\green255\blue255;\red0\green255\blue0;\red255\green0\blue255;\red255\green0\blue0;\red255\green255\blue0;\red255\green255\blue255;\red0\green0\blue128;\red0\green128\blue128;\red0\green128\blue0;\red128\green0\blue128;\red128\green0\blue0;\red128\green128\blue0;\red128\green128\blue128;\red192\green192\blue192;}"
'Set up Styles
Print #pintFileNo, "{\stylesheet"
Print #pintFileNo, "{\widctlpar\adjustright \fs20\lang2057\cgrid \snext0 Normal;}"
Print #pintFileNo, "{\*\cs10 \additive Default Paragraph Font;}"
Print #pintFileNo, "{\s15\widctlpar\tqc\tx4153\tqr\tx8306\adjustright \fs20\lang2057\cgrid \sbasedon0 \snext15 header;}"
Print #pintFileNo, "{\s16\widctlpar\tqc\tx4153\tqr\tx8306\adjustright \fs20\lang2057\cgrid \sbasedon0 \snext16 footer;}"
Print #pintFileNo, "{\*\cs17 \additive \sbasedon10 page number;}}"
'Set up document Information
Print #pintFileNo, "{\info"
Print #pintFileNo, "{\title Hennies Report}{\author Hennie}{\operator DRAT User}"
Print #pintFileNo, "{\creatim\yr" & Year(varCreateTime) & "\mo" & Month(varCreateTime) & "\dy" & Day(varCreateTime) & "\hr" & Hour(varCreateTime) & "\min" & Minute(varCreateTime) & "}"
Print #pintFileNo, "{\version1}{\edmins0}{\nofpages1}{\nofwords0}{\nofchars0}"
Print #pintFileNo, "{\*\company CompanyName}{\nofcharsws0}{\vern113}}"
'Set up Paper Size and layout
Print #pintFileNo, "\paperw11906\paperh16838\margl851\margr851\margt1134\margb1134"
Print #pintFileNo, "\facingp\widowctrl\ftnbj\aenddoc\formshade\viewkind1\viewscale100\pgbrdrhead\pgbrdrfoot \fet0\sectd"
Print #pintFileNo, "\psz9\linex0\headery567\footery567\colsx709\endnhere\titlepg\sectdefaultcl"

'Set up Headers
strSub_VerticalPosition = "Top"
'First Page Header
Print #pintFileNo, "{\headerf \pard\plain \s15\widctlpar\tqc\tx5103\tqr\tx10206\adjustright \fs20\lang2057\cgrid {"
strSub_PageName = "First"
GoSub Sub_OutputHeaderFooter
Print #pintFileNo, "} " & pstrPageHeading & "\par}"
'Even Page Header
Print #pintFileNo, "{\headerl \pard\plain \s15\widctlpar\tqc\tx5103\tqr\tx10206\adjustright \fs20\lang2057\cgrid {"
strSub_PageName = "Even"
GoSub Sub_OutputHeaderFooter
Print #pintFileNo, "} " & pstrPageHeading & "\par}"
'Odd Page Header
Print #pintFileNo, "{\headerr \pard\plain \s15\widctlpar\tqc\tx5103\tqr\tx10206\adjustright \fs20\lang2057\cgrid {"
strSub_PageName = "Odd"
GoSub Sub_OutputHeaderFooter
Print #pintFileNo, "} " & pstrPageHeading & "\par}"

'Set up Footers
strSub_VerticalPosition = "Bottom"
'First Page Footer
Print #pintFileNo, "{\footerf \pard\plain \s15\widctlpar\tqc\tx5103\tqr\tx10206\adjustright \fs20\lang2057\cgrid {\par"
strSub_PageName = "First"
GoSub Sub_OutputHeaderFooter
Print #pintFileNo, "}}"
'Even Page Footer
Print #pintFileNo, "{\footerl \pard\plain \s15\widctlpar\tqc\tx5103\tqr\tx10206\adjustright \fs20\lang2057\cgrid {\par"
strSub_PageName = "Even"
GoSub Sub_OutputHeaderFooter
Print #pintFileNo, "}}"
'Odd Page Footer
Print #pintFileNo, "{\footerr \pard\plain \s15\widctlpar\tqc\tx5103\tqr\tx10206\adjustright \fs20\lang2057\cgrid {\par"
strSub_PageName = "Odd"
GoSub Sub_OutputHeaderFooter
Print #pintFileNo, "}}"

'Initial Settings for document text
Print #pintFileNo, "\pard\plain \widctlpar\adjustright \f33\fs20\lang2057\cgrid"
Print #pintFileNo, "{"

Exit_ysnInitialiseReportFile:
rstLayoutItemsLeft.Close
rstLayoutItemsCentre.Close
rstLayoutItemsRight.Close
Exit Function
Err_ysnInitialiseReportFile:
ErrBox Err.Description, "mdlRTF.ysnInitialiseReportFile"
ysnInitialiseReportFile = False
Resume Exit_ysnInitialiseReportFile

'Internal subroutine to output a whole header or footer
'The variables strSub_PageName and strSub_VerticalPosition should be set up before this call
Sub_OutputHeaderFooter:
rstLayoutItemsLeft.FindFirst "txtPageName=""" & strSub_PageName & """ AND txtVerticalPositionName=""" & strSub_VerticalPosition & """"
rstLayoutItemsCentre.FindFirst "txtPageName=""" & strSub_PageName & """ AND txtVerticalPositionName=""" & strSub_VerticalPosition & """"
rstLayoutItemsRight.FindFirst "txtPageName=""" & strSub_PageName & """ AND txtVerticalPositionName=""" & strSub_VerticalPosition & """"
Print #pintFileNo, strFormatRTFString(rstLayoutItemsLeft!txtLayoutItemText1) & "\tab"
Print #pintFileNo, strFormatRTFString(rstLayoutItemsCentre!txtLayoutItemText1) & "\tab"
Print #pintFileNo, strFormatRTFString(rstLayoutItemsRight!txtLayoutItemText1) & "\par"
Print #pintFileNo, strFormatRTFString(rstLayoutItemsLeft!txtLayoutItemText2) & "\tab"
Print #pintFileNo, strFormatRTFString(rstLayoutItemsCentre!txtLayoutItemText2) & "\tab"
Print #pintFileNo, strFormatRTFString(rstLayoutItemsRight!txtLayoutItemText2) & "\par"
Print #pintFileNo, strFormatRTFString(rstLayoutItemsLeft!txtLayoutItemText3) & "\tab"
Print #pintFileNo, strFormatRTFString(rstLayoutItemsCentre!txtLayoutItemText3) & "\tab"
Print #pintFileNo, strFormatRTFString(rstLayoutItemsRight!txtLayoutItemText3) & "\par"
Return
End Function

'Terminate the RTF header
Public Function ysnCompleteReportFile(ByVal pintFileNo As Integer) As Boolean
On Error GoTo Err_ysnCompleteReportFile
Print #pintFileNo, "\par }}"
ysnCompleteReportFile = True
Exit_ysnCompleteReportFile:
Exit Function
Err_ysnCompleteReportFile:
ErrBox Err.Description, "mdlRTF.ysnCompleteReportFile"
ysnCompleteReportFile = False
Resume Exit_ysnCompleteReportFile
End Function

'Returns a string converting the supplied non-RTF string to RTF format
'It formats any RTF special characters so that they do not corrupt the RTF file
Public Function strFormatRTFString(ByVal pstrRTFString As String) As String
On Error GoTo Err_strFormatRTFString

Dim strReturnString As String
Dim intI As Integer
Dim ysnSpecialCode As Boolean

strReturnString = ""
ysnSpecialCode = False

For intI = 1 To Len(pstrRTFString)
If ysnSpecialCode Then
Select Case Mid$(pstrRTFString, intI, 1)
Case "d"
strReturnString = strReturnString & Date
Case "p"
strReturnString = strReturnString & "{\field{\*\fldinst {\cs17 PAGE }}{\fldrslt {\cs17\lang1024 1}}}"
Case "q"
strReturnString = strReturnString & "{\field{\*\fldinst {\cs17 NUMPAGES }}{\fldrslt {\cs17\lang1024 1}}}"
Case "t"
strReturnString = strReturnString & Time
Case Chr$(13)
strReturnString = strReturnString 'Ignore character
Case Chr$(10)
strReturnString = strReturnString 'Ignore character
Case Else
strReturnString = strReturnString & Mid$(pstrRTFString, intI, 1)
End Select
ysnSpecialCode = False
Else
Select Case Mid$(pstrRTFString, intI, 1)
Case Chr$(13)
strReturnString = strReturnString 'Ignore character
Case Chr$(10)
strReturnString = strReturnString & "\par "
Case "^"
ysnSpecialCode = True
Case Else
strReturnString = strReturnString & Mid$(pstrRTFString, intI, 1)
End Select
End If
Next intI

strFormatRTFString = strReturnString

Exit_strFormatRTFString:
Exit Function
Err_strFormatRTFString:
ErrBox Err.Description, "mdlRTF.strFormatRTFString"
strFormatRTFString = ""
Resume Exit_strFormatRTFString
End Function

'Raises a popup Exclamation error message
'pstrSubName should be of the form module.procedure, or formname_event or formname.control_event
Sub ErrBox(ByVal pstrErrorMessage As String, ByVal pstrSubName As String)
On Error GoTo Err_ErrBox
MsgBox pstrErrorMessage, vbExclamation, "Error in " & pstrSubName
Exit_ErrBox:
Exit Sub
Err_ErrBox:
MsgBox Err.Description, vbExclamation, "Error in mdlRTF.ErrBox"
Resume Exit_ErrBox
End Sub

This additionally sets up Header and Footer data, held in a table, tblLayoutData. This has a text primary key fields of:
txtLayoutName: a name for each layout (allows multiple layouts)
txtPageName: First, Odd or Even
txtVerticalPositionName: Top or Bottom (for Header or Footer)
txtHorizontalPositionName: Left, Centre or Right
The data fields are txtLayoutItemText1, txtLayoutItemText2 and txtLayoutItemText3 which are the lines of text in the Header/Footer item. In these Items you can use ^d, ^t, ^p and ^q, for Date (of generation), Time (of generation), Page Number, Total Pages respectively.
If you set up a table with these fields, the program should work. Any header and footer items not found are just set as blank.
The function strFormatRTFString returns the supplied text string, formatted for the RTF file. This should be used for user input data (unless it contains RTF codes).

I hope this is some help. If the Header/Footer bits are too tricky/confused then you can always omit them.

Also, the MS Rich Text Format (RTF) Specification, Product Support Services, Application Note 1/94 GC0165 has all the basics and is quite readable. It also has a highly amusing chapter title, Conventions of an RTF Reader. Ho Ho. Those zany cats at Microsoft.

- Frink

 

[hennep]

Hoi Frink,

I have used the same method of "cheating". Instead of Word I have used Wordpad because it creates less "trouble" in the rtf file.
What I cannot figure out are the rtf-"statements" to include the bitmap image. I have found some resources on the internet that show an example in black and white but when I try the the code to handle a coloured picture it shows distorted when I open the rtf file in Word.
I will have a look at the Application Note you mentioned, hope it shows the info I need.

thanks,
Hennie