Re: Lebans RTF2 Control Default Font Microsoft Access 2003

From: jpkemp (jpkemp_at_nospam.kempscaseworks.com)
Date: 05/22/04 

Date: Sat, 22 May 2004 15:42:22 -0400

Stephen,
I'm committed to using your RTF2 control and not moving to an HTML
solution. I've looked at the code that is supposed to select the default
font of the box, and have tried to modify the text currently in the box,
to no avail. It may be that I have to select text first or have placed
things in the wrong sequence.
 
This is the code behind my button that corrects the non RTF code with RTF
tags. My problem is that I can't manage to get it to do anything other
than the system font, which when brought up in Word shows up as long thin
lines. If the lines are highlighted and the font changed, there isn't a
problem.

Thanks for your help with this.

The code selects memo field contents (summary) that are missing RTF
coding. It blots out the RTF label or that shows up in the first record.
It then puts in the required tabs and paragraph markers and drops it into
the RTF box. This puts the code in and then it's stored back in the memo
field. It loops through the recordset until all screwed up memo fields
have RTF coding on them.

Private Sub Command0_Click()
On Error GoTo p_err
DoCmd.Hourglass True
Application.Echo False
x = 1
crit = "SELECT CLIENTSW.CASENUM, CLIENTSW.SUMMARY FROM CLIENTSW WHERE
(((CLIENTSW.SUMMARY) Not Like ""*rtf*"" And (CLIENTSW.SUMMARY) Is Not
Null));"
Set mdb = CurrentDb()
Set mrs = mdb.OpenRecordset(crit, dbOpenDynaset, DbSeeChanges)
If mrs.EOF And mrs.BOF Then
Else
Dim xz As String
Me!SUMMARY.rtfText = ""
'Loop through the records
mrs.MoveFirst
    Do While Not mrs.EOF And x < 3000
'Replace the new lines and tabs
        xz = mrs!SUMMARY
        xz = Replace(xz, vbNewLine, "\par ")
        xz = Replace(xz, vbTab, "\tab ")
'Change to RTF text
        Me!SUMMARY.Object.SelText = xz
        Set txtRTF = Me.SUMMARY.Object
'Update the Summary field
        mrs.Edit
        mrs!SUMMARY.Value = txtRTF.rtfText
        txtRTF.rtfText = ""
        mrs.Update
        mrs.MoveNext
        x = x + 1
    Loop
mrs.Close
Set mrs = Nothing
Set mdb = Nothing
End If
DoCmd.Hourglass False
Application.Echo True
MsgBox x
Exit Sub
p_err:
Application.Echo True
MsgBox Err.Description
End Sub