Tweet
In gbSnippets I provide the capability of exporting source code to HTML by
drawing on a 3rd party conversion tool - irun.dll. It's very capable, but also
has some limitations which I cannot fix. So I decided to work out a solution
of my own - the snippet posted below.
The solution is a variation on the same code that is used to provide syntax
highlighting within a RichEdit control - but does not require the use of a
RichEdit or any other character formatting control. RTF content is not used
in the solution. Just give the procedure plain text source code and it will
create formatted HTML for you.
The code is provided below, and is also available in the
gbSnippets PowerBASIC source code library (snippet# gbs_00405).
You can get the entire library by downloading gbSnippets or you
can view individual snippets online.
gbSnippets home page: http://www.garybeene.com/sw/gbsnippets.htm
Online source code listings: http://www.garybeene.com/power/code/
If you've already installed gbSnippets, you can ensure that your local
library is synchronized with the latest snippets on the gbSnippets server
by using the "Actions/Synchronize with gbSnippets Server" menu.
There are two files needed for this snippet. Just please these in the
folder where the EXE is compiled. Both of these are included in the
gbSnippets distribution.
http://www.garybeene.com/files/powerbasic.syn (right-click to download)
Even though the solution does not require a RichEdit control, this
example includes syntax highlighting of the source code so you can
compare it to the output. In this example, the output is placed in
in a file called export.htm.
This approach does not handle TAB characters within the source
code, although you should be able to use earlier code I posted on
replacing TAB with variable numbers of spaces to achieve reasonable
(but not perfect) positioning when TAB use is required.
Finally, this solution uses the deprecated HTML <font> tag. I'll
eventually update it to use CSS methods, but it should work fine
as is with any browser available today.
... correction at 5:05pm: to handle multiple blank lines
drawing on a 3rd party conversion tool - irun.dll. It's very capable, but also
has some limitations which I cannot fix. So I decided to work out a solution
of my own - the snippet posted below.
The solution is a variation on the same code that is used to provide syntax
highlighting within a RichEdit control - but does not require the use of a
RichEdit or any other character formatting control. RTF content is not used
in the solution. Just give the procedure plain text source code and it will
create formatted HTML for you.
The code is provided below, and is also available in the
gbSnippets PowerBASIC source code library (snippet# gbs_00405).
You can get the entire library by downloading gbSnippets or you
can view individual snippets online.
gbSnippets home page: http://www.garybeene.com/sw/gbsnippets.htm
Online source code listings: http://www.garybeene.com/power/code/
If you've already installed gbSnippets, you can ensure that your local
library is synchronized with the latest snippets on the gbSnippets server
by using the "Actions/Synchronize with gbSnippets Server" menu.
There are two files needed for this snippet. Just please these in the
folder where the EXE is compiled. Both of these are included in the
gbSnippets distribution.
http://www.garybeene.com/files/powerbasic.syn (right-click to download)
Even though the solution does not require a RichEdit control, this
example includes syntax highlighting of the source code so you can
compare it to the output. In this example, the output is placed in
in a file called export.htm.
This approach does not handle TAB characters within the source
code, although you should be able to use earlier code I posted on
replacing TAB with variable numbers of spaces to achieve reasonable
(but not perfect) positioning when TAB use is required.
Finally, this solution uses the deprecated HTML <font> tag. I'll
eventually update it to use CSS methods, but it should work fine
as is with any browser available today.
Code:
Export To HTML
'Compilable Example:
#Compile Exe
#Dim All
#Include "Win32api.inc"
#Include "commctrl.inc"
#Include "richedit.inc"
%IDC_RichEdit = 500
Global LWords() As String, UWords() As String, MWords() As String
Global hRichEdit As DWord, hDlg As DWord, OrigRichEditProc&, CodeCase&
Function PBMain() As Long
'create some sample content for the RichEdit control
Dim Content$
Content$ = "Function Example" + $CrLf + "Select Case MyVar" + $CrLf + "Case 12 '1st case" + $CrLf + "End " + Chr$(34) + "the <> the" + Chr$(34) + " Select" + $CrLf + "End 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
OrigRichEditProc& = SetWindowLong(GetDlgItem(hDlg, %IDC_RichEdit), %GWL_WndProc, CodePTR(TextWndProc))
SendMessage hRichEdit, %EM_SETEVENTMASK, 0, %ENM_SELCHANGE Or %ENM_CHANGE
Dialog Show Modal hDlg Call DlgProc
End Function
CallBack Function DlgProc() As Long
Select Case CB.Msg
Case %WM_InitDialog
CodeCase& = 3
Control Set Option hDlg, 203, 201, 203
synInitializeRWords
synApplySyntax
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 : synApplySyntax
Case 202 : CodeCase& = 2 : synApplySyntax
Case 203 : CodeCase& = 3 : synApplySyntax
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' size=-1><b>"
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
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(hRichEdit, %EM_EXLINEFROMCHAR, 0, -1)
ScanLine(CurLine, CurLine) 'check current line only
Function = 0 : Exit Function 'return zero
End Select
TextWndProc = CallWindowProc(OrigRichEditProc&, hWnd, wMsg, wParam, lParam)
End Function
Sub synApplySyntax()
MousePTR 11 'Scan all lines
TurnOffCol(hDlg)
ScanLine(0, SendMessage(hRichEdit, %EM_GETLINECOUNT, 0, 0) - 1)
MousePTR 0
SetFocus hRichEdit
End Sub
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
' 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(ByVal hDlg As Long)
' 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 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
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
'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
'---------------------------------upper/lower/mixed handled here-----------
SendMessage(hRichEdit, %EM_EXSETSEL, 0, VarPTR(pd))
xWord = Choose$(CodeCase&, UWords(Result-1), LWords(Result-1), MWords(Result-1))
Control Send hDlg, %IDC_RichEdit, %EM_ReplaceSel, %True, StrPTR(xWord)
'----------------------------------------------------------------------
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
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
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
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 "<" With "<" In sText
Replace ">" With ">" In sText
Replace $spc 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
'gbs_00405
