Date: 02-16-2022
Return to Index
created by gbSnippets
'... 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: (Jose Includes)
#Compiler PBWin 10
#Compile EXE
#Dim All
%Unicode=1
#Include "win32api.inc"
#Include "richedit.inc"
Declare Function WinMsg Lib "WINMSG.DLL" Alias "WindowMessageA" (ByVal MsgNum As Long) As 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 Long) As 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, wParam, lParam)
End Function
Sub synInitializeRWords
Local temp$, i As Long
ReDim UWords(1000), LWords(1000), MWords(1000)
Open Exe.Path$ + "powerbasic.syn" For 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 Long) As 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 = "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))
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
http://www.garybeene.com/sw/gbsnippets.htm