'Dieser Source stammt von http://www.activevb.de und
'darf zur nichtkommerziellen Nutzung frei verwendet werden,
'solange diese Vermerke unverändert bleiben.
'© Götz Reinecke Feb 2000
'
'Für eventuelle Schäden wird nicht gehaftet.
'
'Sollten Sie Fehler entdecken oder Fragen haben, dann
'mailen Sie mir bitte unter: reinecke@activevb.de
'Ansonsten viel Spaß und Erfolg damit !
 
Option Explicit
 
'### Typ zur Aufsplittung des Quellcodes
Public Type SourceFileType
    Text As String          ' Eigentlicher Source
    Head As String          ' Header-Abschnitt
    Len As Long             ' Länge der Datei
End Type
 
 
'### Organisation der im Header stehenden Objekte
Public Type ObjectListType
    Objekt() As String      ' Objekttyp
    Bezeichnung() As String ' Name des 'Objekts
    Count As Integer        ' Anzahl aller Objekte
End Type
 
'### Felder zur Umwandlung
Private ZeichenH() As String
Private ZeichenV() As String
Private ProzA() As String
Private ProzE() As String
Private Token() As String
Private TokLoaded As Boolean
 
'### Farben
Private NM As String, BE As String, CM As String
 
'###########################################################
'#
'# Einsprung-Funktion:
'# SRC$  : Übergabe des Quelltextes
'# Mode$ : HTM Umwandlung in HTM-Format
'#       : RTF Umwandlung in RTF-Format
'# FSize&: Schriftgröße
'# C     : Übergabe eines RTF-Controls
'#

