Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

Convert Source Code to HTML

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • PBWin Convert Source Code to HTML

    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/gbsnippets.pbr
    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 "&lt;" In sText
       Replace ">" With "&gt;" In sText
       Replace $spc With "&nbsp;" 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
    ... correction at 5:05pm: to handle multiple blank lines
    Last edited by Gary Beene; 6 Nov 2009, 05:06 PM.
Working...
X