Original Syntax Highlighter - Borje

Category: Controls - RichEdit

Date: 03-28-2012

Return to Index


 
Plus Jules comments:
 
Borje, this is an excellent example of color syntax highlighting.
As you are aware, if you search the net, anyone using the RichEdit
control has the same problem, and yet no one has yet fixed it
or at least wants to share the fix with us.
 
I have experimented a little using tips from various programming
sites.  The best solution so far is to reduce the overhead while
repainting the client area. I have narrowed it down to just the
line that we are editing on the fly. Eventually I hope to get it
down to just the word.
 
 
Here are the changes:
 
1.
'Added WS_CLIPCHILDREN to the parent window
DIALOG NEW 0, "PB/DDT RichEdit syntax color demo",,, 400, 300, %WS_CLIPCHILDREN OR %WS_SYSMENU TO hDlg
 
2.
'Changed WS_CLIPCHILDREN to WS_CLIPSIBLINGS to the RichEdit window
  CONTROL ADD "RichEdit", hDlg, %ID_RICHEDIT, "", 6, 6, 384, 252, _
              %WS_CHILD  OR %WS_CLIPSIBLINGS OR %WS_VISIBLE OR %ES_MULTILINE OR %WS_VSCROLL OR _
              %WS_HSCROLL OR %ES_AUTOVSCROLL OR %ES_AUTOHSCROLL OR %ES_WANTRETURN, %WS_EX_CLIENTEDGE
 
 
3.
'Moved the ScanLine call to this select case block. (from TextWndProc->WM_KEYUP)
'This way we eliminate scanning if any of the navigation keys are used.
 
                 CASE %EN_CHANGE 'is trigged after..
 
                 Local CurLine As Long
                 CurLine = SendMessage(hEdit, %EM_EXLINEFROMCHAR, 0, -1)
                 CALL ScanLine(CurLine, CurLine)'check current line only
 
 
4.
'Changed line...
  SendMessage hEdit, %WM_SETREDRAW, 0, 0
'To
  SendMessage hEdit, %EM_HIDESELECTION,1,0
 
5.
'and Changed line
  SendMessage hEdit, %WM_SETREDRAW, 1, 0
'To...
  SendMessage hEdit, %EM_HIDESELECTION,0,0
 
6.
'Comment out repainting in the ScanLine routine.
  'InvalidateRect hEdit, ByVal %NULL, 0 : UpdateWindow hEdit
 
'Compilable Example:
' NOTE: corrected for latest RichEdit.inc Feb 17, 2004
'いいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいい
' RichEdit example for PB/DLL 6.0, showing how to create a Richedit
' control and mark all occurrences of search-text with a specific color.
' It also shows you how to use subclassing to get %WM_.. -events and how
' to detect caret position and change-flag. I hope it can be of some use,
' even though it's not at all optimized for any specific purpose..  :-)
'いいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいい
' I actually don't think it can become much faster than this. The part
' that slows it down, is when you select text in order to set the color.
' Maybe it would be possible to stream out the text and use RTF code to
' set colors before you stream it in again, but that's another story..
'
' I compared it to a C++ sample I found, and my code is both faster and
' manages coloring while editing. Edit a word and see what happens.
' It's slow on big texts though, but I've added a timer to enable you
' to experiment and see if you can make it faster.
'
' Oh yes - I've included code to set a red color to text between quotes,
' and it works fine when its used on the whole text, but it does not
' handle editing 100% correct - it fails double quotes..
'
' There's also some flickering that occurs when the Richedit window
' is redrawn after an action. Couldn't find any good solutions to this,
' but maybe someone else knows how to fix it in the Richedit control?
' ----------------------------------------------------------------------
' TIPS: By not using ES_NOHIDESEL when you create the control, all
' actions that involves selecting text becomes faster. Also set the
' event mask to zero before you do repeated stuff and reset it after
' you are done, plus use WM_SETREDRAW on/off for faster action. This
' sample shows all these trix and then some more..
' ----------------------------------------------------------------------
' IMPORTANT NOTICE: Richedit only handles text up to 65,535 bytes in
' Win95/98, but since some of the used EM_ -messages only works up to
' 32,766 bytes, the actual limit here is 32,766 bytes, in Win95/98..
' ----------------------------------------------------------------------
' DISCLAIMER: This is just one example of how it can be done. I normally
' don't use Richedit that much myself, but I know a lot people have been
' asking for this, so here's my solution to it - compile and run..  :-)
'
' By Borje Hagsten, released as Public Domain - May 7, 2000
'いいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいい
 
