Date: 02-16-2022
Return to Index
created by gbSnippets
'Compilable Example: (Jose Includes)
#Compiler PBWin 10
#Compile Exe "syntax_template.exe"
#Dim All
#Debug Error On
#Debug Display On
%Unicode = 1
#Include "Win32API.inc"
#Resource Manifest, 1, "xptheme.xml"
%IDC_RichEdit = 500
Global hDlg, hRichEdit, hCodeFont, OldREProc As Dword, CodeCase As Long
Global UWords() As String, MWords() As StringZ * 50
Function PBMain() As Long
Dialog Default Font "Tahoma", 12,1
Dialog New Pixels, 0, "Syntax Highlighting Test", , , 300,200, %WS_OverlappedWindow,, To hDlg
Dialog Show Modal hDlg, Call DlgProc
End Function
CallBack Function DlgProc
Local w,h As Long
Select Case Cb.Msg
Case %WM_InitDialog
CodeCase = 3
CreateRichEdit
Control Set Text hDlg, %IDC_RichEdit, "Function PBMain" + $CrLf + " 'test" + $CrLf + " x = ""2""" + $CrLf + "End Function"
synInitializeWords
PostMessage hDlg, %WM_User+500, 0, 0
Case %WM_User+500
synApplySyntax
Case %WM_Size
Dialog Get Client hDlg To w,h
Control Set Loc hDlg, %IDC_RichEdit, 0,0
Control Set Size hDlg, %IDC_RichEdit, w,h
End Select
End Function
Sub CreateRichEdit
' LoadLibrary("msftedit.dll")... fail
' Control Add "RichEdit50W", ... fail
LoadLibrary("riched32.dll")
Control Add "RichEdit", hDlg, %IDC_RichEdit, "", 5, 60, 150, 100, _
%WS_Child Or %WS_Visible Or %ES_MultiLine Or %WS_VScroll Or %ES_AutoHScroll _
Or %WS_TabStop Or %WS_HScroll Or %ES_AutoVScroll Or %ES_WantReturn Or %ES_NoHideSel, %WS_Ex_ClientEdge
Control Handle hDlg, %IDC_RichEdit To hRichEdit
Font New "Courier New",12,1 To hCodeFont
Control Set Font hDlg, %IDC_RichEdit, hCodeFont
OldREProc = SetWindowLong(hRichEdit, %GWL_WndProc, CodePtr(NewREProc))
End Sub
Function NewREProc(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(hRichEdit, %EM_EXLINEFROMCHAR, 0, -1)
ScanLine(CurLine, CurLine) 'check current line only
Function = 0 : Exit Function 'return zero
End Select
NewREProc = CallWindowProc(OldREProc, hWnd, wMsg, wParam, lParam)
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 synInitializeWords
Local temp$, i As Long
ReDim UWords(1000), MWords(1000)
Open Exe.Path$ + "keywords.txt" For Input As #1
While IsFalse Eof(1)
Line Input #1, temp$
If Len(Trim$(temp$)) Then
MWords(i) = temp$ 'has humpback words in it, used for display
UWords(i) = UCase$(temp$) 'UCase is used to compare code against keywords
Incr i
End If
Wend
Close #1
ReDim Preserve UWords(i-1), MWords(i-1)
End Sub
Function setRichTextColor( ByVal NewColor As Long) As 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
Local tTime As Single : tTime = Timer 'get time
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
End If 'Arrow
MousePtr 0
SendMessage(hRichEdit, %EM_SETMODIFY, %FALSE, 0) 'reset modify flag
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, Buf As String
Local Aspect, xEvents, i, j, stopPos, lnLen, Result As Long
Local 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
Buf = UCase$(Buf)
'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 = "REM" Then '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))
Control Send hDlg, %IDC_RichEdit, %EM_ReplaceSel, %True, VarPtr(MWords(Result-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
'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
http://www.garybeene.com/sw/gbsnippets.htm