Syntax Highlighting (Visible Lines Only)

Category: Controls - RichEdit

Date: 03-28-2012

Return to Index


 
'... this snippet is in work
 
'Compiler Comments:
'This code is written to compile with PBWin10. To compile with PBWin9,
'add this line:
#Include "CommCtrl.inc"
 
'Compilable Example:
#Compiler PBWin 10
#Compile EXE
#Dim All
#Include "win32api.inc
#Include "richedit.inc"
Declare Function WinMsg Lib "WINMSG.DLL" Alias "WindowMessageA" (ByVal MsgNum As LongAs String
 
%IDC_RichEdit = 500
Global LWords() As String, UWords() As String, MWords() As String, iCount&
Global hRichEdit As DWord, hDlg As DWord, OrigRichEditProc&
'Global iTopLine&, iBottomLine&, iCurrentLine&
 
Function PBMain() As Long
   'create some sample content for the RichEdit control
   Dim Content$, i As Long
   For i = 0 To 200 : Content$ = Content$ + Format$(i, "  000 ") + Repeat$( 5, Choose$(Rnd(1,5), "Select ", "End ", "If ", "Exit ", "Loop ") ) + $CrLf : Next i
   Dialog New Pixels, 0, "Syntax Test",300,300,450,400, %WS_OverlappedWindow To hDlg
   LoadLibrary("riched32.dll")
   InitCommonControls
   Control Add Button, hDlg, 204, "Current Line", 50, 10, 90, 20
   Control Add Button, hDlg, 205, "Visible Lines", 150, 10, 90, 20
   Control Add Button, hDlg, 206, "All Black", 250, 10, 90, 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
   Dialog Show Modal hDlg Call DlgProc
End Function
 
CallBack Function DlgProc() As Long
   Local iTopLine&, iBottomLine&, iCurrentLine&
   Select Case CB.Msg
      Case %WM_InitDialog
         OrigRichEditProc& = SetWindowLong(GetDlgItem(hDlg, %IDC_RichEdit), %GWL_WndProc, CodePTR(TextWndProc))
         SendMessage hRichEdit, %EM_SETEVENTMASK, 0, %ENM_SELCHANGE Or %ENM_CHANGE Or %ENM_Scroll
         SetFont
         synInitializeRWords
      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-50
      Case %WM_Paint
         cprint "wm_paint"
         GetLineNumbers
         ApplySyntax  iTopLine&, iBottomLine&     'when dialog is resized
      Case %WM_Command
         GetLineNumbers
         Select Case CB.Ctl
            Case 204 :              If CB.Ctlmsg = %BN_Clicked Then ApplySyntax iCurrentLine&, iCurrentLine&
            Case 205 :              If CB.Ctlmsg = %BN_Clicked Then ApplySyntax iTopLine&, iBottomLine&
            Case 206 :              If CB.Ctlmsg = %BN_Clicked Then TurnOffColor
         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
   Local iTopLine&, iBottomLine&, iCurrentLine&
   Select Case wMsg
      Case %WM_KeyDown
         GetLineNumbers
         Select Case wParam
            Case %VK_Up      'UpArrow
               cprint "wm_keydown  vk_up"
               If (iCurrentLine& = iTopLine&) AND iCurrentLine& Then
                  ApplySyntax iTopLine&-1, iTopLine&-1   ': Function = 0 : Exit Function
                  SendMessage (hRichEdit, %EM_Scroll, %SB_LineUp, 0)
               End If
            Case %VK_Down    'DownArrow
               cprint "wm_keydown  vk_down"
               If iCurrentLine& = iBottomLine& Then
                  ApplySyntax iBottomLine&+1, iBottomLine&+1   ': Function = 0 : Exit Function
                  SendMessage (hRichEdit, %EM_Scroll, %SB_LineDown, 0)
               End If
            Case %VK_Prior   'PageUp
               cprint "wm_keydown  vk_pageUp"
               ApplySyntax iTopLine&-1+iBottomLine&-iTopLine&, iBottomLine&   : Function = 0 : Exit Function
               SendMessage (hRichEdit, %EM_Scroll, %SB_PageUp, 0)
            Case %VK_Next    'PageDown
               cprint "wm_keydown  vk_pageDown"
               ApplySyntax iBottomLine&+1, iBottomLine&-iTopLine&  : Function = 0 : Exit Function
               SendMessage (hRichEdit, %EM_Scroll, %SB_PageDown, 0)
            Case Else
               'allow processing to go through
         End Select
      Case %WM_KeyUp
         ApplySyntax iCurrentLine&, iCurrentLine& : Function = 0 : Exit Function   'key up (syntax highlighting while editing)
      Case %WM_MouseWheel      'generates en_vscroll, where syntax_visiblelines is called
         cprint "wm_mousewheel"
         GetLineNumbers
         If Hi(Integer,wParam) > 0 Then
            ApplySyntax iTopLine&-1, iTopLine&-1
            'SendMessage (hRichEdit, %EM_Scroll, %SB_LineUp, 0)
         Else
            ApplySyntax iBottomLine&+1, iBottomLine&+1
            'SendMessage (hRichEdit, %EM_Scroll, %SB_LineDown, 0)
         End If
         'Function = 0 : Exit Function
      Case %WM_VScroll        'when an event occurs in the scroll bar
         cprint "wm_vscroll"  'generate en_scroll
         GetLineNumbers
         Select Case Lo(Word,wParam)
            Case %SB_LineUp
               ApplySyntax iTopLine&-1, iTopLine&-1  : Function = 0 : Exit Function
               'SendMessage (hRichEdit, %EM_Scroll, %SB_LineUp, 0)
            Case %SB_LineDown
               ApplySyntax iBottomLine&+1,iBottomLine&+1 ': Function = 0 : Exit Function
               'SendMessage (hRichEdit, %EM_Scroll, %SB_LineDown, 0)
            Case %SB_PageUp
               ApplySyntax iTopLine&-1, iTopLine&-iBottomLine+iTopLine&-1 : Function = 0 : Exit Function
               SendMessage (hRichEdit, %EM_Scroll, %SB_PageUp, 0)
            Case %SB_PageDown
               ApplySyntax iBottomLine&+1, iBottomLine&+iBottomLine&-iTopLine+1: Function = 0 : Exit Function
               SendMessage (hRichEdit, %EM_Scroll, %SB_PageDown, 0)
            Case %SB_ThumbPosition
               ApplySyntax 0,0
            Case %SB_ThumbTrack
               ApplySyntax 0,0
         End Select
   End Select
   TextWndProc = CallWindowProc(OrigRichEditProc&, hWnd, wMsg, wParamlParam)
End Function
 
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
   ' works on selected text. &HFF red, &HFF0000 blue, &H008000 dark green, &H0 is black
   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 ApplySyntax(Line1&, Line2&)
   cprint "apply_syntax"
   Local pd As CharRange, cf As CharFormat, Oldpd As CharRange, iEventMask&
   MousePTR 11
 
   'save position/eventmask, disable eventmask/redraw
   SendMessage(hRichEdit, %EM_EXGETSEL, 0, VarPTR(Oldpd))            'save original position
   iEventMask& = SendMessage(hRichEdit, %EM_GETEVENTMASK, 0, 0)   'save event mask
   SendMessage(hRichEdit, %EM_SETEVENTMASK, 0, 0)                   'disable event mask
   SendMessage(hRichEdit, %WM_SETREDRAW, 0, 0)                       'disable redraw
 
   'select specified lines
   pd.cpMin = SendMessage(hRichEdit, %EM_LINEINDEX, Line1&, 0)               'char at start of iTopLine
   pd.cpMax = SendMessage(hRichEdit, %EM_LINEINDEX, Line2&, 0)           'char at start of iBottomLine
   pd.cpMax = pd.cpMax + SendMessage(hRichEdit, %EM_LINELENGTH, pd.cpMax, 0) 'char at end of iBottomLine
   SendMessage(hRichEdit, %EM_EXSETSEL, 0, VarPTR(pd))                            'select visible lines
 
   'set visible lines to black
   cf.cbSize      = Len(cf)            'Length of structure
   cf.dwMask      = %CFM_COLOR    'Set mask to colors only
   cf.crTextColor = &H0               'Set the new color value
   SendMessage(hRichEdit, %EM_SETCHARFORMAT, %SCF_Selection, VarPTR(cf))
 
   'colorize the visible lines
   ScanLine (Line1&, Line2&)
 
   'restore position/eventmask, enable eventmask/redraw
   SendMessage(hRichEdit, %EM_EXSETSEL, 0, VarPTR(Oldpd))           'restore caret position
   SendMessage hRichEdit, %WM_SETREDRAW, 1, 0                       'turn on redraw
   InvalidateRect hRichEdit, ByVal %NULL, 0 : UpdateWindow hRichEdit  'refresh
   SendMessage(hRichEdit, %EM_SETEVENTMASK, 0, iEventMask&)              'enable event mask
   MousePTR 0
End Sub
 
Sub GetLineNumbers
   Local iTopLine&, iBottomLine&, iCurrentLine&
   'assumes hDlg, %ID_RichEdit and hRichEdit Global variables
   Local P As Point, w As Long, h As Long
   Control Get Client hDlg, %IDC_RichEdit To w,h
   P.x = w : P.y = h
   iTopLine& = SendMessage(hRichEdit, %EM_GetFirstVisibleLine,0,0)       'visible line# at top of control
   iBottomLine& = SendMessage(hRichEdit, %EM_CharFromPos, 0, VarPTR(P) )
   iBottomLine& = SendMessage(hRichEdit, %EM_LineFromChar, iBottomLine&, 0)
   iCurrentLine& = SendMessage(hRichEdit, %EM_EXLINEFROMCHAR, 0, -1)               'current line
 
End Sub
 
Sub SetTopLine(iDesiredLine&)
   Local iTopLine&
   'first time aligns a line at the top of the control, but it may not be the desired line
   iTopLine& = SendMessage (hRichEdit, %EM_GetFirstVisibleLine, 0,0)
   SendMessage hRichEdit, %EM_LineScroll, 0, iDesiredLine& - iTopLine&
   'the second time ensures the proper result
   iTopLine& = SendMessage (hRichEdit, %EM_GetFirstVisibleLine, 0,0)
   SendMessage hRichEdit, %EM_LineScroll, 0, iDesiredLine& - iTopLine&
End Sub
 
Sub ScanLine(ByVal Line1 As Long, ByVal Line2 As Long)
   Local iTopLine&, iBottomLine&, iCurrentLine&
   ' Syntax color parser for received line numbers
   Local tBuff As TEXTRANGE, pd As CHARRANGE
   Local xWord As String, Buf As String
   Local Aspect 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
 
   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
                        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
 
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
 
Sub TurnOffColor
   ' 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 CPrint (SOut As String)
   Static hConsole As Long, cWritten As Long
   Incr iCount&
   SOut = Str$(iCount&) + "  " + SOut
   If hConsole = 0 Then AllocConsole: hConsole = GetStdHandle(-11&)
   WriteConsole hConsole, ByCopy sOut + $CrLf, Len(sOut) + 2, cWritten, ByVal 0&
End Sub
 
'gbs_00420
'Date: 03-10-2012


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