Date: 02-16-2022
Return to Index
created by gbSnippets
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: (Jose Includes)
' 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
%Unicode=1
#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 String) As Long
Declare Function MakeFont(ByVal FontName As String, ByVal PointSize As Long) As Long
Declare SUB ScanLine(ByVal Line1 As Long, ByVal Line2 As Long)
Declare Function setRichTextColor( ByVal NewColor As Long) As 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 String) As 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 ABS, ADD, ADDR, ALL, AND, ARRAY, AS, ASC, ASCIIZ, ATN, ATTACH
DATA BAR, BEEP, BIN$, BIT, BITS?, BITS??, BITS???, BITS%, BITS&, BYTE, BUTTON, BYCOPY, BYREF, ByVal
DATA CALL, CALLBACK, CASE, CBCTL, CBCTLMSG, CBHNDL, CBLPARAM, CBMSG, CBWPARAM, CBYT, CCUR
DATA CCUX, CDBL, CDWD, CEIL, CEXT, CHDIR, CHDRIVE, CHECK, CHECKBOX, CHR$, CINT
DATA CLIENT, CLNG, CLOSE, CODEPTR, COMBOBOX, COMM, COMMAND$, CONTROL, COS, CQUD,
DATA CSNG, CUR, CUX, CURDIR$, CVBYT, CVCUR, CVCUX, CVD, CVDWD, CVE, CVI, CVL
DATA CVQ, CVS, CVWRD, CWRD
DATA DATA, DATACOUNT, DATE$, Declare, DECR, DEFBYT, DEFCUR, DEFCUX, DEFDBL
DATA DEFDWD, DEFEXT, DEFINT, DEFLNG, DEFQUD, DEFSNG, DEFSTR, DEFWRD, DELETE
DATA DIALOG, DIM, DIR$, DISABLE, DISKFREE, DISKSIZE, DLL, DO, DOEVENTS, DOUBLE, DRAW, DWord
DATA ELSE, ENABLE, END, ENVIRON$, EOF, EQV, ERASE, ERR, ERRAPI, ERRCLEAR, ERROR, EXE, EXIT
DATA EXP, EXP2, EXP10, EXPLICIT, EXT, EXTRACT$
DATA FILEATTR, FILECOPY, FILENAME, FIX, FLUSH, FOCUS, FOR, FORMAT$, FRAC
DATA FRAME, FREEFILE, Function
DATA GET, GET$, GETATTR, Global, GOSUB, GOTO, HANDLE, HEX$, HIBYT, HIWRD, HOST
DATA IF, IMAGE, IMAGEX, IMGBUTTON, IMGBUTTONX, IMP, INCR, INPUT#
DATA INSERT, INSTR, INT, INTEGER, ISFALSE, ISTRUE, ITERATE, KILL
DATA LABEL, LBOUND, LCASE$, LEFT, LEN, LET, LINE, LISTBOX, LOBYT
DATA LOC, LOCAL, LOCK, LOF, LOG, LOG2, LOG10, LONG, LOOP, LOWRD, LSET, LTRIM$
DATA MAKDWD, MAKLNG, MAKPTR, MAT, MAX, MENU, MID$, MIN, MKBYT$, MKCUR$, MKCUX$
DATA MKD$, MKDIR, MKDWD$, MKE$, MKI$, MKL$, MKQ$, MKS$, MKWRD$, MOD, MODAL, MODELESS
DATA MOUSEPTR, MSGBOX, NAME, NEW, NEXT, NONE, NOT, NOTIFY, OCT$, ON, OPEN,
DATA OPTION, OR, PARSE$, PARSECOUNT, PBMAIN, PEEK, PEEK$, PIXELS, POKE, POKE$, POPUP
DATA PRINT, PRINT#, PTR, PUT, PUT$, QUAD, RANDOMIZE, READ, READ$, RECV, REDIM, REGEXPR
DATA REGISTER, REGREPL, REMAIN$, REMOVE$, REPEAT$, REPLACE, RESET, RESUME, RETURN
DATA RGB, RIGHT , RMDIR, RND, ROTATE, ROUND, RSET, RTRIM$
DATA SCAN, SEEK, SELECT, SEND, SET, SETATTR, SETEOF, SGN, SHELL, SHIFT
DATA SHOW, SIN, SINGLE, SIZE, SIZEOF, SLEEP, SORT, SPACE$, SQR, STATE, STATIC, STEP
DATA STR$, STRDELETE, STRING, STRING$, STRINSERT, STRPTR, STRREVERSE, SUB, SWAP
DATA TALLY, TAN, TCP, TEXT, TEXTBOX, THEN, THREAD, TIME$, TIMER, TO, TRIM$, TYPE
DATA UBOUND, UCASE, UDP, UNION, UNITS, UNLOCK, VAL
DATA VARPTR, VERIFY, WEND, WHILE, WIDTH#, WINMAIN, WORD, WRITE, WRITE#, XOR
End Function
'�����������������������������������������������������������������������������
' Create a desirable font and return its handle
' ----------------------------------------------------------------------------
Function MakeFont(ByVal FontName As String, ByVal PointSize As Long) As 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 = "REM" THEN '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 Long) As 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 Long) As 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, wParam, lParam)
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
http://www.garybeene.com/sw/gbsnippets.htm