Die Community zu .NET und Classic VB.
Menü

Quellcode des SourceConverters

 von 

Quellcode  

'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: reineck@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$()
Private ZeichenV$()
Private ProzA$()
Private ProzE$()
Private Token$()
Private TokLoaded As Boolean

'### Farben
Private NM$, BE$, CM$

'###########################################################
'#
'# 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$, 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
'----------------------------------------------------------------


'###########################################################
'#
'# Wandelt den Quellcode in das RTF Format
'#

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

     '### Kommentare
     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

     '### 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
 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) = "&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) & "</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$, 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
'----------------------------------------------------------------


'###########################################################
'#
'# Lädt die durch Datei$ vorgebene Datei und splittet diese
'# in den eigentlichen Sourcecode und ihrem Header auf.
'#

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
'----------------------------------------------------------------


'###########################################################
'#
'# Position eines Zeilenanfanges
'#

Private Function LineStart(ByVal A1&, ByVal Text$) As Long
   LineStart = InStr(A1, Text, vbCrLf)
   If LineStart <> 0 Then LineStart = LineStart + 2
End Function
'----------------------------------------------------------------


'###########################################################
'#
'# Position eines Zeilenendes
'#

Private Function LineEnd(ByVal A1&, ByVal Text$) As Long
   LineEnd = InStr(A1, Text, vbCrLf)
End Function
'----------------------------------------------------------------


'###########################################################
'#
'# Isoliert alle benannten Objekte eines Formulars aus seinem
'# Header.
'#

Public Function GetObjects(ByVal Head$) As ObjectListType
 Dim U&, X&, y&, Z&, Pos&
 Dim aa$
 Dim BB$()

   '### 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
 Dim a%
   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$, 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
'----------------------------------------------------------------


'###########################################################
'#
'# 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