📄 code2html.bas
字号:
Attribute VB_Name = "modCode2Html"
Const HEADER = "<html><body bgcolor=white text=black><pre>" & vbCrLf
Const BLU = "<FONT COLOR='#000088'>"
Const GRN = "<FONT COLOR='#008800'>"
Const CF = "</FONT>"
Dim RW() As String
Dim Special() As String
Dim s As New Strings
Sub initalizeRW()
'case & space after word is important !
'Keyword list by Malcom Ferris http://www.intactinteractive.com
RW = Split("Const ,Else ,ElseIf ,If ,Alias ,And ,As ,Base ,Binary ,Boolean ," & _
"Byte ,ByVal ,Call ,Case ,CBool ,CByte ,CCur ,CDate ,CDbl ,CDec ," & _
"CInt ,CLng ,Close ,Compare ,Const ,CSng ,CStr ,Currency ,CVar ," & _
"CVErr ,Decimal ,Declare ,DefBool ,DefByte ,DefCur ,DefDate ," & _
"DefDbl ,DefDec ,DefInt ,DefLng ,DefObj ,DefSng ,DefStr ,DefVar ," & _
"Dim ,Do ,Double ,Each ,End ,Enum ,Eqv ,Erase ,Error ," & _
"Exit ,Explicit ,False ,For ,Function ,Get ,Global ,GoSub ,GoTo ," & _
"Imp ,In ,Input ,Input ,Integer ,Is ,LBound ,Let ,Lib ,Like ,Line ,Lock ," & _
"Long ,Loop ,LSet ,Name ,New ,Next ,Not ,Object ,Open ,Option ,On ,Or ," & _
"Output ,Preserve ,Print ,Private ,Property ,Public ,Put ,Random ," & _
"Read ,ReDim ,Resume ,Return ,RSet ,Seek ,Select ,Set ,Single ,Spc ," & _
"Static ,String ,Stop ,Sub ,Tab ,Then ,True ,UBound ,Variant ,While ," & _
"Wend ,With ,Empty " _
, ",")
'these handle some other common casekeywords that dont fit the word<space> profile
'necessary because this search is done on a macro scale and not by trying to anlyze
'each word or character it comes across
Special = Split("CLng(,CInt(,CBool(,CByte(,CStr(,True),False),Empty),(True,(False,(Empty", ",")
End Sub
Function formatIt(it)
Dim comment, code, lastDq, lastSq
tmp = Split(it, vbCrLf)
For i = 0 To UBound(tmp)
comment = Empty
code = parseHTMLChars(tmp(i))
s.Strng = code
lastDq = s.LastIndexOf("""")
lastSq = s.LastIndexOf("'")
If lastSq > lastDq Then
If lastDq = -1 Then lastDq = lastSq
comment = s.ToEndOfStr(lastDq)
code = s.Substring(1, lastDq)
End If
tmp(i) = ParseCode(code) & ParseComment(comment)
Next
it = Join(tmp, vbCrLf)
formatIt = HEADER & RemoveRedundantTags(it)
End Function
Function parseHTMLChars(it)
t = Replace(it, "&", "&")
t = Replace(t, "<", "<")
t = Replace(t, ">", ">")
parseHTMLChars = t
End Function
Function ParseCode(it)
If it = Empty Then Exit Function
For i = 0 To UBound(RW)
it = Replace(it, RW(i), BLU & RW(i) & CF)
Next
For i = 0 To UBound(Special)
it = Replace(it, Special(i), BLU & Special(i) & CF)
Next
ParseCode = it
End Function
Function ParseComment(it)
If it = Empty Then Exit Function
ParseComment = GRN & it & CF
End Function
Function RemoveRedundantTags(it)
it = Replace(it, CF & BLU, Empty)
it = Replace(it, CF & GRN, Empty)
it = Replace(it, CF & vbCrLf & BLU, vbCrLf)
it = Replace(it, CF & vbCrLf & GRN, vbCrLf)
RemoveRedundantTags = it
End Function
'-----------------------------------------------------------------------------
'if you want to use inline style sheets..should save space
'and should be pretty well support by 90% of browsers now a days..
'here are the lines to add to use them (it works fine but I only
'tested IE)
'Const HEADER = "<html><style>#b{COLOR:#000088;}#g{COLOR:#008800;}</style>" & _
<body bgcolor=white text=black><pre>" & vbCrLf
'Const SSB = "<font id='b'>"
'Const SSG = "<font id='g'>"
'then replace the old lines with these
'it = Replace(it, RW(i), SSB & RW(i) & CF)
'ParseCode = Replace(it, CF & SSB, Empty)
'ParseComment = SSG & it & CF
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -