Gustav Brock
gustav at cactus.dk
Sat Nov 1 13:27:13 CST 2003
Hi William, Tom
> The client has got new budgets and is again asking for this:
>> My simple need (which I never got solved) was how to assemble an
>> rtf-formatted field from many records (essentially each an rtf
>> document) into one rtf document, stripping headers etc. from each
>> record and adding a header etc. to the final document.
> Does anybody have a clue how to attack it?
> It is for assembling a catalogue where each item in Access has it own
> small description in formatted text (bold, underline, sub/sup script
> only) into one rtf document which are read by the dtp people.
> Basically the task is to strip the header and the tail from the small
> rtf strings, concatenation these, then adding one header and one tail
> to create one finished document.
I did a Google search on "concatenate" and "rtf" and located some new
hits, though mostly from nice people without a proven solution.
However, I noticed you can use the RichTextBox on its own without
having a control on a form:
<code snip>
Dim rtf As RichTextBox
Dim strRTF As String
Set rtf = New RichTextBox
rtf.TextRTF = "Gustav"
Debug.Print rtf.TextRTF
Set rtf = Nothing
</code snip>
This will output:
<rtf>
{\rtf1\ansi\deff0{\fonttbl{\f0\fnil\fcharset0 MS Sans Serif;}}
\viewkind4\uc1\pard\lang1030\f0\fs17 Gustav
\par }
</rtf>
The nice thing with this control is that is has a much wider selection
of text controls than the ocx, for example, superscript and subscript.
By playing around with it I found out that the key to locate the
beginning of the body is the code \pard which seems to always exists;
then locate the following Space. This will skip the leading font
tables and coloursets and bunches of other useless info wrapped in
sets of curly brackets, {...}.
This works fine except if the first char of the body is a non-ascii
char; if so, RTF uses a single byte hex representation of the char and
omits the Space. As an example, this is the string for "€240":
<rtf\
{\rtf1\ansi\deff0{\fonttbl{\f0\fnil\fcharset0 MS Sans Serif;}}
\viewkind4\uc1\pard\lang1030\f0\fs17\'80240
\par }
</rtf>
Note the missing Space.
The escape sequence for such hex bytes is "\'". Thus you'll have
locate first the \pard control code then either a Space or the hex
escape sequence whatever comes first.
Following the body are some closing chars which may be "}" only or
this followed by a CrLf and perhaps a Chr(0). To remove these, one
must travel from the end of the document up to the last "}" and chop
the tail off.
The remaining part is the body which can be concatenated like any
other string with other RTF body strings. When done, apply a minimum
header and a closing "}" and write this to a file and your RTF
document is ready! And, as this is pure code with no ocx or fancy
utils it runs at flashing speed!
First, here's one solution for extracting the RTF body:
<code>
Public Function TrimTextBodyRTF(strTextRTF As String) As String
' Extract RTF body of full RTF formatted string.
'
' 2003-11-01. Gustav Brock. Cactus Data ApS. CPH.
' RTF escape char.
Const cstrRTFEscape As String = "\"
' RTF code identifying RTF control codes leading RTF body.
Const cstrRTFBodyPointer As String = cstrRTFEscape + "pard"
' Char identifying hex code for non-ascii char.
Const cstrRTFByteChar As String = "'"
' Header string for hex code for non-ascii char.
Const cstrRTFByteHeader As String = cstrRTFEscape + cstrRTFByteChar
' Char identifying start of RTF body if first RTF char is an ascii char.
Const cstrRTFBodyHeader As String = " "
' Char closing RTF body.
Const cstrRTFBodyEnd As String = "}"
Dim strRTF As String
Dim strEnd As String
Dim lngPos As Long
Dim lngPosAsc As Long
Dim lngPosHex As Long
Dim lngEnd As Long
Dim lngLen As Long
Dim lngChr As Long
If Len(strTextRTF) > 0 Then
' Locate RTF body pointer.
lngPos = InStr(strTextRTF, cstrRTFBodyPointer)
If lngPos > 0 Then
' Locate start of body if first char is an ascii char.
lngPosAsc = InStr(lngPos, strTextRTF, cstrRTFBodyHeader)
' Check if first char in RTF body is a non-ascii char.
lngPosHex = InStr(lngPos, strTextRTF, cstrRTFByteHeader) - 1
lngPos = 0
If lngPosAsc > 0 Then
If lngPosHex > 0 Then
If lngPosHex < lngPosAsc Then
lngPos = lngPosHex
Else
lngPos = lngPosAsc
End If
Else
lngPos = lngPosAsc
End If
Else
lngPos = lngPosHex
End If
If lngPos > 0 Then
strRTF = Mid(strTextRTF, 1 + lngPos)
' Locate position of RTF end marker (closing bracket).
lngChr = Asc(cstrRTFBodyEnd)
lngLen = Len(strRTF)
lngEnd = 1
While Asc(Right(strRTF, lngEnd)) <> lngChr And lngEnd < lngLen
lngEnd = lngEnd + 1
Wend
If lngEnd = lngLen Then
' RTF end marker was not found.
lngPos = 0
Else
' Calculate length of RTF body.
lngPos = lngLen - lngEnd
End If
' Trim RTF body.
strRTF = Left(strRTF, lngPos)
End If
End If
End If
TrimTextBodyRTF = strRTF
End Function
</code>
Having reached this point it's a simple matter to assemble and write
the full RTF document (watch for line breaks):
<code>
Public Function ConcatenateTextRTF() As Boolean
' Concatenate RTF body strings to one fully formatted RTF file.
'
' Error handling is missing.
'
' 2003-11-01. Gustav Brock. Cactus Data ApS. CPH.
' RTF header.
' Adjust codepage and language code and font as needed.
' Append fontsize to \f0 if needed. "\fs16" for 8 points.
Const cstrRTFBodyHeader As String = "{\rtf1\ansi\ansicpg1252\deflang1030\deff0{\fonttbl{\f0\fnil\fcharset0 Arial;}}\viewkind4\uc1\pard\f0 "
' RTF closing bracket.
Const cstrRTFBodyEnd As String = "}"
' Filename of finished RTF document.
Const cstrRTFFile As String = "c:\winnt\temp\test.rtf"
Dim dbs As Database
Dim rst As Recordset
Dim strRTF As String
Dim intFile As Integer
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("Tabel1")
' Set RTF header.
strRTF = cstrRTFBodyHeader
' Concatenate RTF bodies.
With rst
While .EOF = False
If Not IsNull(!MemoRTF) Then
strRTF = strRTF + TrimTextBodyRTF(!MemoRTF)
End If
.MoveNext
Wend
.Close
End With
' Append RTF closing bracket.
strRTF = strRTF + cstrRTFBodyEnd
' Write RTF file.
intFile = FreeFile
Open cstrRTFFile For Output As #intFile
Print #intFile, strRTF
Close #intFile
Set rst = Nothing
Set dbs = Nothing
ConcatenateTextRTF = True
End Function
</code>
I'm pretty sure this won't be able concatenate any collection of RTF
documents whatever the size. But until further testing has been
carried out, I guess it will be able to concatenate a vast amount of
small RTF docs like those found and produced in an ocx controlled RTF
memobox.
/gustav