Syntax Highlighting

Category: Controls - RichEdit

Date: 03-28-2012

Return to Index


 
'This is the same code gbSnippets is based on for implementing syntax highlighting.
'It requires a RichEdit control and a list of keywords.
 
'Compiler Comments:
'This code is written to compile with PBWin10. To compile with PBWin9,
'add this line:
#Include "CommCtrl.inc"
 
'Primary Code:
'Credit: Borje Hagsten
'Because of size, only a single copy of the procedures is shown, in the compilable example below.
'Here are the basic parts of the code
'1. RichEdit control          - allows character size/font/color formatting
'2. DATA statements with mixed case keyword list
'3  Sub synInitilaize RWords  - uses DATA statements to create upper/lower/mixed keyword arrays
'4. Subclassed RichEdit       - to capture %WM_KeyUp
'5. Sub synApplySyntax        - calls TurnOffColor, ScanLine, handles mouse pointer
'6. Sub TurnOffColor          - sets entire control to black & white (a fast of erase syntax highlighting)
'7. Sub ScanLine              - primary parsers that identifies keywords, strings, comments
'8. Function setRichTextColor - sets color of selection (keywords, strings, comments)
'9. Sub SetFont               - picks an easy to read font (Comic Sans MS)
 
 
'Compilable Example:
#Compiler PBWin 10
#Compile EXE
#Dim All
#Include "win32api.inc
#Include "richedit.inc"
 
%IDC_RichEdit = 500
Global LWords() As String, UWords() As String, MWords() As String
Global hRichEdit As DWord, hDlg As DWord, OrigRichEditProc&, CodeCase&
 
Function PBMain() As Long
   'create some sample content for the RichEdit control
   Dim Content$
   Content$ = "Function Example" + $CrLf + "Select Case MyVar" + $CrLf + "Case 12 '1st case" + $CrLf + "End Select" + $CrLf + "End Function"
   Content$ = Content$ + $CrLf + "For i = 1 to 10" + $CrLf + "Incr i" + $CrLf + "Next i"
   Content$ = Content$ + $CrLf + "If x = 2 Then" + $CrLf + "'do nothing" + $CrLf + "End If"
   Dialog New Pixels, 0, "Syntax Test",300,300,300,400, %WS_OverlappedWindow To hDlg
   'create RichEdit and subclass (to intercept %WM_KeyUp actions)
   LoadLibrary("riched32.dll")
   InitCommonControls
   Control Add Option, hDlg, 201, "Upper", 10, 10, 50, 20
   Control Add Option, hDlg, 202, "Lower", 90, 10, 50, 20
   Control Add Option, hDlg, 203, "Mixed", 170, 10, 50, 20
   Control Add "RichEdit", hDlg, %IDC_RichEdit, Content$, 10, 40, 150, 100, _
      %WS_Child Or %WS_Visible Or %ES_MultiLine Or %WS_VScroll Or %ES_AutoHScroll _
      Or %WS_HScroll Or %ES_AutoVScroll Or %ES_WantReturn Or %ES_NoHideSel, _
      %WS_Ex_ClientEdge
   Control Handle hDlg, %IDC_RichEdit To hRichEdit
   SetFont
   OrigRichEditProc& = SetWindowLong(GetDlgItem(hDlg, %IDC_RichEdit), %GWL_WndProc, CodePTR(TextWndProc))
   SendMessage hRichEdit, %EM_SETEVENTMASK, 0, %ENM_SELCHANGE Or %ENM_CHANGE
   Dialog Show Modal hDlg Call DlgProc
End Function
 
CallBack Function DlgProc() As Long
   Select Case CB.Msg
      Case %WM_InitDialog
         CodeCase& = 1        'upper lower mixed
         Control Set Option hDlg, 201, 201, 203
         synInitializeRWords
         synApplySyntax
      Case %WM_Size
         Dim w As Long, h As Long
         Dialog Get Client CB.Hndl To w,h
         Control Set Size CB.Hndl, %IDC_RichEdit, w-20, h-20
      Case %WM_Command
         Select Case CB.Ctl
            Case 201 : CodeCase& = 1 : synApplySyntax
            Case 202 : CodeCase& = 2 : synApplySyntax
            Case 203 : CodeCase& = 3 : synApplySyntax
            Case %IDC_RichEdit
               Select Case CB.Ctlmsg
                  Case %EN_Change        ' And SelectInWork = 0
                     '                          synApplySyntax
               End Select
            Case 100
               If CB.Ctlmsg = %BN_Clicked Then
                  Local iResult1&, iResult2&
                  TurnOffCol
                  ScanLine(0, SendMessage(hRichEdit, %EM_GETLINECOUNT, 0, 0) - 1)
               End If
         End Select
   End Select
