Quellcode
Option Explicit
Public Type SourceFileType
Text As String Head As String Len As Long End Type
Public Type ObjectListType
Objekt() As String Bezeichnung() As String Count As Integer End Type
Private ZeichenH$()
Private ZeichenV$()
Private ProzA$()
Private ProzE$()
Private Token$()
Private TokLoaded As Boolean
Private NM$, BE$, CM$
Public Function VBtoHTML(SRC$, Mode$, FSize&, Optional C As _
Control) As String
Dim FontName$
If Not TokLoaded Then Call FillTokenList
FontName = "Courier New"
If UCase(Mode) = "HTM" Then
BE = "008000"
NM = "000000"
CM = "000080"
VBtoHTML = "<PRE><FONT SIZE=" & FSize & " FACE=" & FontName _
& ">" & HTMColor(ToHTML(SRC)) & vbCrLf _
& "</FONT></PRE>" & vbCrLf
ElseIf UCase(Mode) = "RTF" Then
BE = CStr(RGB(0, 128, 0))
NM = CStr(RGB(0, 0, 0))
CM = CStr(RGB(0, 0, 128))
Call RTFColor(C, SRC, FSize, FontName)
End If
End Function
Private Sub RTFColor(RTF As RichTextBox, SRC$, FSize&, Fname$)
Dim Pos&, X&, y&, Z&, E&, l&
Dim C1%, C2%, T2$
Dim TokenPos&, TokenFound%
RTF.TextRTF = Liner(SRC, "RTF")
l = Len(RTF.Text)
RTF.SelStart = 0
RTF.SelLength = l
RTF.SelFontSize = FSize
RTF.SelColor = Val(NM)
RTF.SelFontName = Fname
RTF.SelLength = 0
Pos = 1
Do While Pos < l
If Mid$(RTF.Text, Pos, 1) = Chr$(39) Then
X = InStr(Pos + 1, RTF.Text, vbCrLf)
If X = 0 Then X = l
RTF.SelStart = Pos - 1
RTF.SelLength = X - Pos
RTF.SelColor = Val(BE)
Pos = X + 1
Goto RTFnext
End If
If Mid$(RTF.Text, Pos, 1) = Chr$(34) Then
X = Pos - 1
Pos = InStr(Pos + 1, RTF.Text, Chr$(34))
If Pos = 0 Then
Pos = l
Else
Pos = Pos + 1
End If
End If
Z = InStr(Pos, RTF.Text, Chr$(34))
If Z = 0 Then Z = l
y = InStr(Pos, RTF.Text, Chr$(39))
If y = 0 Then y = l
If y < Z Then Z = y
TokenFound = -1
TokenPos = l
For X = 0 To UBound(Token)
y = InStr(Pos, RTF.Text, Token(X))
If y <> 0 And y < Z And y < TokenPos Then
If y > 1 Then
C1 = Asc(UCase(Mid$(RTF.Text, y - 1, 1)))
Else
C1 = 32
End If
T2 = UCase(Mid$(RTF.Text, y + Len(Token(X)), 1))
If T2 <> "" Then
C2 = Asc(T2)
Else
C2 = 32
End If
If (C1 < 65 Or C1 > 90) And _
(C2 < 65 Or C2 > 90) And Not _
(C1 > 47 And C1 < 58) And Not _
(C2 > 47 And C2 < 58) Then
TokenPos = y
TokenFound = X
End If
End If
Next X
If TokenFound > -1 Then
T2 = Token(TokenFound)
RTF.SelStart = TokenPos - 1
RTF.SelLength = Len(T2)
RTF.SelColor = Val(CM)
Pos = TokenPos + Len(T2)
Else
Pos = Z
End If
RTFnext:
Loop
RTF.SelStart = l
End Sub
Private Function HTMColor(ByVal Text$) As String
Dim Line$, NewLine$, P As Single
Dim X&, y&, aa$, Pos&, Tok%, MemTok%, LenTok%, l%, Buff$
Const Sep$ = "ÜÄÖß_"
For X = Len(Text) To 1 Step -1
aa = Mid$(Text, X, 1)
If aa <> vbCr And aa <> vbLf And aa <> " " Then Exit For
Next X
Text = Left$(Text, X) & vbCrLf
Text = " " & Liner(Text, "HTML")
Pos = 1
Do While Pos < Len(Text)
X = InStr(Pos, Text, vbCrLf)
If X <> 0 Then
Line = RTrim$(Mid$(Text, Pos, X - Pos))
Pos = X + 2
NewLine = ""
If Line <> "" Then
For X = 1 To Len(Line)
If Mid$(Line, X, 6) = """ Then
If Mid$(Line, X, 18) = """"" Then
X = X + 18
NewLine = NewLine & """""
Else
y = InStr(X + 6, Line, """)
If y = 0 Then
NewLine = NewLine & Mid$(Line, X)
Exit For
Else
NewLine = NewLine & Mid$(Line, X, y - X + 6)
X = y + 5
End If
End If
ElseIf Mid$(Line, X, 5) = "'" Then
NewLine = NewLine & "<FONT COLOR=#" & BE & ">" _
& Mid$(Line, X) & "</FONT>"
Exit For
Else
For Tok = 0 To UBound(Token)
l = Len(Token(Tok))
If Mid$(Line, X, l) = Token(Tok) Then
aa = UCase(Mid$(Line, X + l, 1))
y = 0
If aa <> "" Then y = Asc(aa)
If (y < 65 Or y > 90) And _
(y < 48 Or y > 57) Or _
InStr(1, Sep, aa) <> 0 Then
aa = ""
If X > 1 Then aa = UCase(Mid$(Line, X - 1, 1))
y = 0
If aa <> "" Then y = Asc(aa)
If (y < 65 Or y > 90) And _
(y < 48 Or y > 57) Or _
InStr(1, Sep, aa) <> 0 Then
NewLine = NewLine & "<FONT COLOR=#" & CM & ">" _
& Token(Tok) & "</FONT>"
X = X + l
Exit For
End If
End If
End If
Next Tok
NewLine = NewLine & Mid$(Line, X, 1)
End If
Next X
Else
NewLine = " "
End If
Buff = Buff & NewLine & vbCrLf
Else
Exit Do
End If
Loop
HTMColor = Mid$(Buff, 2)
End Function
Private Function Liner(ByRef Text$, ByRef Mode$) As String
Dim X&, y&, Z&, Pos&
Dim aa$
Dim Line$
Dim Dekla As Boolean
If Mode = "HTML" Then
Line = "<FONT COLOR=#808080><HR></FONT>"
Else
Line = "____________________________________"
Line = Line & Line
End If
If Text = "" Then Exit Function
For X = Len(Text) To 1 Step -1
aa = Mid$(Text, X, 1)
If aa <> " " And aa <> vbLf And aa <> vbCr Then Exit For
Next X
Text = Left$(Text, X)
Pos = 1
Do While Pos < Len(Text)
X = InStr(Pos, Text, vbCrLf)
If X <> 0 Then
Pos = X + 2
For y = Pos To Len(Text)
aa = Mid$(Text, y, 1)
If aa <> vbLf And aa <> vbCr Then Exit For
Next y
If Not Dekla Then
For Z = 0 To UBound(ProzA)
If Mid$(Text, y, Len(ProzA(Z))) = ProzA(Z) Then
For X = Pos - 1 To 1 Step -1
aa = Mid$(Text, X, 1)
If aa <> " " And aa <> vbLf And _
aa <> vbCr Then Exit For
Next X
Text = Left$(Text, X) & vbCrLf & Line _
& Mid$(Text, X + 1, Len(Text))
Pos = y
Dekla = True
Exit For
End If
Next Z
Else
For Z = 0 To UBound(ProzE)
If Mid$(Text, y, Len(ProzE(Z))) = ProzE(Z) Then
X = InStr(Pos, Text, vbCrLf)
If X <> 0 Then
Text = Left$(Text, X + 1) & Line & _
Mid$(Text, X, Len(Text))
Pos = X + Len(Line) + 4
Else
Pos = Len(Text)
End If
Exit For
End If
Next Z
End If
Else
Exit Do
End If
Loop
Liner = Text & vbCrLf
End Function
Public Function Load_SRC(ByVal Datei$) As SourceFileType
Dim aa$, BB$, CC$, A1&, LA&, LE&
If Datei = "" Then Exit Function
Open Datei For Input As 1
BB = Input$(LOF(1), 1)
Close 1
Load_SRC.Len = Len(BB)
LA = InStr(BB, "Attribute VB_Name")
If LA <> 0 Then
A1 = LineEnd(LA, BB) + 2
Do
LA = LineStart(LA, BB)
If LA = 0 Then Exit Do
LE = LineEnd(LA, BB)
If LE = 0 Then Exit Do
aa = Trim$(Mid$(BB, LA, LE - LA))
If aa <> "" And InStr(aa, "Attribute VB_") = 0 _
Then Exit Do
LA = LE
A1 = LA
Loop
CC = Trim$(Left$(BB, A1 - 1))
BB = Mid$(BB, A1, Len(BB))
A1 = LineEnd(1, BB)
If A1 <> 0 Then
aa = Trim$(Left$(BB, A1 - 1))
If aa = "" Then BB = Mid$(BB, A1 + 2, Len(BB))
End If
Load_SRC.Text = BB
Load_SRC.Head = CC
End If
End Function
Private Function LineStart(ByVal A1&, ByVal Text$) As Long
LineStart = InStr(A1, Text, vbCrLf)
If LineStart <> 0 Then LineStart = LineStart + 2
End Function
Private Function LineEnd(ByVal A1&, ByVal Text$) As Long
LineEnd = InStr(A1, Text, vbCrLf)
End Function
Public Function GetObjects(ByVal Head$) As ObjectListType
Dim U&, X&, y&, Z&, Pos&
Dim aa$
Dim BB$()
Pos = 1
Do While Pos < Len(Head)
X = InStr(Pos, Head, "Begin ")
If X = 0 Then Exit Do
y = InStr(X + 6, Head, Chr$(13) & Chr$(10)) - 1
If X < 1 Then Exit Do
U = InStr(X + 6, Head, ".")
If X < 1 Then Exit Do
ReDim Preserve BB(Z)
BB(Z) = Trim$(Mid$(Head, U + 1, y - U))
Z = Z + 1
Pos = y + 1
Loop
If Z <> 0 Then
For X = 0 To Z - 1
For y = 0 To Z - 1
If BB(y) > BB(X) Then
aa = BB(X)
BB(X) = BB(y)
BB(y) = aa
End If
Next y
Next X
ReDim GetObjects.Objekt(Z - 1)
ReDim GetObjects.Bezeichnung(Z - 1)
For X = 0 To Z - 1
y = InStr(1, BB(X), " ")
If y <> 0 Then
GetObjects.Objekt(X) = Left$(BB(X), y - 1)
GetObjects.Bezeichnung(X) = _
LTrim$(Mid$(BB(X), y + 1, Len(BB(X))))
Else
GetObjects.Objekt(X) = BB(X)
End If
Next X
GetObjects.Count = Z - 1
Else
GetObjects.Count = -1
End If
End Function
Private Function ToHTML(ByVal Inp$) As String
Dim a%
For a = 1 To UBound(ZeichenV) - 1
Inp = SwapElement(Inp, ZeichenV(a), ZeichenH(a))
Next a
ToHTML = Inp
End Function
Private Function SwapElement(ByVal Inp$, ByVal SRC$, _
ByVal Des$) As String
Dim a&, A1$, A2$
a = 1
Do
a = InStr(a, Inp, SRC)
If a = 0 Then Exit Do
If a <> 1 Then A1 = Left$(Inp, a - 1)
A2 = Mid$(Inp, a + Len(SRC), Len(Inp))
Inp = A1 + Des + A2
a = a + 1
Loop
SwapElement = Inp
End Function
Private Sub FillCharList()
ReDim ZeichenH$(0 To 16)
ReDim ZeichenV$(0 To 16)
ZeichenH(1) = "&": ZeichenV(1) = "&"
ZeichenH(2) = "Ä": ZeichenV(2) = "Ä"
ZeichenH(3) = "Ö": ZeichenV(3) = "Ö"
ZeichenH(4) = "Ü": ZeichenV(4) = "Ü"
ZeichenH(5) = "ä": ZeichenV(5) = "ä"
ZeichenH(6) = "ö": ZeichenV(6) = "ö"
ZeichenH(7) = "ü": ZeichenV(7) = "ü"
ZeichenH(8) = "ß": ZeichenV(8) = "ß"
ZeichenH(9) = "<": ZeichenV(9) = "<"
ZeichenH(10) = ">": ZeichenV(10) = ">"
ZeichenH(11) = """: ZeichenV(11) = Chr$(34)
ZeichenH(12) = "©": ZeichenV(12) = "©"
ZeichenH(13) = "~": ZeichenV(13) = "~"
ZeichenH(14) = "&Reg;": ZeichenV(14) = "&Reg;"
ZeichenH(15) = "'": ZeichenV(15) = "'"
ZeichenH(16) = " ": ZeichenV(16) = " "
End Sub
Private Sub FillTokenList()
ReDim ProzA(0 To 12)
ReDim ProzE(0 To 2)
ReDim Token(0 To 74)
ProzA(0) = "Function"
ProzA(1) = "Sub"
ProzA(2) = "Private Function"
ProzA(3) = "Private Sub"
ProzA(4) = "Public Function"
ProzA(5) = "Public Sub"
ProzA(6) = "Static Function"
ProzA(7) = "Static Sub"
ProzA(8) = "Friend Function"
ProzA(9) = "Friend Sub"
ProzA(10) = "Property Get"
ProzA(11) = "Property Let"
ProzA(12) = "Property Set"
ProzE(0) = "End Sub"
ProzE(1) = "End Function"
ProzE(2) = "End Property"
Token(0) = "Alias"
Token(1) = "And"
Token(2) = "Append"
Token(3) = "As"
Token(4) = "BF"
Token(5) = "Binary"
Token(6) = "Boolean"
Token(7) = "Byte"
Token(8) = "ByVal"
Token(9) = "Call"
Token(10) = "Close"
Token(11) = "Collection"
Token(12) = "Const"
Token(13) = "Control"
Token(14) = "Cstr"
Token(15) = "Declare"
Token(16) = "Dim"
Token(17) = "Do"
Token(18) = "Double"
Token(19) = "Else"
Token(20) = "ElseIf"
Token(21) = "End"
Token(22) = "Error"
Token(23) = "Exit"
Token(24) = "Explicit"
Token(25) = "False"
Token(26) = "For"
Token(27) = "Function"
Token(28) = "Goto"
Token(29) = "If"
Token(30) = "Input"
Token(31) = "Integer"
Token(32) = "LBound"
Token(33) = "Lib"
Token(34) = "Line"
Token(35) = "Long"
Token(36) = "Loop"
Token(37) = "New"
Token(38) = "Next"
Token(39) = "Not"
Token(40) = "Nothing"
Token(41) = "On"
Token(42) = "Open"
Token(43) = "Option"
Token(44) = "Or"
Token(45) = "Output"
Token(46) = "Print"
Token(47) = "Private"
Token(48) = "Public"
Token(49) = "Random"
Token(50) = "ReDim"
Token(51) = "Set"
Token(52) = "Single"
Token(53) = "Step"
Token(54) = "String"
Token(55) = "Sub"
Token(56) = "Then"
Token(57) = "To"
Token(58) = "True"
Token(59) = "Type"
Token(60) = "UBound"
Token(61) = "Until"
Token(62) = "While"
Token(63) = "With"
Token(64) = "CBool"
Token(65) = "CByte"
Token(66) = "CCur"
Token(67) = "CDate"
Token(68) = "CDbl"
Token(69) = "CDec"
Token(70) = "CInt"
Token(71) = "CLng"
Token(72) = "CSng"
Token(73) = "CStr"
Token(74) = "CVar"
Call FillCharList
TokLoaded = True
End Sub