Public Function VBtoHTML(SRC As String, Mode As String, FSize As Long, Optional C As Control) As String Dim FontName As String 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
'########################################################### '# '# Wandelt den Quellcode in das RTF Format '# Private Sub RTFColor(RTF As RichTextBox, SRC As String, FSize As Long, Fname As String) Dim Pos As Long, X As Long, y As Long, Z As Long, E As Long, l As Long, xt As Long Dim C1 As Integer, C2 As Integer, T2 As String Dim TokenPos As Long, TokenFound As Integer 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 '### Kommentare If Mid$(RTF.Text, Pos, 1) = Chr$(39) Then xt = Pos Do X = InStr(xt + 1, RTF.Text, vbCrLf) If X = 0 Then X = l Exit Do Else If X > 1 Then If Mid(RTF.Text, X - 1, 1) = "_" Then xt = X + 2 Else Exit Do End If Else Exit Do End If End If Loop RTF.SelStart = Pos - 1 RTF.SelLength = X - Pos RTF.SelColor = Val(BE) Pos = X + 1 GoTo RTFnext End If '### Anführungszeichen 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 '### Token finden bis zum nächsten " oder ' 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 '### Suche nach dem nächsten Token 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 '### Token einfärben 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
'########################################################### '# '# Wandelt den Quelltext in HTML-Code um '# Private Function HTMColor(ByVal Text As String) As String Dim Line As String, NewLine As String, P As Single, Com As String, xn As Long, xt As Long Dim X As Long, y As Long, aa As String, Pos As Long, Tok As Integer Dim MemTok As Integer, LenTok As Integer, l As Integer, Buff As String Const Sep As String = "ÜÄÖß_" 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) = "&quot;" Then If Mid$(Line, X, 18) = "&quot;&quot;&quot;" Then X = X + 18 NewLine = NewLine & "&quot;&quot;&quot;" Else y = InStr(X + 6, Line, "&quot;") 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) = "&#39;" Then NewLine = NewLine & "<FONT COLOR=#" & BE & ">" & Mid$(Line, X) If Right(Line, 1) = "_" Then xt = Pos Do xn = InStr(xt, Text, vbCrLf) If xn = 0 Then xt = Len(Text) Exit Do Else If Mid(Text, xn - 1, 1) = "_" Then xt = xn + 2 Else xt = xn Exit Do End If End If Loop NewLine = NewLine & vbCrLf & Mid(Text, Pos, xt - Pos) Pos = xt End If NewLine = NewLine & "</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
'########################################################### '# '# Analysiert den Sourcecode und fügt zwischen den Funktionen '# und hinter dem Deklarationsabschnitt je einem Trennstrich '# ein. '# Private Function Liner(ByRef Text As String, ByRef Mode As String) As String Dim X As Long, y As Long, Z As Long, Pos As Long Dim aa As String, Line As String, 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
'########################################################### '# '# Lädt die durch File vorgebene Datei und splittet diese '# in den eigentlichen Sourcecode und ihrem Header auf. '# Public Function Load_SRC(ByVal File As String) As SourceFileType Dim aa As String, BB As String, CC As String, A1 As Long, LA As Long, LE As Long If File = "" Then Exit Function Open File 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
'########################################################### '# '# Position eines Zeilenanfanges '# Private Function LineStart(ByVal A1 As Long, ByVal Text As String) As Long LineStart = InStr(A1, Text, vbCrLf) If LineStart <> 0 Then LineStart = LineStart + 2 End Function
'########################################################### '# '# Position eines Zeilenendes '# Private Function LineEnd(ByVal A1 As Long, ByVal Text As String) As Long LineEnd = InStr(A1, Text, vbCrLf) End Function
'########################################################### '# '# Isoliert alle benannten Objekte eines Formulars aus seinem '# Header. '# Public Function GetObjects(ByVal Head As String) As ObjectListType Dim U As Long, X As Long, y As Long, Z As Long, Pos As Long, aa As String, BB() As String '### Objekte isolieren 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 '### Objekte sortieren 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 '### Objekte in Bezeichnung und Namen aufteilen 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
'########################################################### '# '# Tauscht alle Sonderzeichen des Sourcecodes gegen die HTML- '# Sonderzeichen aus. '# Private Function ToHTML(ByVal Inp As String) As String Dim a As Integer For a = 1 To UBound(ZeichenV) - 1 Inp = SwapElement(Inp, ZeichenV(a), ZeichenH(a)) Next a ToHTML = Inp End Function
'########################################################### '# '# Tauscht im Sting Inp$ alle durch SRC$ definierten Fragmente '# gegen Des$ aus. (Im Prinzip die Funktion Replace unter VB 6) '# Private Function SwapElement(ByVal Inp As String, ByVal SRC As String, ByVal Des As String) As String Dim a As Long, A1 As String, A2 As String 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
'########################################################### '# '# Liste der HTML-Sonderzeichen (Beliebig erweiterbar) '# Private Sub FillCharList() ReDim ZeichenH(0 To 16) ReDim ZeichenV(0 To 16) ZeichenH(1) = "&amp;": ZeichenV(1) = "&" ZeichenH(2) = "&Auml;": ZeichenV(2) = "Ä" ZeichenH(3) = "&Ouml;": ZeichenV(3) = "Ö" ZeichenH(4) = "&Uuml;": ZeichenV(4) = "Ü" ZeichenH(5) = "&auml;": ZeichenV(5) = "ä" ZeichenH(6) = "&ouml;": ZeichenV(6) = "ö" ZeichenH(7) = "&uuml;": ZeichenV(7) = "ü" ZeichenH(8) = "&szlig;": ZeichenV(8) = "ß" ZeichenH(9) = "&lt;": ZeichenV(9) = "<" ZeichenH(10) = "&gt;": ZeichenV(10) = ">" ZeichenH(11) = "&quot;": ZeichenV(11) = Chr$(34) ZeichenH(12) = "&copy;": ZeichenV(12) = "©" ZeichenH(13) = "&#126;": ZeichenV(13) = "~" ZeichenH(14) = "&Reg;": ZeichenV(14) = "&Reg;" ZeichenH(15) = "&#39;": ZeichenV(15) = "'" ZeichenH(16) = "&nbsp;": ZeichenV(16) = " " End Sub
'########################################################### '# '# Liste der VB-Tokens und der Prozeduren-Umrahmung. Die Liste '# ist nicht vollständig und kann nach Belieben erweitert wer- '# den '# Private Sub FillTokenList() ReDim ProzA(0 To 12) ReDim ProzE(0 To 2) ReDim Token(0 To 74) '### Prozeduren Einleitungen 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" '### Prozeduren Abschlüsse ProzE(0) = "End Sub" ProzE(1) = "End Function" ProzE(2) = "End Property" '### Tokens 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