Formatting RichEdit Content

[Gary Beene]

I've previously published various ways to format RichEdit content. Here's an example that does 5 kinds of formatting:

Case - upper/lower
Character Spacing - horizontal gap between characters
Line Spacing - vertical gap between lines
Paragraph Formatting - merge lines separated by a single $crlf into paragraphs
Underline - underline the currently selected line of text

Discussion here.

'Compilable Example:  'Jose Includes
#Compile Exe
#Dim All
%Unicode = 1
#Include "Win32API.inc"

%MultiLineREStyle_Wrap    = %WS_Child Or %WS_ClipSiblings Or %WS_Visible Or %ES_MultiLine Or %WS_VScroll Or %ES_AutoVScroll                    Or %ES_WantReturn Or %ES_NoHideSel Or %WS_TabStop Or %ES_SaveSel

Global RTFExpandA As WStringZ * %Max_Path

Enum Equates Singular
   IDC_RichEdit = 500
   IDC_Case
   IDC_Letters
   IDC_Under
   IDC_Lines
   IDC_Paragraph
End Enum

Global hDlg,hRichEdit,OldREProc As Dword
Global UnderlineCurrentLine, WideSpacing, LIneSpacing, CaseType, FormatParagraph As Long
Global LastUnderLine, TurnOffResult As Long
Global OriginalText$

Function PBMain() As Long
   Dialog Default Font "Arial Black", 24, 1
   Dialog New Pixels, 0, "PowerBASIC",,,700,700, %WS_OverlappedWindow To hDlg
   OriginalText$ = "This is a formatting" + $CrLf + "test to figure out the" + $CrLf + "formatting code I want!"
   OriginalText$ += $CrLf + $CrLf + OriginalText$
   LoadLibrary("msftedit.dll")
   Control Add "RichEdit50W", hDlg, %IDC_RichEdit, OriginalText$,10, 60, 680, 630, %MultiLineREStyle_Wrap, %WS_Ex_ClientEdge
   Control Handle hDlg, %IDC_RichEdit To hRichEdit
   SendMessage hDlg, %EM_SetEventMask, 0, %ENM_SelChange
   OldREProc = SetWindowLong(hRichEdit, %GWL_WNDPROC, CodePtr(REProc))

   Control Add Button, hDlg, %IDC_Case,"Case", 10,10,120,35
   Control Add Button, hDlg, %IDC_Letters,"Ltrs", 140,10,120,35
   Control Add Button, hDlg, %IDC_Under,"Under", 270,10,120,35
   Control Add Button, hDlg, %IDC_Lines,"Lines", 410,10,120,35
   Control Add Button, hDlg, %IDC_Paragraph,"Para", 560,10,120,35
   Dialog Show Modal hDlg Call DlgProc
End Function

CallBack Function DlgProc() As Long
   Select Case Cb.Msg
      Case %WM_InitDialog
         RTFExpandA = "\expndtw720 "
      Case %WM_Command
         Select Case Cb.Ctl
            Case %IDC_Case        : Format_Case(hDlg,%IDC_RichEdit)           'hDlg/%IDC_RichEdit are Global, but in practice I might Format one of several RichEdit controls
            Case %IDC_Letters     : Format_WideSpacing(hDlg,%IDC_RichEdit)
            Case %IDC_Lines       : Format_LineSpacing(hDlg,%IDC_RichEdit)
            Case %IDC_Paragraph   : Format_Paragraph(hDlg,%IDC_RichEdit)
            Case %IDC_Under       : Format_Underline
         End Select
   End Select
End Function

Sub sBeep : WinBeep (250,300) : End Sub

Function REProc(ByVal hWnd As Dword, ByVal wMsg As Long, ByVal wParam As Dword, ByVal lParam As Long) As Long
   Local CallSetCaret, i As Long, KeyState As Long
   Select Case wMsg
      Case %WM_KeyUp
        If (hWnd = hRichEdit) And UnderLineCurrentLine Then RERemoveUnderLines(hRichEdit) : REUnderLineCurrentLine(hRichEdit)
      Case %WM_LButtonUp
        If (hWnd = hRichEdit) And UnderLineCurrentLine Then RERemoveUnderLines(hRichEdit) : REUnderLineCurrentLine(hRichEdit)
      Case %WM_Destroy
         SetWindowLong(hWnd, %GWL_WNDPROC, OldREProc)
   End Select
   Function = CallWindowProc(OldREProc, hWnd, wMsg, wParam, lParam)
End Function

Function RESelectedText(hControl As Dword) As String   'always get text from hRichEdit
   Local rP As CharRange, temp$
   SendMessage hControl, %EM_ExGetSel, 0, VarPtr(rP)
   Control Get Text GetParent(hControl), %IDC_RichEdit To temp$
   Replace $CrLf With $Lf In temp$
   temp$ = Mid$(temp$, rP.cpmin+1 To rP.cpmax)
   Replace $Lf With $CrLf In temp$
   Function = temp$
End Function

Sub RERemoveUnderLines(hControl As Dword)  'remove underline from all words
   Local cf As CharFormat2
   RETurnOff hControl
   cf.cbSize = SizeOf(cf)
   SendMessage hControl, %EM_GetCharFormat, %SCF_All, VarPtr(cf)
   cf.dwMask = %CFM_UnderLine
   cf.dwEffects = cf.dwEffects Xor Not %CFM_Underline
   SendMessage hControl, %EM_SetCharFormat, %SCF_All, VarPtr(cf)
   RETurnON hControl
End Sub

