Date: 02-16-2022
Return to Index
created by gbSnippets
'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"
%IDC_RichEdit = 500
Global LWords() As String, UWords() As String, MWords() As String
Global hRichEdit As DWord, hDlg As DWord, CodeCase&
Global TabLoc() As Single, hDc as DWord, hFont as DWord
Function PBMain() As Long
'create some sample content for the RichEdit control
Dim Content$, i As Long
Content$ = "Function " + $tab + $tab + "Example" + $CrLf + "Select Case MyVar" + $CrLf + "Case 12 '1st Case" + _
$CrLf + "End " + Chr$(34) + "the <> the" + Chr$(34) + " Select" + $CrLf + "End " + $tab + $tab + $tab + "Function"
Content$ = Content$ + $CrLf + "'For i = 1 to 10" + $CrLf + "Incr i" + $CrLf + "Next i"
Content$ = Content$ + $CrLf + "If x <> 2 Then" + $CrLf + Chr$(34) + "nothing" + Chr$(34) + $CrLf + "End If"
Dialog New Pixels, 0, "Syntax Test",300,300,350,400, %WS_OverlappedWindow To hDlg
'create RichEdit and subclass (to intercept %WM_KeyUp actions)
LoadLibrary("riched32.dll")
InitCommonControls
Control Add Option, hDlg, 201, "Upper", 10, 10, 50, 20
Control Add Option, hDlg, 202, "Lower", 90, 10, 50, 20
Control Add Option, hDlg, 203, "Mixed", 170, 10, 50, 20
Control Add Button, hDlg, 204, "Export", 250, 10, 50, 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
SetFont
SendMessage hRichEdit, %EM_SETEVENTMASK, 0, %ENM_SELCHANGE Or %ENM_CHANGE
'initialization
hDC = GetDC(hRichEdit)
hFont = SendMessage (hRichEdit, %WM_GETFONT, 0, 0)
SelectObject hDc, hFont
ReDim TabLoc(50)
For i = 0 To 50 : TAbLoc(i) = i * 0.5 : Next i '0.5" tab locations
Dialog Show Modal hDlg Call DlgProc
ReleaseDC hRichEdit, hDC
End Function
CallBack Function DlgProc() As Long
Select Case CB.Msg
Case %WM_InitDialog
CodeCase& = 3
Control Set Option hDlg, 203, 201, 203
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-20
Case %WM_Command
Select Case CB.Ctl
Case 201 : CodeCase& = 1
Case 202 : CodeCase& = 2
Case 203 : CodeCase& = 3
Case 204
If CB.Ctlmsg = %BN_Clicked Then
Local fNumber&
fNumber& = FreeFile
Open Exe.path$ + "Export.htm" For Output as fNumber&
Print # fNumber&, " <html><body><font face='Comic Sans MS' "
ExportToHTML (0, SendMessage(hRichEdit, %EM_GETLINECOUNT, 0, 0) - 1, fNumber&)
Print # fNumber&, "</font></body></html>"
Close # fNumber&
End If
End Select
End Select
End Function
Sub synInitializeRWords
Local temp$, i As Long, LineCumText$
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
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 ExportToHTML(ByVal Line1 As Long, ByVal Line2 As Long, fNumber&)
' Syntax color parser for received line numbers
Local pd As CHARRANGE, Oldpd As CHARRANGE, tBuff As TEXTRANGE
Local xWord As String, Buf As String, Buf_orig As String, temp$
Local x as Single, y as Single, tPos as Single, sWidth as Single, sCount as Long
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
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
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Expand TABs
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
temp$ = ConvertTabToSpace(buf)
buf = temp$ + Chr$(0)
Buf_orig = Buf 'keep the original case for later use
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 -> "
PrintX Chr$(34), "" , fNumber&
stopPos = Instr(I + 1, Buf, Chr$(34)) 'Find match
If stopPos Then
PrintX Mid$(Buf_Orig, I+1, stopPos - I - 1 ), "red", fNumber&
PrintX Chr$(34), "", fNumber&
StopPos = (StopPos - I) ' + 1)
I = I + StopPos
Letter = Letter + StopPos
wFlag = 0
End If
Case 39 ' comment character -> '
PrintX Mid$(Buf_Orig, I, lnLen - I +1 ), "darkgreen", fNumber&
wFlag = 0
Exit For
Case Else 'word is ready 32, 33, 40 to 47, 58 to 62, 64, 91 to 94, 96, 123 to 128
If wFlag = 1 Then
xWord = Mid$(Buf, stopPos, I - stopPos) 'Get word
If xWord = "REM" Then 'extra for the uncomment word, REM
PrintX XWord, "darkgreen", fNumber&
wFlag = 0
Exit For
End If
Array Scan UWords(0), = xWord, To Result 'Is it in the array?
If Result Then
xWord = Choose$(CodeCase&, UWords(Result-1), LWords(Result-1), MWords(Result-1))
PrintX xWord, "blue", fNumber&
Else
xWord = Mid$(Buf_Orig, stopPos, I - stopPos) 'Get original capitalization of the word
PrintX xWord, "", fNumber&
End If
wFlag = 0
End If
If Mid$(Buf,I,1) <> Chr$(0) Then PrintX Mid$(Buf,I,1), "", fNumber&
End Select
Incr Letter
Next I
Else
PrintX $Spc, "", fNumber&
End If
Print # fNumber&, "<br>"
Next J
End Sub
Sub PrintX(sText As String, sColor as String, fNumber&)
Replace $spc With " " in sText
Replace "<" With "<" In sText
Replace ">" With ">" In sText
If sColor = "" Then
Print # fNumber&, sText ; 'default text color
Else
Print # fNumber&, "<font color=" + sColor + ">" + sText + "</font>" ; 'syntax highlighting color
End If
End Sub
Function ConvertTABtoSpace(ByVal text$) As String
'build string one space at a time until length reaches TAB stops
Local i As Long, j As Long, temp$, iSpaces&, iSpaceWidth!, result$
Local tempWidth!, ncWidth!, ncHeight!, iTab&, R as Rect
Text$ = Trim$(Text$, Chr$(0) )
temp$ = ""
For i = 1 To ParseCount(text$, $Tab)
temp$ = temp$ + Parse$(text$,$Tab, i)
DrawTextEx hDC, ByVal StrPTR(temp$), Len(temp$), R, %DT_CalcRect, ByVal 0
tempWidth! = (R.nright - R.nleft)/GetDeviceCaps(hdc, %LOGPIXELSX)
iTab& = Fix(tempWidth!/0.5)+1 'next location tab after current endpoint
Do
temp$ = temp$ + " "
DrawTextEx hDC, ByVal StrPTR(temp$), Len(temp$), R, %DT_CalcRect, ByVal 0
tempWidth! = (R.nright - R.nleft)/GetDeviceCaps(hdc, %LOGPIXELSX)
Loop While tempWidth! < TabLoc(iTab&)
Next i
Function = temp$
End Function
'gbs_00406
'Date: 03-10-2012
http://www.garybeene.com/sw/gbsnippets.htm