#Compiler PBWin 9, PBWin 10
#Compile EXE
#Dim All
 
#Include "win32api.inc"    'Some include files
#Include "RICHEDIT.INC"
 
'TYPE CHARFORMAT2          'Special Type for correct format setting
'  cbSize As Long
'  dwMask AS DWord
'  dwEffects AS DWord
'  yHeight As Long
'  yOffset As Long         '0 for superscript, 0 for subscript
'  crTextColor AS DWord
'  bCharSet AS BYTE
'  bPitchAndFamily AS BYTE
'  szFaceName As AsciiZ * %LF_FACESIZE
'  szDummy AS INTEGER      'added as a 2 Byte correction
'END TYPE
 
%IDLABEL      = 100        'Some Id's for the controls
%IDLABELPOS   = 101
%IDLABELTIME  = 102
%IDLABELSIZE  = 103
%IDNOCOL      = 200
%ID_RICHEDIT  = 500
 
Global hEdit   As Long    'A bit easier with this handle as Global
Global OldProc As Long    'For the subclassed edit control
Global cData() As String  'an array to hold all keywords
 
'Declare subs and functions
Declare CallBack Function DlgCallback()
Declare SUB      GetPosText(ByVal hDlg As Long)
Declare Function LoadPBdata(MyArray() As StringAs Long
Declare Function MakeFont(ByVal FontName As String, ByVal PointSize As LongAs Long
Declare SUB      ScanLine(ByVal Line1 As Long, ByVal Line2 As Long)
Declare Function setRichTextColor( ByVal NewColor As LongAs Long
Declare SUB      TurnOffCol(ByVal hDlg As Long)
 
'いいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいい
' Start point - build dialog, controls and set some initial data
' ----------------------------------------------------------------------------
 
Function PBMain
   '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   'Load the Richedit dll.
   '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   IF LoadLibrary("RICHED32.DLL") = 0 THEN
      MSGBOX "Unable to load RICHED32.DLL - sorry, no point in continuing",,"File missing!"
      EXIT Function  'is this correct? At least it seems to terminate properly..
   END IF
 
   '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   'Declare some variables, plus build dialog and controls
   '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   Local txt As String, fDir As String, fFile As String, rText As String
   Local hDlg As Long, hFont As Long, hFile As Long
 
   DIALOG NEW 0, "PB/DDT RichEdit syntax color demo",,, 400, 300, %WS_SYSMENU TO hDlg
   CONTROL ADD BUTTON, hDlg, %IDOK,     "&Set color",  230, 266,  50, 14
   CONTROL ADD BUTTON, hDlg, %IDNOCOL, "&Reset",    285, 266,  50, 14
   CONTROL ADD BUTTON, hDlg, %IDCANCEL, "E&xit",       340, 266,  50, 14
   CONTROL ADD LABEL,  hDlg, %IDLABEL,  "Changed:",     10, 272, 100, 12
   CONTROL ADD LABEL,  hDlg, %IDLABELPOS,  "Position",  10, 260, 100, 12
   CONTROL ADD LABEL,  hDlg, %IDLABELTIME,  "Time elapsed:", 115, 260, 115, 12
   CONTROL ADD LABEL,  hDlg, %IDLABELSIZE,  "Size:",         115, 272, 115, 12
 
   CONTROL ADD "RichEdit", hDlg, %ID_RICHEDIT, "", 6, 6, 384, 252, _
      %WS_CHILD  OR %WS_CLIPCHILDREN OR %WS_VISIBLE OR %ES_MULTILINE OR %WS_VSCROLL OR _
      %WS_HSCROLL OR %ES_AUTOVSCROLL OR %ES_AUTOHSCROLL OR %ES_WANTRETURN, %WS_EX_CLIENTEDGE
 
   CONTROL HANDLE hDlg, %ID_RICHEDIT TO hEdit
 
   '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   'Subclass the Richedit control and set it to use "Courier New", 9 p.
   '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   OldProc = SetWindowLong(hEdit, %GWL_WNDPROC, CODEPTR(TextWndProc))
   hFont   = MakeFont("Courier New", 9)
   SendMessage hEdit, %WM_SETFONT, hFont, 0
 
   '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   'Must set the event mask, so we can pick up a few events from Richedit
   '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   CALL SendMessage(hEdit, %EM_SETEVENTMASK, 0, %ENM_SELCHANGE OR %ENM_CHANGE OR %ENM_UPDATE)
   CALL SendMessage(hEdit, %EM_SETLIMITTEXT, &H100000&, 0) 'make it accept text > 32767 bytes &H100000&
 
   '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   'Try to open some .BAS file. If it fails, create and set some other text
   '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   fDir = CURDIR$ : IF RIGHT$(fDir, 1) <> "\THEN fDir = fDir & "\"
   fFile = DIR$(fDir & "*.bas")
 
   IF LEN(fFile) THEN
      hFile = FREEFILE                         'simple file-to-richedit -routine
      OPEN fFile FOR BINARY AS hFile
      GET$ hFile, LOF(hFile), txt
      CLOSE hFile
      SetWindowText hEdit, ByVal STRPTR(txt)
 
   ELSE                                        'failed, so create a dummy text..
      txt =       "Function PBMain  ' Test for color syntax" & CHR$(10)
      txt = txt & "    DIALOG NEW 0, ""Syntax color"",,, 400, 300, %WS_SYSMENU TO hDlg" & CHR$(10)
      txt = txt & "    CONTROL ADD LABEL, hDlg, id, ""demo"", x, y, xx, yy" & CHR$(10)
      txt = txt & "    DIALOG SHOW MODAL hDlg CALL DlgCallback" & CHR$(10) 'LF - line feed
      txt = txt & "End Function" & CHR$(13, 10) & CHR$(13, 10)             'CRLF - new paragraph
 
      rText = REPEAT$(10, txt)
      CALL SendMessage(hEdit, %WM_SETTEXT, 0, STRPTR(rText))
   END IF
 
   '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   'Pass the array on to another function that will redim and load it with data.
   '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   LoadPBdata cData()
 
   '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   'Enable the following if you want it to start with syntax colored text..
   '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   '  MOUSEPTR 11                  'Scan all lines
   '  CALL  ScanLine(0, SendMessage(hEdit, %EM_GETLINECOUNT, 0, 0) - 1)
   '  MOUSEPTR 0
 
   '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   'Set the modify flag to zero = text not changed
   '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   CALL SendMessage(hEdit, %EM_SETMODIFY, %FALSE, 0)
 
   '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   'Get the initial position data into the labels
   '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   CALL GetPosText(hDlg)
   SetFocus hEdit
 
   '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   ' Show the dialog
   '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   DIALOG SHOW MODAL hDlg CALL DlgCallback
 
   '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   'This point is reached when the program terminates - delete what we have created
   '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   IF hFont THEN DeleteObject hFont
   IF OldProc THEN SetWindowLong hDlg, %GWL_WNDPROC, OldProc
 
End Function
 
   'いいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいい
   ' Main callback procedure for all controls
   ' ----------------------------------------------------------------------------
 
CallBack Function DlgCallback()
   SELECT CASE CBMSG
      CASE %WM_COMMAND
         SELECT CASE CBCTL
            CASE %IDOK                       '<- Set color -button
               Local tTime AS SINGLE : tTime = TIMER 'To see how long it takes
               DIALOG DOEVENTS
               MOUSEPTR 11                   'Scan all lines
               CALL  ScanLine(0, SendMessage(hEdit, %EM_GETLINECOUNT, 0, 0) - 1)
               MOUSEPTR 0
               SetFocus hEdit
 
               CALL GetPosText(CBHNDL)
               CONTROL SET TEXT CBHNDL, %IDLABELTIME, "Time elapsed: " & _
                  FORMAT$(TIMER - tTime, "0.0000") & " seconds."
 
            CASE %IDNOCOL                    '<- Reset -button
               CALL TurnOffCol(CBHNDL)
               SetFocus hEdit
 
            CASE %IDCANCEL                   '<- Exit -button
               DIALOG END CBHNDL             'Exit program
 
            CASE %ID_RICHEDIT                'Some Richedit events, just to
               SELECT CASE HIWRD(CBWPARAM)   'show you where to find them
                  CASE %EN_UPDATE 'is trigged before displaying altered text
 
                  CASE %EN_CHANGE 'is trigged after..
                     'BEEP         'uncomment, to see that it works on changes
               END SELECT
 
         END SELECT
 
      CASE %WM_NOTIFY
         Local nh AS NMHDR PTR
         nh =  CBLPARAM                                'More Richedit events
         IF CBCTL = %ID_RICHEDIT THEN                  'Get caret movement
            IF @nh.code = %EN_SELCHANGE THEN
               CALL GetPosText(CBHNDL)
            END IF
         END IF
   END SELECT
End Function
 
   'いいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいい
   ' Routine to get text and changed-flag status
   ' ----------------------------------------------------------------------------
 
Sub GetPosText(ByVal hDlg As Long)
   Local txt As String, l As Long, pd AS CHARRANGE
 
   l = SendMessage(hEdit, %WM_GETTEXTLENGTH, 0, 0)
   CALL SendMessage(hEdit, %EM_EXGETSEL, 0, VARPTR(pd))
   txt = "Size:" & STR$(l) & " bytes.  (pos: "  & STR$(pd.cpMin) & " )"
   CONTROL SET TEXT hDlg, %IDLABELSIZE, txt
 
   IF pd.cpMin = pd.cpMax THEN  ' nothing selected
      pd.cpMin = SendMessage(hEdit, %EM_EXLINEFROMCHAR, 0, (pd.cpMin)) + 1 'line number
      pd.cpMax = pd.cpMax - SendMessage(hEdit, %EM_LINEINDEX, -1, 0) + 1   'pos. in line
 
      txt = "Line:" + STR$(pd.cpMin) & "   Pos:" & STR$(pd.cpMax)
   ELSE
      txt = "Selected: " & STR$(pd.cpMax - pd.cpMin) & " bytes"
   END IF
 
   CONTROL SET TEXT hDlg, %IDLABELPOS, txt
 
   'Get status - returns %FALSE (0) for not modified, or %TRUE (-1) for modified
   IF SendMessage(hEdit, %EM_GETMODIFY, 0, 0) THEN
      CONTROL SET TEXT hDlg, %IDLABEL, "Modified"
   ELSE
      CONTROL SET TEXT hDlg, %IDLABEL, "Not modified"
   END IF
 
End Sub
 
   'いいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいい
   ' Redim and load a received array with data
   ' ----------------------------------------------------------------------------
 
Function LoadPBdata(dArray() As StringAs Long
   Local I As Long, rc As Long
 
   rc = DATACOUNT
   REDIM dArray(rc - 1) As String 'zero based, so -1
 
   FOR I = 1 TO rc                  'read the data into the array
      dArray(I-1) = UCASE$(READ$(I))
   NEXT
 
   Function = rc  'Return the count, in case we ever should need it..
 
   'PB/DLL 6.0 syntax color data - at least most of it..  :-)
   DATA %DEF#COMPILE#DEBUG#DIM#IF#Include#RESOURCE#OPTION
   DATA #REGISTER#RESOURCE#STACK
   DATA ABSADDADDR, ALL, ANDARRAYASASC, ASCIIZ, ATNATTACH
   DATA BARBEEPBIN$BITBITS?BITS??BITS???BITS%BITS&, BYTE, BUTTON, BYCOPY, BYREF, ByVal
   DATA CALLCALLBACKCASECBCTLCBCTLMSGCBHNDLCBLPARAMCBMSGCBWPARAMCBYTCCUR
   DATA CCUXCDBLCDWDCEILCEXTCHDIRCHDRIVECHECKCHECKBOXCHR$CINT
   DATA CLIENTCLNGCLOSECODEPTRCOMBOBOXCOMMCOMMAND$CONTROLCOSCQUD,
   DATA CSNG, CUR, CUX, CURDIR$CVBYTCVCURCVCUXCVDCVDWDCVECVICVL
   DATA CVQCVSCVWRDCWRD
   DATA DATADATACOUNTDATE$DeclareDECRDEFBYTDEFCURDEFCUXDEFDBL
   DATA DEFDWDDEFEXTDEFINTDEFLNGDEFQUDDEFSNGDEFSTRDEFWRDDELETE
   DATA DIALOGDIMDIR$DISABLEDISKFREEDISKSIZE, DLL, DODOEVENTS, DOUBLE, DRAWDWord
   DATA ELSEENABLEENDENVIRON$EOFEQVERASEERR, ERRAPI, ERRCLEARERROREXEEXIT
   DATA EXPEXP2EXP10EXPLICIT, EXT, EXTRACT$
   DATA FILEATTRFILECOPY, FILENAME, FIXFLUSHFOCUSFORFORMAT$FRAC
   DATA FRAMEFREEFILEFunction
   DATA GETGET$GETATTRGlobalGOSUBGOTOHANDLEHEX$HIBYTHIWRDHOST
   DATA IFIMAGEIMAGEXIMGBUTTONIMGBUTTONXIMPINCRINPUT#
   DATA INSERTINSTRINT, INTEGER, ISFALSEISTRUEITERATEKILL
   DATA LABELLBOUNDLCASE$, LEFT, LENLETLINELISTBOXLOBYT
   DATA LOCLOCALLOCKLOFLOGLOG2LOG10LONGLOOPLOWRDLSETLTRIM$
   DATA MAKDWDMAKLNGMAKPTRMATMAXMENUMID$MINMKBYT$MKCUR$MKCUX$
   DATA MKD$MKDIRMKDWD$MKE$MKI$MKL$MKQ$MKS$MKWRD$MODMODALMODELESS
   DATA MOUSEPTRMSGBOXNAMENEWNEXT, NONE, NOTNOTIFYOCT$ONOPEN,
   DATA OPTIONORPARSE$PARSECOUNTPBMAINPEEKPEEK$PIXELSPOKEPOKE$POPUP
   DATA PRINTPRINT#, PTR, PUTPUT$, QUAD, RANDOMIZE, READ, READ$RECVREDIMREGEXPR
   DATA REGISTERREGREPLREMAIN$REMOVE$REPEAT$REPLACERESETRESUMERETURN
   DATA  RGB, RIGHT , RMDIRRNDROTATEROUNDRSETRTRIM$
   DATA SCANSEEKSELECTSENDSETSETATTRSETEOFSGNSHELLSHIFT
   DATA SHOWSINSINGLESIZESIZEOFSLEEPSORTSPACE$SQRSTATESTATICSTEP
   DATA STR$, STRDELETE, STRINGSTRING$, STRINSERT, STRPTR, STRREVERSE, SUBSWAP
   DATA TALLYTANTCPTEXTTEXTBOXTHENTHREADTIME$TIMERTOTRIM$TYPE
   DATA UBOUND, UCASE, UDPUNIONUNITSUNLOCKVAL
   DATA VARPTRVERIFYWENDWHILE, WIDTH#, WINMAIN, WORD, WRITEWRITE#XOR
 
End Function
 
   'いいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいい
   ' Create a desirable font and return its handle
   ' ----------------------------------------------------------------------------
 
Function MakeFont(ByVal FontName As String, ByVal PointSize As LongAs Long
   Local hDC As Long, CyPixels As Long
 
   hDC = GetDC(%HWND_DESKTOP)
   CyPixels  = GetDeviceCaps(hDC, %LOGPIXELSY)
   ReleaseDC %HWND_DESKTOP, hDC
   PointSize = (PointSize * CyPixels) \ 72
 
   Function = CreateFont(0 - PointSize, 0, 0, 0, %FW_NORMAL, 0, 0, 0, _
      %ANSI_CHARSET, %OUT_TT_PRECIS, %CLIP_DEFAULT_PRECIS, _
      %DEFAULT_QUALITY, %FF_DONTCARE, BYCOPY FontName)
 
End Function
 
   'いいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいい
   ' Syntax color parser for received line numbers
   ' ----------------------------------------------------------------------------
 
Sub ScanLine(ByVal Line1 As Long, ByVal Line2 As Long)
   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
 
   CALL SendMessage(hEdit, %EM_EXGETSEL, 0, VARPTR(Oldpd)) 'Original position
   '(so we can reset it later)
   'Disable the event mask, for better speed
   xEvents = SendMessage(hEdit, %EM_GETEVENTMASK, 0, 0)
   CALL SendMessage(hEdit, %EM_SETEVENTMASK, 0, 0)
 
   'Turn off redraw for faster and smoother action
   CALL SendMessage(hEdit, %WM_SETREDRAW, 0, 0)
 
   IF Line1 <> Line2 THEN                                  'if multiple lines
      MOUSEPTR 11
   ELSE                                                                     'editing a line
      pd.cpMin = SendMessage(hEdit, %EM_LINEINDEX, Line1, 0)                'line start
      pd.cpMax = pd.cpMin + SendMessage(hEdit, %EM_LINELENGTH, pd.cpMin, 0) 'line end
      CALL SendMessage(hEdit, %EM_EXSETSEL, 0, VARPTR(pd))                  'select line
      setRichTextColor &H0                                                  'set black
   END IF
 
   FOR J = Line1 TO Line2
      Aspect = SendMessage(hEdit, %EM_LINEINDEX, J, 0)       'line start
      lnLen  = SendMessage(hEdit, %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(hEdit, %EM_GETTEXTRANGE, 0, ByVal VARPTR(tBuff)) 'Get line
 
         CALL 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
                     CALL SendMessage(hEdit, %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
                  CALL SendMessage(hEdit, %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
                        CALL SendMessage(hEdit, %EM_EXSETSEL, 0, VARPTR(pd))
                        setRichTextColor &H00008000&
                        wFlag = 0
                        EXIT FOR
                     END IF
 
                     ARRAY SCAN cData(0), = xWord, TO Result  'Is it in the array?
                     IF Result THEN
                        pd.cpMin = Aspect + stopPos - 1
                        pd.cpMax = Aspect + I - 1
                        CALL SendMessage(hEdit, %EM_EXSETSEL, 0, VARPTR(pd))
                        CALL 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
   CALL SendMessage(hEdit, %EM_EXSETSEL, 0, VARPTR(Oldpd))
 
   'Turn on Redraw again and refresh - this one causes some flicker in Richedit..
   SendMessage hEdit, %WM_SETREDRAW, 1, 0
   InvalidateRect hEdit, ByVal %NULL, 0 : UpdateWindow hEdit
 
   'Reset the event mask
   IF xEvents THEN CALL SendMessage(hEdit, %EM_SETEVENTMASK, 0, xEvents)
 
End Sub
 
   'いいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいい
   ' setRichTextColor sets the textcolor for selected text in a Richedit control.
   ' Example: CALL setRichTextColor(&HFF) sets the color to red.
   ' &HFF0000 is blue, &H008000 is dark green, &H0 is black, etc..
   ' ----------------------------------------------------------------------------
 
Function setRichTextColor( ByVal NewColor As LongAs Long
   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
 
   CALL SendMessage(hEdit, %EM_SETCHARFORMAT, %SCF_SELECTION, VARPTR(cf))
 
End Function
 
   'いいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいい
   ' TextWndProc - traps %WM_.. -actions in the richtext window
   ' ----------------------------------------------------------------------------
 
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(hEdit, %EM_EXLINEFROMCHAR, 0, -1)
         CALL ScanLine(CurLine, CurLine)               'check current line only
         Function = 0 : EXIT Function                  'return zero
   END SELECT
 
   TextWndProc = CallWindowProc(OldProc, hWnd, wMsg, wParamlParam)
End Function
 
   'いいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいい
   ' Set all text to black - faster this way
   ' ----------------------------------------------------------------------------
 
Sub TurnOffCol(ByVal hDlg As Long)
   Local cf AS CHARFORMAT, pd AS CHARRANGE, Oldpd AS CHARRANGE, xEvent As Long
   Local tTime AS SINGLE : tTime = TIMER                      'get time
 
   xEvent = SendMessage(hEdit, %EM_GETEVENTMASK, 0, 0)         'Get eventmask
   CALL SendMessage(hEdit, %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
   CALL SendMessage(hEdit, %EM_SETCHARFORMAT, -1, VARPTR(cf)) '%SCF_ALL = -1
 
   IF xEvent THEN
      CALL SendMessage(hEdit, %EM_SETEVENTMASK, 0, xEvent)     'Enable eventmask
   END IF                                                     'Arrow
   MOUSEPTR 0
 
   CALL SendMessage(hEdit, %EM_SETMODIFY, %FALSE, 0)          'reset modify flag
   CALL GetPosText(hDlg)                                      'show position
 
   CONTROL SET TEXT hDlg, %IDLABELTIME, "Time elapsed: " & _  'Show elapsed time
      FORMAT$(TIMER - tTime, "0.0000") & " seconds."
 
End Sub
 
'gbs_01069
'Date: 03-10-2012


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