End Function
 
Function TextWndProc(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As LongAs Long
   Select Case wMsg
      Case %WM_KeyUp         'trap key up, for syntax color check while editing
         Local CurLine As Long
         CurLine = SendMessage(hRichEdit, %EM_EXLINEFROMCHAR, 0, -1)
         ScanLine(CurLine, CurLine)               'check current line only
         Function = 0 : Exit Function                  'return zero
   End Select
   TextWndProc = CallWindowProc(OrigRichEditProc&, hWnd, wMsg, wParamlParam)
End Function
 
Sub synApplySyntax()
   MousePTR 11                   'Scan all lines
   TurnOffCol
   ScanLine(0, SendMessage(hRichEdit, %EM_GETLINECOUNT, 0, 0) - 1)
   MousePTR 0
   SetFocus hRichEdit
End Sub
 
Sub synInitializeRWords
   Local temp$, i As Long
   ReDim UWords(1000), LWords(1000), MWords(1000)
   Open Exe.Path$ + "powerbasic.synFor Input As #1
   While IsFalse Eof(1)
      Line Input #1, temp$
      If Len(Trim$(temp$)) Then
         MWords(i) = temp$
         UWords(i) = UCase$(MWords(i))
         LWords(i) = LCase$(MWords(i))
         Incr i
      End If
   Wend
   Close #1
   ReDim Preserve UWords(i-1), LWords(i-1), MWords(i-1)
End Sub
 
Function setRichTextColor( ByVal NewColor As LongAs Long
   ' setRichTextColor sets the textcolor for selected text in a Richedit control.
   ' &HFF - read, &HFF0000 - blue, &H008000 - dark green, &H0 is black, etc.
   Local cf As CHARFORMAT
   cf.cbSize      = Len(cf)       'Length of structure
   cf.dwMask      = %CFM_COLOR    'Set mask to colors only
   cf.crTextColor = NewColor      'Set the new color value
   SendMessage(hRichEdit, %EM_SETCHARFORMAT, %SCF_SELECTION, VarPTR(cf))
End Function
 
Sub TurnOffCol
   ' Set all text to black - faster this way
   Local cf As CHARFORMAT, xEvent As Long
   xEvent = SendMessage(hRichEdit, %EM_GETEVENTMASK, 0, 0)         'Get eventmask
   SendMessage(hRichEdit, %EM_SETEVENTMASK, 0, 0)            'Disable eventmask
   MousePTR 11                                                'Hourglass
   cf.cbSize      = Len(cf)                                   'Length of structure
   cf.dwMask      = %CFM_COLOR                                'Set mask to colors only
   cf.crTextColor = &H0                                       'Set black color value
   SendMessage(hRichEdit, %EM_SETCHARFORMAT, -1, VarPTR(cf)) '%SCF_ALL = -1
   If xEvent Then SendMessage(hRichEdit, %EM_SETEVENTMASK, 0, xEvent)     'Enable eventmask
   MousePTR 0
End Sub
 
Sub ScanLine(ByVal Line1 As Long, ByVal Line2 As Long)
   ' Syntax color parser for received line numbers
   Local pd As CHARRANGE, Oldpd As CHARRANGE, tBuff As TEXTRANGE
   Local xWord As String, Buf As String
   Local Aspect As Long, xEvents As Long, I As Long , J As Long, stopPos As Long
   Local lnLen As Long, Result As Long, wFlag As Byte, Letter As Byte Ptr
 
   SendMessage(hRichEdit, %EM_EXGETSEL, 0, VarPTR(Oldpd)) 'Original position
   '(so we can reset it later)
   'Disable the event mask, for better speed
   xEvents = SendMessage(hRichEdit, %EM_GETEVENTMASK, 0, 0)
   SendMessage(hRichEdit, %EM_SETEVENTMASK, 0, 0)
 
   'Turn off redraw for faster and smoother action
   SendMessage(hRichEdit, %WM_SETREDRAW, 0, 0)
 
   If Line1 <> Line2 Then                                  'if multiple lines
      MousePTR 11
   Else                                                                     'editing a line
      pd.cpMin = SendMessage(hRichEdit, %EM_LINEINDEX, Line1, 0)                'line start
      pd.cpMax = pd.cpMin + SendMessage(hRichEdit, %EM_LINELENGTH, pd.cpMin, 0) 'line end
      SendMessage(hRichEdit, %EM_EXSETSEL, 0, VarPTR(pd))                  'select line
      setRichTextColor &H0                                             'set black
   End If
 
   For J = Line1 To Line2
      Aspect = SendMessage(hRichEdit, %EM_LINEINDEX, J, 0)       'line start
      lnLen  = SendMessage(hRichEdit, %EM_LINELENGTH, Aspect, 0) 'line length
 
      If lnLen Then
         Buf = Space$(lnLen + 1)
         tBuff.chrg.cpMin = Aspect
         tBuff.chrg.cpMax = Aspect + lnLen
         tBuff.lpstrText = StrPTR(Buf)
         lnLen = SendMessage(hRichEdit, %EM_GETTEXTRANGE, 0, ByVal VarPTR(tBuff)) 'Get line
 
         CharUpperBuff(ByVal StrPTR(Buf), lnLen)        'Make UCASE
         'I always use this one, since it handles characters > ASC(127) as well.. ;-)
 
         '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         ' Loop through the line, using a pointer for better speed
         '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         Letter = StrPTR(Buf) : wFlag = 0
         For I = 1 To Len(Buf)
            Select Case @Letter 'The characters we need to inlude in a word
               Case 97 To 122, 65 To 90, 192 To 214, 216 To 246, 248 To 255, _
                     35 To 38, 48 To 57, 63, 95
                  If wFlag = 0 Then
                     wFlag = 1 : stopPos = I
                  End If
 
               Case 34 ' string quotes -> "
                  stopPos = Instr(I + 1, Buf, Chr$(34)) 'Find match
                  If stopPos Then
                     pd.cpMin = Aspect + I
                     pd.cpMax = Aspect + stopPos - 1
                     SendMessage(hRichEdit, %EM_EXSETSEL, 0, VarPTR(pd))
                     setRichTextColor &HFF
                     StopPos = (StopPos - I + 1)
                     I = I + StopPos
                     Letter = Letter + StopPos
                     wFlag = 0
                  End If
 
               Case 39 ' uncomment character -> '
                  pd.cpMin = Aspect + I - 1
                  pd.cpMax = Aspect + lnLen
                  SendMessage(hRichEdit, %EM_EXSETSEL, 0, VarPTR(pd))
                  setRichTextColor &H00008000&
                  wFlag = 0
                  Exit For
 
               Case Else  'word is ready
                  If wFlag = 1 Then
                     xWord = Mid$(Buf, stopPos, I - stopPos)  'Get word
 
                     If xWord = "REMThen  'extra for the uncomment word, REM
                        pd.cpMin = Aspect + I - Len(xWord) - 1
                        pd.cpMax = Aspect + lnLen
                        SendMessage(hRichEdit, %EM_EXSETSEL, 0, VarPTR(pd))
                        setRichTextColor &H00008000&
                        wFlag = 0
                        Exit For
                     End If
                     Array Scan UWords(0), = xWord, To Result  'Is it in the array?
                     If Result Then
                        pd.cpMin = Aspect + stopPos - 1
                        pd.cpMax = Aspect + I - 1
                        '---------------------------------upper/lower/mixed handled here-----------
                        SendMessage(hRichEdit, %EM_EXSETSEL, 0, VarPTR(pd))
                        If CodeCase& Then
                           xWord = Choose$(CodeCase&, UWords(Result-1), LWords(Result-1), MWords(Result-1))
                           Control Send hDlg, %IDC_RichEdit, %EM_ReplaceSel, %True, StrPTR(xWord)
                        End If
                        '----------------------------------------------------------------------
                        SendMessage(hRichEdit, %EM_EXSETSEL, 0, VarPTR(pd))
                        setRichTextColor(&HFF0000)       'set blue color
                     End If
                     wFlag = 0
                  End If
            End Select
 
            Incr Letter
         Next I
      End If
   Next J
 
   'Reset original caret position
   SendMessage(hRichEdit, %EM_EXSETSEL, 0, VarPTR(Oldpd))
 
   'Turn on Redraw again and refresh - this one causes some flicker in Richedit..
   SendMessage hRichEdit, %WM_SETREDRAW, 1, 0
   InvalidateRect hRichEdit, ByVal %NULL, 0 : UpdateWindow hRichEdit
 
   'Reset the event mask
   If xEvents Then SendMessage(hRichEdit, %EM_SETEVENTMASK, 0, xEvents)
End Sub
 
Sub SetFont
   Dim hFont As DWord
   Font New "Comic Sans MS", 10, 1 To hFont
   Control Set Font hDlg, %IDC_RichEdit, hFont
End Sub
 
'gbs_00281
'Date: 03-10-2012


created by gbSnippets
http://www.garybeene.com/sw/gbsnippets.htm