Sub REUnderlineCurrentLine(hControl As Dword)
   Local cf As CharFormat2, rP As CharRange
   Local CurrentLine, LineLength As Long

   RETurnOff(hControl)

   CurrentLine = SendMessage(hControl, %EM_EXLineFromChar, 0,-1)   'current line# / 1st line of selection
   LastUnderLine = CurrentLine
   rP.cpMin = SendMessage(hControl, %EM_LineIndex, CurrentLine, 0)  'position of 1st char in line#
   LineLength = SendMessage(hControl, %EM_LineLength, rP.cpMin, 0)  'length of line starting at that char position
   rP.cpMax = rP.cpMin + LineLength
   SendMessage(hControl, %EM_EXSetSel, 0, VarPtr(rP))               'select specified text (rP.cpmin-rP.cpmax)

   'remove existing underlines
   cf.cbSize = SizeOf(cf)
   SendMessage hControl, %EM_GetCharFormat, %SCF_All, VarPtr(cf)
   cf.dwMask = %CFM_UnderLine
   cf.dwEffects = cf.dwEffects Xor Not %CFM_Underline
   SendMessage hControl, %EM_SetCharFormat, %SCF_All, VarPtr(cf)

   'underline
   cf.cbSize = SizeOf(cf)
   SendMessage hControl, %EM_GetCharFormat, %SCF_Selection, VarPtr(cf)
   cf.dwMask = %CFM_UnderLine
   cf.dwEffects = cf.dwEffects Xor %CFM_Underline
   SendMessage hControl, %EM_SetCharFormat, %SCF_Selection, VarPtr(cf)
   SendMessage(hControl, %EM_SetSel, rP.cpMin, rP.cpMin)

   RETurnOn(hControl)

End Sub

Sub RETurnOff(hControl As Dword)
   TurnOffResult = SendMessage(hControl, %EM_GETEVENTMASK, 0, 0)  'get current event mask
   SendMessage(hControl, %EM_SETEVENTMASK, 0, 0)
   SendMessage(hControl, %WM_SETREDRAW, 0, 0)
End Sub

Sub RETurnOn(hControl As Dword)
   SendMessage hControl, %WM_SETREDRAW, 1, 0
   InvalidateRect hControl, ByVal %NULL, 0 : UpdateWindow hControl
   If TurnOffResult Then SendMessage(hControl, %EM_SETEVENTMASK, 0, TurnOffResult)  'restore event mask
End Sub

Sub Format_Case(hParent As Dword, ControlID As Long)
   CaseType Xor=1
   RESetText_New hParent, ControlID
End Sub

Sub Format_WideSpacing(hParent As Dword, ControlID As Long)
   Incr WideSpacing : If WideSpacing > 2 Then WideSpacing = 0
   RESetText_New hParent, ControlID
End Sub

Sub Format_Underline
   UnderLineCurrentLine Xor=1
   RERemoveUnderLines(hRichEdit)
   If UnderLineCurrentLine Then REUnderLineCurrentLine(hRichEdit)
End Sub

Sub Format_LineSpacing(hParent As Dword, ControlID As Long)
   Incr LineSpacing : If LineSpacing > 2 Then LineSpacing = 0
   RESetText_New hParent, ControlID
End Sub

Sub Format_Paragraph(hParent As Dword, ControlID As Long)
   FormatParagraph Xor=1
   RESetText_New hParent, ControlID
End Sub

Sub RESetText_New(hParent As Dword, ControlID As Long)
   Local hControl As Dword, temp$, ParaFormt2 As PARAFORMAT2, RtfText As String

   hControl = GetDlgItem(hParent,ControlID)
   RETurnOff hControl

   'Case
   RtfText = IIf$(CaseType, UCase$(OriginalText$), OriginalText$)
   Control Set Text hParent, ControlID, RtfText

   'Paragraph Formatting
   If FormatParagraph Then
      Replace $CrLf + $CrLf    With "::::;;;;::::"  In RtfText  'get rid of paragraph separation
      Replace $CrLf            With $Spc            In RtfText  'merge individual lines separated by a single $crlf
      Replace "::::;;;;::::"   With $CrLf + $CrLf   In RtfText  'restore the paragraph separation
      Control Set Text hParent, ControlID, RtfText
   End If

   'Character Spacing
   If WideSpacing Then
      RTFExpandA = Choose$(WideSpacing, "\expndtw360 ", "\expndtw720 ")
      RtfText = "{\rtf1\ansi " + RTFExpandA + RtfText + "}"    'Insert expand instruction.
      Replace $CrLf With "\par " In RtfText
      'Replace "{\rtf1\ansi \expndtw360 {\rtf1\ansi \expndtw360" With "{\rtf1\ansi \expndtw360" In RtfText
      SendMessage hControl, %WM_SetText, 0, StrPtr(RtfText)  'place in RichEdit as RTF text
   End If

   'Line Spacing
   If LineSpacing Then
      SendMessage hControl, %EM_SetSel, 0, -1
      ParaFormt2.dwMask           = %PFM_LINESPACING
      ParaFormt2.dyLineSpacing    = Choose(LineSpacing,30,40,50) '20 = one line height, 40 = 2, 10 = ½
      ParaFormt2.bLineSpacingRule = 5  'Five mean that dyLineSpacing is in twentieth, see MSDN
      ParaFormt2.cbSize           = SizeOf(PARAFORMAT2)
      SendMessage(hControl, %EM_SETPARAFORMAT, 0, VarPtr(ParaFormt2))
      SendMessage hControl, %EM_SetSel, -1, 0
   End If

   RETurnON hControl
   SendMessage hControl, %EM_SetSel, 0, 0  'could capture the starting postion and restore it here
   Control Set Focus hParent, ControlID

End Sub
​