Export to HTML (w/TAB Expansion)

Category: Controls - RichEdit

Date: 03-28-2012

Return to Index


 
'Compiler Comments:
'This code is written to compile with PBWin10. To compile with PBWin9,
'add this line:
#Include "CommCtrl.inc"
 
'Compilable Example:
#Compiler PBWin 10
#Compile EXE
#Dim All
#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.htmFor 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.synFor 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 = "REMThen  '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


created by gbSnippets
http://www.garybeene.com/sw/gbsnippets.htm