| |
'
' Build an HTML table representing source code.
'
Private Function RTFtoHTML(ByVal sSourceText As String) As String
Dim lLenText As Long, lStart As Long, lTime As Long
Dim sBg_color As String, iCount As Integer, sCaption As String, lProg As Long
Dim sTxt As String, iPos As Integer, sNextLine As String, lProgress As Long
Dim aKeywords 'As Variant, is actually what it is.
'' Dim aKeywords() 'Regular array, we don't need it.
Dim WordObj As Word.Application, bIsCreatedObject As Boolean
Dim lStartTitle As Long ', lEndTitle As Long
'OK, but this isn't code, it's text so just use the first sentence (to first ",")
gsFancyTitle = "[My Page Title Here]"
'OK, but'gives RTF junk strings too so see below for solution
' gsFancyTitle = Left(sSourceText, InStr(sSourceText, ".") - 1)
' gsFancyTitle = Left(gsFancyTitle, InStr(gsFancyTitle, ",") - 1)
sCaption = " Processing 60K per minute, please wait. "
If Len(sSourceText) < 20 Then
MsgBox "Exiting, clipboard was empty, or tiny."
Exit Function
End If
On Error GoTo cmdOK_Error
Me.Caption = "Using current Word window as our RTF converter..."
Set WordObj = GetObject(, "Word.Application.8")
GoTo Continue
WordNotRunning:
Me.Caption = "Starting Word as our RTF converter..."
' Set WordObj = CreateObject("Word.Basic")
' Set WordObj = CreateObject("Word.Application")
Set WordObj = CreateObject("Word.Application.8")
'- Word will start without any toolbars or menus unless these are reversed.
With WordObj
.Visible = False
.Application.Visible = False
.WindowState = wdWindowStateMinimize 'or wdWindowStateMaximize
' WordObj.Visible = True
'- This might speed up the compiled version enough to avoid the .Open error
.Application.ScreenUpdating = False
End With
bIsCreatedObject = True '- Flag indicates a created session we can close later.
DoEvents
Continue:
DoEvents
'KEEP ????????
gsFancyTitle = Left(Clipboard.GetText(vbCFText), 100) 'default (vbCFRTF)
' WordObj.FileOpen "C:\Winword\Test.Doc"
' WordObj.Documents.Open "C:\Winword\Test.Doc"
' WB.FileOpen filList.List(filList.ListIndex) & "\" & dirList.List(dirList.ListIndex)
' WordObj.Documents.Open dirList.List(dirList.ListIndex) & "\" & filList.List(filList.ListIndex)
' WordObj.Application.Run MacroName:="HTML.HTMLView.DocClose"
'OK, but make OLE for ordinary users.
' WordObj.Application.Run MacroName:="NormHome.NewMacros.SaveAs_RTF_from_Clipboard"
OLE_SaveAs_RTF_from_Clipboard WordObj
lLenText = Len(sSourceText)
' lLenText/1000 = Ks
' lLenText = (lLenText / 1000) / 61.38 * 60 '= seconds
lLenText = (lLenText / 1000) / 60 * 60 '= seconds rounding up
' lLenText = Ks
'245/168 169/2.75
'Print 169 / 2.75
' 61.4545454545455
'Print Len(txtSource.Text)
'168806
'Print 168.806 / 2.75
' 61.384 k/minute
'- Put in the HTML, BODY and HEAD tags (not absolutely required, but nice to have around.
'OK, but put in the <TITLE> tag too :)
' sTxt = "<HTML>" & vbCrLf & " <BODY>" & vbCrLf & " <HEAD> </HEAD>" & vbCrLf & vbCrLf 'was ""
'no
' sTxt = "<HTML>" & vbCrLf & " <BODY>" & vbCrLf & " <HEAD>" & vbCrLf
sTxt = "<HTML>" & vbCrLf & " <HEAD>" & vbCrLf
sTxt = sTxt & " <TITLE></TITLE>" & vbCrLf
sTxt = sTxt & " </HEAD>" & vbCrLf & "<BODY>" & vbCrLf 'was ""
' Print Hex$(picColor(iSelectedColor).BackColor)
'7 = FFC0FF
'6 = FFC0C0
'5 = FFFFA6
'4 = C0FFC0
'3 = C0FFFF
'2 = EEEEEE
'1 = FFFFFF
'0 = 8000000 F
'- Compute the selected color.
If iSelectedColor = 0 Then
sBg_color = ""
ElseIf iSelectedColor = 2 Then '- klugie to get it to an HTML color
sBg_color = "EEEEEE" '- light gray
ElseIf iSelectedColor = 3 Then
sBg_color = "FFFFA6" '"FFFFC4" '- light yellow 'the default "C0FFFF" is turquoise
ElseIf iSelectedColor = 4 Then
sBg_color = "95FFCA" 'brighter light green
ElseIf iSelectedColor = 5 Then
sBg_color = "C4FFFF" '"FFFFC0" '- very light cyan
ElseIf iSelectedColor = 6 Then
sBg_color = "B7B7FF" 'nice baby blue
ElseIf iSelectedColor = 7 Then
sBg_color = "FFC0C0" 'pink
Else
sBg_color = Hex(picColor(iSelectedColor).BackColor)
End If
'- Compute the selected comment color.
If iSelectedCommentColor = 0 Then
sFg_comment_color = ""
Else
sFg_comment_color = Hex(picCommentColor(iSelectedCommentColor).BackColor)
'- Kluge cause I can't get the background color of the VB form pic boxes to match the HTML code, can u?
' cool, then send me an email: Gries@Robert.org
Select Case sFg_comment_color
Case "800000"
sFg_comment_color = "000080" '- Navy blue
Case "4000"
sFg_comment_color = "008000" '- Dark Green
Case "80"
sFg_comment_color = "800000" '- Maroon
Case Else
sFg_comment_color = "000000" '- Black
End Select
End If
'- If the background color is not blank, use a table.
If Len(sBg_color) > 0 Then
'3/7 ok
' If sBg_color <> "Fancier_Frames" Then '#FFFFFF
If picFancyFrame.BorderStyle = vbBSNone Then
'OK
'- Start the table.
sTxt = sTxt & "<TABLE BORDER=1 CELLSPACING=0 CELLPADDING=2 BGCOLOR=#" & sBg_color & ">" & vbCrLf
sTxt = sTxt & "<TR><TD>" & vbCrLf
Else '- Fancy table.
' gsFancyTitle = Clipboard.GetText(vbCFText) 'default (vbCFRTF)
'- Now sTxt has all the RTF junk codes converted to HTML codes, so we can get the proposed
' string for the <TITLE> tag and the Page Caption Title text
' Dim lStartTitle As Long, lEndTitle As Long
' InStrNum(sBigString As String, sSearchString As String, iOccurance As Integer
' lStartTitle = InStrNum(gsFancyTitle, "P>", 2) + 2
lStartTitle = InStr(gsFancyTitle, ",") - 1
If lStartTitle = 0 Then
lStartTitle = InStr(gsFancyTitle, ".") - 1
End If
' lEndTitle = Left(sTxt, InStr(lStartTitle, gsFancyTitle, "<") - 1)
On Error Resume Next
' gsFancyTitle = Left(gsFancyTitle, InStr(gsFancyTitle, ",") - 1) 'gives RTF junk strings too, tho
gsFancyTitle = Left(gsFancyTitle, lStartTitle)
'It isn't HTML, now it's text, so use above line
' gsFancyTitle = Mid(gsFancyTitle, lStartTitle, lEndTitle - lStartTitle) 'gives RTF junk strings too, tho
On Error GoTo cmdOK_Error 'revert to the original error handler
gsFancyTitle = InputBox("Enter Page Caption (empty for blank)", "Fancy Page", gsFancyTitle)
DoEvents
Screen.MousePointer = vbHourglass
sTxt = sTxt & "<table border=0 width=100% align=center cellspacing=0 cellpadding=10>" & vbCrLf
sTxt = sTxt & "<tr>" & vbCrLf
sTxt = sTxt & "<td width=30 bgcolor=#003366> </td>" & vbCrLf
sTxt = sTxt & " <td bgcolor=#003366><font size=4 color=#FFFFFF face=Arial, Helvetica, sans-serif>"
sTxt = sTxt & gsFancyTitle & "</font></td> " & vbCrLf
sTxt = sTxt & "</tr>" & vbCrLf
sTxt = sTxt & "<tr>" & vbCrLf
sTxt = sTxt & "<td width=30 bgcolor=#cccccc> </td>" & vbCrLf
' sTxt = sTxt & "<td bgcolor=#FFFFFF>" & vbCrLf 'default
sTxt = sTxt & "<td bgcolor=#" & sBg_color & ">" & vbCrLf
sTxt = sTxt & "<p><font face=Arial, Helvetica, sans-serif size=3>" & vbCrLf
End If '- chose Fancy Format, or regular table.
Else ' (don't do a no frames page because they clicked the fancy page button, too
'- Overide with the non-fancy page background color with
' the default background color for a fancy page.
sBg_color = "FFFFFF" '#FFFFFF
'3/7 ok
' If sBg_color <> "Fancier_Frames" Then '#FFFFFF
If picFancyFrame.BorderStyle = vbBSNone Then
'- Do nothing.
Else
'NEW
gsFancyTitle = Clipboard.GetText(vbCFText) 'default (vbCFRTF)
'- Now sTxt has all the RTF junk codes converted to HTML codes, so we can get the proposed
' string for the <TITLE> tag and the Page Caption Title text
' Dim lStartTitle As Long, lEndTitle As Long
' InStrNum(sBigString As String, sSearchString As String, iOccurance As Integer
' lStartTitle = InStrNum(gsFancyTitle, "P>", 2) + 2
lStartTitle = InStr(gsFancyTitle, ",") - 1
If lStartTitle = 0 Then
lStartTitle = InStr(gsFancyTitle, ".") - 1
End If
' lEndTitle = Left(sTxt, InStr(lStartTitle, gsFancyTitle, "<") - 1)
On Error Resume Next
' gsFancyTitle = Left(gsFancyTitle, InStr(gsFancyTitle, ",") - 1) 'gives RTF junk strings too, tho
gsFancyTitle = Left(gsFancyTitle, lStartTitle)
'It isn't HTML, now it's text, so use above line
' gsFancyTitle = Mid(gsFancyTitle, lStartTitle, lEndTitle - lStartTitle) 'gives RTF junk strings too, tho
On Error GoTo cmdOK_Error 'revert to the original error handler
gsFancyTitle = InputBox("Enter Page Caption (empty for blank)", "Fancy Page", gsFancyTitle)
DoEvents
Screen.MousePointer = vbHourglass
sTxt = sTxt & "<table border=0 width=100% align=center cellspacing=0 cellpadding=10>" & vbCrLf
sTxt = sTxt & "<tr>" & vbCrLf
sTxt = sTxt & "<td width=30 bgcolor=#003366> </td>" & vbCrLf
sTxt = sTxt & " <td bgcolor=#003366><font size=4 color=#FFFFFF face=Arial, Helvetica, sans-serif>"
sTxt = sTxt & gsFancyTitle & "</font></td> " & vbCrLf
sTxt = sTxt & "</tr>" & vbCrLf
sTxt = sTxt & "<tr>" & vbCrLf
sTxt = sTxt & "<td width=30 bgcolor=#cccccc> </td>" & vbCrLf
sTxt = sTxt & "<td bgcolor=#" & sBg_color & ">" & vbCrLf
sTxt = sTxt & "<p><font face=Arial, Helvetica, sans-serif size=3>" & vbCrLf
End If
End If '- "Use a table? or use Fancy table default color"
'- Start TT PRE.
' sTxt = sTxt & "<TT><PRE>"
lStart = Timer
DoEvents
'get the body HTML text only format that Word has put there
sTxt = sTxt & Clipboard.GetText(vbCFText) 'default (vbCFRTF)
''- Now sTxt has all the RTF junk codes converted to HTML codes, so we can get the proposed
'' string for the <TITLE> tag and the Page Caption Title text
' Dim lStartTitle As Long, lEndTitle As Long
'
'' InStrNum(sBigString As String, sSearchString As String, iOccurance As Integer
'
' lStartTitle = InStrNum(sTxt, "p>", 2) + 2
'
' lEndTitle = Left(sTxt, InStr(lStartTitle, sTxt, "<") - 1)
'
'' gsFancyTitle = Left(gsFancyTitle, InStr(gsFancyTitle, ",") - 1) 'gives RTF junk strings too, tho
' gsFancyTitle = Mid(sTxt, lStartTitle, lEndTitle - lStartTitle) 'gives RTF junk strings too, tho
'- Remove the final vbCrLf and end PRE TT.
' sTxt = Left(sTxt, Len(sTxt) - Len(vbCrLf))
' sTxt = sTxt & "</PRE></TT>" & vbCrLf ' Might need a </p> here
sTxt = sTxt & "<br>" & vbCrLf ' Might need a </p> here
'--------------------------------------------------
'- If the background color is not blank, finish the table.
If Len(sBg_color) > 0 Then
sTxt = sTxt & "</TD></TR>" & vbCrLf
sTxt = sTxt & "</TABLE>" & vbCrLf
End If
'3/7 OK
' If sBg_color = "Fancier_Frames" Then '#FFFFFF
If picFancyFrame.BorderStyle = vbBSNone Then
'- Do nothing.
Else
sTxt = sTxt & "</td>" & vbCrLf
sTxt = sTxt & " </tr>" & vbCrLf
sTxt = sTxt & " <tr>" & vbCrLf
sTxt = sTxt & " <td width=30 bgcolor=#CCCCCC> </td>" & vbCrLf
sTxt = sTxt & " <td bgcolor=#CCCCCC align=right valign=middle></td>" & vbCrLf
sTxt = sTxt & " </tr>" & vbCrLf
sTxt = sTxt & "</table>" & vbCrLf
End If
'OK
sTxt = sTxt & vbCrLf & " </BODY>" & vbCrLf & "</HTML>"
' RTFtoHTML = sTxt
'- Stick in the Title of the page for browser caption, same as Page title we just asked the user for.
RTFtoHTML = ReplaceString(sTxt, "<TITLE></TITLE>", "<TITLE>" & gsFancyTitle & "</TITLE>")
bRunning = False
cmdConvert.Caption = "&Convert to HTML"
TryAgain:
' Set WordObj = Nothing
'' AppActivate "Microsoft Word"
If bIsCreatedObject Then
Me.Caption = "Closing Word..."
With WordObj
' .Application.ScreenUpdating = False
.Documents.Add
.Selection.TypeText sFirstSentence 'Left(Clipboard.GetText(vbCFText), 50) '"smallclipboard"
.Selection.WholeStory
.Selection.Copy
.ActiveDocument.Saved = True
.ActiveDocument.Close Savechanges:=False
.DisplayAlerts = wdAlertsNone '- Word won't prompt for large clipboard
.Quit
End With
Else '- Word was already running, so we just used that instance.
With WordObj
' .Application.ScreenUpdating = False
.Documents.Add
.Selection.TypeText sFirstSentence '"smallclipboard"
.Selection.WholeStory
.Selection.Copy
.ActiveDocument.Saved = True
.ActiveDocument.Close Savechanges:=False
.WindowState = wdWindowStateMinimize
' .DisplayAlerts = wdAlertsNone '- Word won't prompt for large clipboard
' .Quit
.Application.ScreenUpdating = True
End With
End If
Set WordObj = Nothing
cmdOK_Exit:
Exit Function
cmdOK_Error:
Select Case Err
Case 429 '- OLE automation error. Word wasn't running.
Screen.MousePointer = vbDefault
' MsgBox "Microsoft Word isn't running. Please start it first and click 'Open' again.", vbExclamation, " Error Opening Document"
' Resume WordNotRunning '- This starts word without macpac really loaded, so don't do it.
' Unload Me
' Exit Sub
' Resume cmdOK_Exit
Resume WordNotRunning
' Case 5793 '- Incorrect file converter (not a Word document).
' Resume TryAgain
' Case 5121 '- Incorrect file converter (not a Word document).
' Resume TryAgain
Case Else
'7/7
Me.Hide
Screen.MousePointer = vbDefault
MsgBox "Error #" & Err.Number & ": " & Err.Description, vbInformation, " Error Opening Document"
' Exit Sub
Resume cmdOK_Exit
End Select
End Function
|
