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&, iWheel&
 
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
   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"
         Syntax_VisibleLines     'when dialog is resized
      Case %WM_Command
         Select Case CB.Ctl
            Case 204 :              If CB.Ctlmsg = %BN_Clicked Then Syntax_CurrentLine
            Case 205 :              If CB.Ctlmsg = %BN_Clicked Then Syntax_VisibleLines
            Case 206 :              If CB.Ctlmsg = %BN_Clicked Then TurnOffColor
            Case %IDC_RichEdit
               Select Case Hi(Word, CB.wParam)
                  Case %EN_VScroll
                     If iWheel& Then
                        cprint "en_vscroll"
                        iWheel& = 0
                        'vertical scroll bar, scroll mouse wheel, arrow buttons on vertical scroll bar
                        'between arrow button and thumb, keyboard HOME, END, PageUp, PageDown, UpArrow, DownArrow
                        'NOT when click thumb
                        Syntax_VisibleLines
                     End If
               End Select
         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
         Syntax_CurrentLine : Function = 0 : Exit Function   'key up (syntax highlighting while editing)
      Case %WM_MouseWheel      'generates en_vscroll, where syntax_visiblelines is called
         cprint "wm_mousewheel"
         iWHeel& = 1
         If Hi(Integer,wParam) > 0 Then
            SendMessage (hRichEdit, %EM_Scroll, %SB_LineUp, 0)
         Else
            SendMessage (hRichEdit, %EM_Scroll, %SB_LineDown, 0)
         End If
         Function = 0 : Exit Function
      Case %WM_Vscroll
         cprint "wm_vscroll"  'generate en_scroll
         '        Syntax_VisibleLines    '%SB_EndScroll, %SB_LineDown, %SD_LineUp, %SD_PageDown, %SD_PageUp, %SD_ThumbPosition, %SD_ThumbTrack
         '        Function = 0 : Exit Function
 
      Case %WM_NCLButtonDown
         cprint "nclbuttondown"
         Syntax_VisibleLines
   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 Syntax_CurrentLine
   Local pd As CharRange, cf As CharFormat, Oldpd As CharRange, iEventMask&, CurLine&
   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 current line
   CurLine& = SendMessage(hRichEdit, %EM_EXLINEFROMCHAR, 0, -1)               'current line
   pd.cpMin = SendMessage(hRichEdit, %EM_LINEINDEX, CurLine&, 0)                'char at start of current line
   pd.cpMax = pd.cpMin + SendMessage(hRichEdit, %EM_LINELENGTH, pd.cpMin, 0) 'char at end of current line
   SendMessage(hRichEdit, %EM_EXSETSEL, 0, VarPTR(pd))                            'select line
 
   'set current line 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 current line
   ScanLine (CurLine, CurLine)
 
   '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 Syntax_VisibleLines
   Local pd As CharRange, cf As CharFormat, Oldpd As CharRange, iEventMask&
   Local iTopLine&, iBottomLine&
   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 visible lines
   GetTopBottomLines iTopLine&, iBottomLine&
   pd.cpMin = SendMessage(hRichEdit, %EM_LINEINDEX, iTopLine&, 0)               'char at start of iTopLine
   pd.cpMax = SendMessage(hRichEdit, %EM_LINEINDEX, iBottomLine&, 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 (iTopLine&, iBottomLine&+1)
 
   'restore position/eventmask, enable eventmask/redraw
   SendMessage(hRichEdit, %EM_EXSETSEL, 0, VarPTR(Oldpd))           'restore caret position
   SetTopLine(iTopLine&)                                                      'restore visible lines
   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 GetTopBottomLines(iTopLine&, iBottomLine&)
   '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)
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)
   ' 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_00408
'Date: 03-10-2012
 
   '                         GetTopBottomLines(iTopLine&, iBottomLine&)
   '                         SetTopLine(iTopLine&)


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