Quellcode von DeTager

Quellcode  

 'Dieser Source stammt von http://www.activevb.de und
 'darf zur nicht kommerziellen Nutzung frei verwendet werden,
 'solange diese Vermerke unverändert bleiben.
 '© Götz Reinecke Jan 2000
 '
 'Für eventuelle Schäden wird nicht gehaftet.
 '
 'Sollten Sie Fehler entdecken oder Fragen haben, dann
 'mailen Sie mir bitte unter: vb@goetz-reinecke.de
 'Ansonsten viel Spaß und Erfolg damit !
 
Option Explicit 

 Public Type DetagerType         '# Übergabe-Variable des DeTager Moduls
   HtmlText As String            '# übergibt das HTML-Dokument
   BlockingRate As Long          '# Legt die Größe der Blöcke fest
   DoEventsRate As Integer       '# x>0 :mit Progressbar, alle x ein DoEvent
                                 '# x=0 :ohne Progressbar, keine DoEvents
                                 '# x<0 :ohne Progressbar, alle x ein DoEvent
   ProgressBar As Control        '# Übergibt das Progressbar Control
   ErrorString As String         '# Definiert den HTML-Fehlerstring
   ErrorIgnore As Boolean        '# Fehlerunterdrückung aktivieren/deaktivieren
   MakeText As Boolean           '# Erlaubt die Umwandlung des Textes
   MakeTags As Boolean           '# Erlaubt die Analyse der Tags
 End Type
 

 Public Type DetagerResultType   '# Ergebnis-Variable des DeTager Moduls
   Text As String                '# Gibt den analysierten Text wieder
   ImageListCount As Long        '# Anzahl der gefundenen direkten Grafiken
   ImageList() As String         '# Liste der Adressen aller direkten Grafiken
   ImageMass() As Integer        '# Anzahl der jeweiligen direkten Grafiken
   AlterList() As String         '# Liste der Alternativtexte der direkten Grafiken
   ReferListCount As Long        '# Anzahl der gefundenen Refers (Links)
   ReferList() As String         '# Liste der Adressen aller gefundenen Refers (Links)
   ReferMass() As Integer        '# Anzahl der jeweiligen Refers (Links)
   AncorListCount As Long        '# Anzahl der gefundenen Anker
   AncorList() As String         '# Liste der Namen aller gefundenen Anker
   TargetListCount As Long       '# Anzahl der gefundenen Targets
   TargetList() As String        '# Liste der Namen aller gefundenen Targets
   TargetMass() As Integer       '# Anzahl der jeweiligen Targets
   CommentListCount As Long      '# Anzahl der aufgetretenen Kommentare
   CommentList() As String       '# Liste der aufgetretenen Kommentare
   ErrorListCount As Long        '# Anzahl der intern verursachten Fehler
   ErrorList() As String         '# Liste der intern verursachten Fehler
   HTMLErrorCount As Long        '# Anzahl der im Text gefundenen HTML-Fehler
   Title As String               '# Titel des HTML-Dokuments
   MetaDescription As String     '# Text der in den META-Tags gefundenen Beschreibung
   MetaKeywords As String        '# Text der in den META-Tags gefundenen Schlüsselwörter
   MetaLanguage As String        '# Text der in den META-Tags gefundenen Landessprache
   Java As String                '# Enthält alle isolierten JavaScript Befehle
   MetaRevisit As String         '# Text der in den META-Tags gefundenen erneuten
                                  '  Besuchsaufforderung
 End Type



 Private AllowTasks As Boolean       '# Flag für DoEvents
 Private TaskNum%                    '# Modulinternes Abbild der Eingangsvariablen
                                     '  DoEventsRate
 Private ERRTxt$                     '# Modulinternes Abbild der Eingangsvariablen
                                     '  ErrorString
 Private Progress As Control         '# Modulinternes Abbild der Eingangsvariablen
                                     '  Progressbar
 Private ErrorIgnore As Boolean      '# Modulinternes Abbild der Eingangsvariablen
                                     '  ErrorIgnore
 Private BLOCK$(), BLOCKCNT&         '# Feldvariable und deren Zähler für das Anlegen
                                     '  der Blöcke
 Private Result As DetagerResultType '# Modul Ergebnisvariable
 Private LIMIT&                      '# Optimum be ca 850
 Private FORBIDDEN$                  '# String für das Festlegen der führenden
                                    '  unbedeutenden Zeichen einer Zeile
 Public DeTagerActive As Boolean     '# Dieses Flag zeigt an ob das Module bereits arbeitet


 '######################################################################
 '#
 '#  'Detag' ist die Einstiegsroutine für das Modul Detager. Von hier
 '#          werden die Variablen initialisiert alle Abläufe gesteuert.
 '#

 Public Function Detag(DOC As DetagerType) As DetagerResultType
  If DOC.ErrorIgnore Then If ErrorIgnore Then On Error Goto ERRDeTag
  Dim x&, AA$
    
    '### Läuft Modul bereits ?
    If DeTagerActive = True Then
      Exit Function
    Else
      DeTagerActive = True
    End If
    
    
    '### Festlegen der führenden unbedeutenden Zeichen einer Zeile
    FORBIDDEN = Chr$(9) & Chr$(10) & Chr$(13) & Chr$(32) & Chr$(160)
    
    
    '### Initialieren der Variable Result
    Result.Text = ""
    Result.ImageListCount = 0
    Result.ReferListCount = 0
    Result.AncorListCount = 0
    Result.TargetListCount = 0
    Result.CommentListCount = 0
    Result.ErrorListCount = 0
    Result.HTMLErrorCount = 0
    Result.MetaDescription = ""
    Result.MetaKeywords = ""
    
    
    '### Initialieren der internen Variablen
    BLOCKCNT = 0
    ERRTxt = DOC.ErrorString
    TaskNum = DOC.DoEventsRate



    '########################## Aufruf DeScripter Anfang ###########################
    '#                                                                             #
    '#  Diesen Teil bei Nichtverwendung des Moduls 'DeScripter' ausdokumentieren   #
    '#                                                                             #
        x = InStr(1, UCase(DOC.HtmlText), "SCRIPT")                               '#
        If x Then                                                                 '#
          Dim Script As DeScripterType                                            '#
          Script = ScriptSens(DOC.HtmlText)                                       '#
          DOC.HtmlText = Script.HTML                                              '#
          Result.Java = Script.Java                                               '#
        End If                                                                    '#
    '#                                                                             #
    '#                                                                             #
    '########################## Aufruf DeScripter Ende #############################



    '### Progressbar / Task Handling
    If Abs(TaskNum) <> 0 Then
      '### Tasks erlaubt
      AllowTasks = True
      If TaskNum > 0 Then
        '### Progressbar anzeigen und hochzählen
        Set Progress = DOC.ProgressBar
        Progress.Min = 0
        Progress.Value = 0
        If Len(DOC.HtmlText) > 0 Then Progress.Max = Len(DOC.HtmlText)
      End If
    Else
      '### keine Tasks erlaubt
      AllowTasks = False
    End If
    
    
    '### Blockgröße prüfen und Blockfeld dimensionieren
    LIMIT = DOC.BlockingRate
    If LIMIT < 1 Or LIMIT > 500000 Then Exit Function
    ReDim BLOCK(0 To Len(DOC.HtmlText) / LIMIT + 10)
    
    
    '### Eigentliche Analyse starten
    DOC.HtmlText = GetTitle(DOC.HtmlText, DOC.MakeText)
    If DOC.MakeText Then
        '### Text mit umwandeln
        Call DelTag(DOC.HtmlText, DOC.MakeTags)
        For x = 0 To BLOCKCNT - 1
          Call DeBLock(x)
          Result.Text = Result.Text & BLOCK(x)
        Next x
    Else
        '### Nur Tags analysieren
        Call GetTag(DOC.HtmlText)
    End If
    
    
    '### Rückgabe der ermittelten Werte und Texte
    Detag = Result
    DeTagerActive = False
  Exit Function


 '### Fehlerbehandlung
 ERRDeTag:
    Call ERRSTACK(Err.Number, Err.Description, "DeTager", "DeTag")
    Resume Next
 End Function



 '######################################################################
 '#
 '#  'DeBlock' Entfernt Blockübergreifend aus dem durch 'X&' benannten
 '#            Block, alle überflüssigen Leerzeilen und führenden Leer-
 '#            zeichen (Definition dieser Zeichen in Variablen 'FORBIDDEN$'
 '#

 Private Sub DeBLock(ByVal x&)
  If ErrorIgnore Then On Error Goto ERRDeBlock
  Dim AA$, BB$, CC$, P1&, P2&, P&, POS&, y&, z&
  Dim EOLflag As Boolean
 
    POS = 1
    AA = BLOCK(x)
     
    '### Folgendes gilt für alle Blöcke nur nicht den ersten
    If x <> 0 Then
          'Ist nicht der erste Block
          If Len(BLOCK(x - 1)) > 1 Then
              '### der letzte Block vor dem aktuellen hat eine Länge von mindestens zwei
              '     ZEICHEN
              BB = Right$(BLOCK(x - 1), 1)
              If BB = Chr$(13) Or BB = Chr$(10) Then
                  '### Letzter Block hört mit Chr(10) oder Chr(13) auf.
                  '    Dies ist von Bedeutung falls der aktuelle ebenfalls mit Chr(10)
                  '    oder Chr(13) beginnt
                  For y = Len(BLOCK(x - 1)) To 1 Step -1
                      BB = Mid$(BLOCK(x - 1), y, 1)
                      '### untersuchen ob sich vor dem Zeilenumbruch des letzten Blockes
                      '    überflüssige Zeichen befinden
                      If InStr(1, FORBIDDEN, BB) = 0 Then Exit For
                  Next y
                  '### Abschneiden der überflüssigen Zeichen inkl. des Zeilenumbruchs
                  '    und hinzufügen eines neuen Umbruchs
                  BLOCK(x - 1) = RTrim$(Left$(BLOCK(x), y)) & Chr$(13) & Chr$(10)
                  '### Setzen des Umbruchsflag um im weiteren deutlich zu machen,
                  '    daß der letzte Block mit einem Umbruch endet
                  EOLflag = True
              End If
          End If
    End If
    
    
    
    If EOLflag Or x = 0 Then
        '### Letzter Block endet mit einem Umbruch (EOLFLAG) oder es handelt
        '    sich um den ersten Block (X=0)
        For y = 1 To Len(AA)
            BB = Mid$(AA, y, 1)
            '### Überflüssige Leerzeichen oder Ümbrüche der ersten
            '    Zeile (Sonderstatus) des aktuellen Blockes entfernen
            If InStr(1, FORBIDDEN, BB) = 0 Then Exit For
        Next y
        '### Und den Müll abschneiden
        AA = LTrim$(Mid$(AA, y, Len(AA)))
    Else
       '### Letzter Block endet nicht mit einem Umbruch (EOLFLAG) und es
       '    handelt sich auch nicht um den ersten Block (X=0)
        BB = Left$(LTrim$(AA), 1)
        If BB = Chr$(13) Or BB = Chr$(10) Then
            '### Erstes Zeichen der ersten Zeile des aktuellen Blockes
            '    ist ein Umbruch, deshalb wird der Umbruch an den letzen
            '    Block angehängt und im aktuellen abgeschnitten
            BLOCK(x - 1) = BLOCK(x - 1) & Chr$(13) & Chr$(10)
            For y = 1 To Len(AA)
                '### Überflüssige Leerzeichen oder Ümbrüche der ersten
                '    Zeile (Sonderstatus) des aktuellen Blockes entfernen
                BB = Mid$(AA, y, 1)
                If InStr(1, FORBIDDEN, BB) = 0 Then Exit For
            Next y
            '### Und den Müll abschneiden
            AA = Mid$(AA, y, Len(AA))
        End If
    End If
    
    
    '### So alle Vorarbeiten und Besonderheiten erledigt, hier folgt
    '    jetzt die eigentliche Eleminierung anhand einer Schleife
    Do While POS < Len(AA)
        '### P1 Umbruch durch Chr(10); P2 Umbruch durch Chr(13)
        P1 = InStr(POS, AA, Chr$(10))
        P2 = InStr(POS, AA, Chr$(13))
        If P1 = 0 And P2 = 0 Then
            '### Kein Umbruch im restlichen Block mehr vorhanden; also fertig
            BLOCK(x) = AA
            Exit Sub
        End If
        
        
        If (P1 < P2 And P1 <> 0) Or P2 = 0 Then
            '### Umbruch P1 (Chr(10)) kommt vor Umbruch P2 (Chr(13))
            P = P1
        Else
            '### Umbruch P2 (Chr(13)) kommt vor Umbruch P1 (Chr(10))
            P = P2
        End If
        
        
        '### Ausschneiden des Textes vor dem Umbruch, abspeichern in CC$
        CC = Left$(AA, P - 1) & Chr$(13) & Chr$(10)
        POS = P + 2
        
        
        '### Prüfen ob Umbruch von überflüssigen führenden Zeichen
        '    gefolgt wird
        z = Len(AA)
        For y = P + 1 To Len(AA)
            z = y
            BB = Mid$(AA, y, 1)
            If InStr(1, FORBIDDEN, BB) = 0 Then Exit For
            z = y + 1
        Next y
        '### Zusammen setzen des Textes unter Auschneidung der überflüssigen
        '    Zeichenkette
        AA = CC & Mid$(AA, z, Len(AA))
    Loop
    BLOCK(x) = AA
  Exit Sub
    
    
 '### Fehlerbehandlung
 ERRDeBlock:
    Call ERRSTACK(Err.Number, Err.Description, "DeTager", "DeBlock")
    Resume Next
 End Sub


 '######################################################################
 '#
 '#  'DelTag' Findet Tags, analysiert sie und zerlegt den eignetlichen
 '#           Text in Blöcke. Die Variable 'HTML$' enthält das HTML-
 '#           Dokument. 'TagFlag' erlaubt oder verbietet das analysieren
 '#           der Tags.
 '#

 Private Function DelTag(ByVal HTML$, ByVal TagFlag As Boolean) As String
  If ErrorIgnore Then On Error Goto ERRDelTag
  Dim POS&, TAG1&, TAG2&, TAG3&, TAG4&, TestTag&, S&
  Dim TAG$, TXT$, AA$, COM$
  
    If HTML = "" Then Exit Function
    POS = 1
    S = 1
    Do While POS < Len(HTML)
    
        '### Erfassen der Position vom Anfang des nächsten Tags
        TAG1 = InStr(POS, HTML, "<")
        If TAG1 = 0 Then
            '### Es wurde kein weiteres öffnendes Tag gefunden
            If TAG2 = 0 Then TAG2 = S - 1
            TXT = MakeBlock(TXT & ASCTausch(Mid$(HTML, TAG2 + 1, Len(HTML))), True)
            Exit Function
        End If
        
        
        '### Erfassen der Position vom Ende des nächsten Tags
        TAG2 = InStr(TAG1, HTML, ">")
        If TAG2 = 0 Then
            '### Es wurde kein weiteres schließendes Tag gefunden
            DelTag = MakeBlock(TXT & ASCTausch(Mid$(HTML, S, Len(HTML))), True)
            Exit Function
        End If
    
    
        '# Prüfen auf Fehler (z.B.: <TA1G<TAG2>)
        TestTag = InStr(TAG1 + 1, HTML, "<")
        If (TestTag > TAG2) Or TestTag = 0 Then
            '### Kein HTML Fehler: Tag gefunden
            If TagFlag Then Call TagSens(Mid$(HTML, TAG1, TAG2 - TAG1 + 1))
            If S < TAG1 Then
                TXT = TXT & ASCTausch(Mid$(HTML, S, TAG1 - S))
                If Len(TXT) > LIMIT Then TXT = MakeBlock(TXT, False)
            End If
        Else
            '### Eventuell HTML-Fehler, jedoch vorheriges Prüfen auf HTML Kommentar
            TAG3 = InStr(TAG1 + 4, HTML, "-->")
            TAG4 = InStr(TAG1 + 4, HTML, "<!--")
            AA = Mid$(HTML, TAG1, 4)
 
            If (AA <> "<!--")Or (AA = "<!--" And TAG3 = 0) Or _
               (AA = "<!--" And TAG3 > TAG4 And TAG4 <> 0) Then
                    '### HTML Error
                    TXT = TXT & ASCTausch(Mid$(HTML, S, TAG1 - S)) & Chr$(13)
                    TXT = TXT & Chr$(10) & ERRTxt & Mid$(HTML, TAG1, TAG2 - TAG1 + 1)
                    TXT = TXT & ERRTxt & Chr$(13) & Chr$(10)
                    If Len(TXT) > LIMIT Then TXT = MakeBlock(TXT, False)
                    Result.HTMLErrorCount = Result.HTMLErrorCount + 1
            ElseIf AA = "<!--" And ((TAG3 <> 0 And TAG3 < TAG4) Or (TAG3 <> 0 And _
                   TAG4 = 0)) Then
                    '### HTML-Kommentar herausschneiden
                    COM = Mid$(HTML, TAG1, TAG3 - TAG1 + 3)
                    Call SaveComment(COM)
                    TAG2 = TAG3 + 2
            End If
        End If
        
        '### Positionszeiger erhöhen
        POS = TAG2 + 1
        S = POS
        
        '### Task zulassen ?
        If AllowTasks Then Call EventHandler(POS)
    Loop
    
    
    '### Vom Resttext den letzten Block erstellen
    DelTag = MakeBlock(TXT & ASCTausch(Mid$(HTML, TAG2 + 1, Len(HTML))), True)
  Exit Function


 '### Fehlerbehandlung
 ERRDelTag:
    Call ERRSTACK(Err.Number, Err.Description, "DeTager", "DelTag")
    Resume Next
    
 End Function

 '######################################################################
 '#
 '#  'SaveComment' Speichert die übergebene Variable COM$ in einen Stack
 '#

 Private Sub SaveComment(ByVal COM$)
  If ErrorIgnore Then On Error Goto ERRSaveComment
    ReDim Preserve Result.CommentList(0 To Result.CommentListCount + 1)
    Result.CommentList(Result.CommentListCount) = COM
    Result.CommentListCount = Result.CommentListCount + 1
  Exit Sub


 '### Fehlerbehandlung
 ERRSaveComment:
    Call ERRSTACK(Err.Number, Err.Description, "DeTager", "SaveComment")
    Resume Next
    
 End Sub

 '######################################################################
 '#
 '#  'GetTag' Die eigentliche Analyse bezieht sich nur auf Tags; der
 '#           Text wird hier nicht berücksichtigt.
 '#

 Private Function GetTag(ByVal HTML$)
  If ErrorIgnore Then On Error Goto ERRGetTag
  Dim POS&, TAG1&, TAG2&, TestTag&
  Dim TAG$

    If HTML = "" Then Exit Function
    POS = 1
    Do While POS < Len(HTML)
        TAG1 = InStr(POS, HTML, "<")
        If TAG1 = 0 Then Exit Function '### Kein weiteres Tag mehr gefunden
                
        TAG2 = InStr(TAG1, HTML, ">")
        If TAG2 = 0 Then Exit Function '### Kein weiteres Tag mehr gefunden
              
        '### Testen auf HTML-Fehler; wenn kein Fehler wird das Tag analysiert
        TestTag = InStr(TAG1 + 1, HTML, "<")
        If (TestTag > TAG2) Or TestTag = 0 Then Call TagSens(Mid$(HTML, TAG1, _
                                                             TAG2 - TAG1 + 1))
        POS = TAG2 + 1
        If AllowTasks Then Call EventHandler(POS)
    Loop
  Exit Function


 '### Fehlerbehandlung
 ERRGetTag:
    Call ERRSTACK(Err.Number, Err.Description, "DeTager", "GetTag")
    Resume Next
    
 End Function



 '######################################################################
 '#
 '#  'MakeBlock' Zerlegt den Text in Blöcke der Größe 'Limit' und
 '#              speichert diese in einem Stack. Der Rest wird zu-
 '#              rückgegeben. Die Variable Ende zeigt an ob es sich
 '#              um den letzten Textabschnitt handelt, damit der
 '#              Resttext in einem eigenen Block abgelegt werden
 '#              kann.
 '#

 Private Function MakeBlock(ByVal Text$, Ende As Boolean) As String
  If ErrorIgnore Then On Error Goto ERRMakeBlock
  Dim x&, AA$
    
    '### Prüfen ob das FEld für die Blöcke hoch genug dimensioniert wurde.
    '    Falls nicht wird das Feld um zehn weitere Blöcke erhöht
    If UBound(BLOCK) < BLOCKCNT + 3 Then
        ReDim Preserve BLOCK(0 To BLOCKCNT + 10)
    End If
    
    '### Text in gleichgroße (LIMIT&) Blöcke zerlegen und zuweisen
    For x = 1 To Len(Text) - LIMIT Step LIMIT
         BLOCK(BLOCKCNT) = Mid$(Text, x, LIMIT)
         BLOCKCNT = BLOCKCNT + 1
    Next x
    
    
    '### Den nach der Zerlegung verbleibenden Rest in 'AA$' ablegen
    AA = Mid$(Text, x, LIMIT)
    If Ende Then
         '### handelt es sich um das Ende des HTML-Textes wird dem Rest
         '    ein eigener Block zugewiesen
         BLOCK(BLOCKCNT) = AA
         BLOCKCNT = BLOCKCNT + 1
    End If
    '### Rest zurückgeben
    MakeBlock = AA
   Exit Function


 '### Fehlerbehandlung
 ERRMakeBlock:
    Call ERRSTACK(Err.Number, Err.Description, "DeTager", "MakeBlock")
    Resume Next
    
 End Function



 '######################################################################
 '#
 '#  'TagSens' Schaltstelle für weitere Analyse auf Refers, Images etc.
 '#

 Private Function TagSens(ByVal TAG$) As String
  If ErrorIgnore Then On Error Goto ERRTagSens
  Dim AA$, BB$
    
    AA = UCase(TAG)
    
    
    '### Test auf Links
    If InStr(1, AA, "HREF")Then
        BB = RefTag(TAG)
        If BB = "" Then
            If InStr(1, AA, "LINK")Then BB = LnkTag(TAG)
        End If
    ElseIf InStr(1, AA, "META")Then
        BB = MetTag(TAG)
    Else
        If InStr(1, AA, "NAME")Then BB = AncTag(TAG)
        If BB = "" And InStr(1, AA, "FRAME")Then BB = FrmTag(TAG)
    End If
    
    
    '### Test auf Image
    If InStr(1, AA, "IMG")And InStr(1, AA, "SRC")Then
        BB = ImgTag(TAG)
    ElseIf InStr(1, AA, "BACKGROUND")Then
        BB = BgrTag(TAG)
    End If
    
    
    '### Test auf HTML Kommentar
    If Left$(AA, 4) = "<!--" And Right$(AA, 3) = "-->" Then Call SaveComment(TAG)
  
    
    '### Test auf 'EMBED' & 'SOUND'
    If InStr(1, AA, "EMBED")Or InStr(1, AA, "BGSOUND")Then
       BB = EmbdTag(TAG)
    End If
  Exit Function

 '### Fehlerbehandlung
 ERRTagSens:
    Call ERRSTACK(Err.Number, Err.Description, "DeTager", "DelTag")
    Resume Next

 End Function



 '######################################################################
 '#
 '#  'GetTitel' Erfasst den Titel einse HTML Dokuments. Die Variable Del
 '#             gibt an ob der Titel aus dem HTML-TEXT gelöscht werden
 '#             soll oder nicht. Die Funktion gibt den HMTL-Text zurück
 '#

 Private Function GetTitle(ByVal HTML$, ByVal Del As Boolean) As String
  If ErrorIgnore Then On Error Goto ERRGetTitle
  Dim AA$, BB$, CC$, U&, x&, y&, z&, A1&, A2&, B1&, B2&
    GetTitle = HTML
    AA = UCase(HTML)
    Result.Title = ""
    x = 1
    
    
    '### Schleife, um bei doppelter Title Dekleration alle Title zu erfassen
    Do While x < Len(HTML$)
    
        '### Prüfen ob TITLE-Tag vorhanden ist
        y = InStr(x, AA, "TITLE")
        If y = 0 Then Exit Function
        z = InStr(y + 6, AA, "/TITLE")
        If z = 0 Then Exit Function
        
        
        '### Herantasten an '<' von '<TITLE>'
        For U = y To 1 Step -1
            BB = Mid$(HTML, U, 1)
            A1 = U
            If BB = "<" Then Exit For
        Next U
        
        
        '### Herantasten an '>' von '</TITLE>'
        For U = z To Len(AA)
            B2 = U
            BB = Mid$(HTML, U, 1)
            If BB = ">" Then Exit For
        Next U
        
        
        '### Aussschneiden der Title-Dekleration
        CC = DeSpace(Mid$(AA, A1, B2 - A1 + 1), "")
        If Left$(CC, 7) = "<TITLE>" And Right$(CC, 8) = "</TITLE>" Then
            '### Syntax der Title-Dekleration scheint soweit in Ordnung:
            
            '### Herantasten an '>' von '<TITLE>'
            For U = y To Len(HTML)
                BB = Mid$(HTML, U, 1)
                A2 = U + 1
                If BB = ">" Then Exit For
            Next U
            
            
            '### Herantasten an '<' von '</TITLE>'
            For U = z To 1 Step -1
                BB = Mid$(HTML, U, 1)
                B1 = U - 1
                If BB = "<" Then Exit For
            Next U
            
            If A2 < B1 Then
                '### Syntax der Title-Dekleration ist endgültig in Ordnung:
                Result.Title = Result.Title & Mid$(HTML, A2, B1 - A2 + 1)
                If Del Then
                    '### Da 'Del' gesetzt ist, wird die Title-Delkleration elemeniert
                    HTML = Left$(HTML, A1 - 1) & Mid$(HTML, B2 + 1, Len(HTML))
                    GetTitle = HTML
                    AA = UCase(HTML)

                   '### Position zurücksetzen da Title gelöscht wurde und
                    '    die Position weiter unten wieder erhöht wird (x=z+7-7=z)
                    z = A1 - 7
                End If
            End If
        End If
        x = z + 7
    Loop
  Exit Function


 '### Fehlerbehandlung
 ERRGetTitle:
    Call ERRSTACK(Err.Number, Err.Description, "DeTager", "GetTitle")
    Resume Next

 End Function


 '######################################################################
 '#
 '#  'ASCTausch' reguliert den Umgang mit HTML Sonder- und ASCIIzeichen,
 '#              Im speziellen setzt diese Funktion ASCII und Sonderzei-
 '#              chen aus der HTML-Syntax in normalen Text um
 '#

 Private Function ASCTausch(ByVal HTML$) As String
  If ErrorIgnore Then On Error Goto ERRASCTausch
    HTML = TauschString(HTML, "&nbsp;", " ")
    HTML = TauschString(HTML, "&quot;", Chr$(34))
    HTML = TauschString(HTML, "&auml;", "ä")
    HTML = TauschString(HTML, "&Auml;", "Ä")
    HTML = TauschString(HTML, "&ouml;", "ö")
    HTML = TauschString(HTML, "&Ouml;", "Ö")
    HTML = TauschString(HTML, "&uuml;", "ü")
    HTML = TauschString(HTML, "&Uuml;", "Ü")
    HTML = TauschString(HTML, "&szlig;", "ß")
    HTML = TauschString(HTML, "&amp;", "&")
    HTML = TauschString(HTML, "&lt;", "<")
    HTML = TauschString(HTML, "&gt;", ">")
    HTML = TauschString(HTML, "&copy;", "Copyright")
    HTML = TauschString(HTML, "&reg;", "Eingetragenes Warenzeichen")
    HTML = ASCRechnung(HTML)
    ASCTausch = HTML
  Exit Function


 '### Fehlerbehandlung
 ERRASCTausch:
    Call ERRSTACK(Err.Number, Err.Description, "DeTager", "ASCTasch")
    Resume Next
 End Function



 '######################################################################
 '#
 '#  'ASCReTausch' Gegenstück zur Funktion ASCTausch. Wird eigentlich
 '#                im Modul DeTager nicht benötigt. Ist aber der voll-
 '#                stänigkeithalber als kleines Bonbon mit eingebaut.
 '#                Im speziellen setzt diese Funktion Sonderzeichen in
 '#                die HTML-Syntax um.
 '#

 Public Function ASCReTausch(ByVal HTML$) As String
  If ErrorIgnore Then On Error Goto ERRASCReTausch
    HTML = TauschString(HTML, "&", "&amp;")
    HTML = TauschString(HTML, Chr$(34), "&quot;")
    HTML = TauschString(HTML, "ä", "&auml;")
    HTML = TauschString(HTML, "Ä", "&Auml;")
    HTML = TauschString(HTML, "ö", "&ouml;")
    HTML = TauschString(HTML, "Ö", "&Ouml;")
    HTML = TauschString(HTML, "ü", "&uuml;")
    HTML = TauschString(HTML, "Ü", "&Uuml;")
    HTML = TauschString(HTML, "ß", "&szlig;")
    HTML = TauschString(HTML, "<", "&lt;")
    HTML = TauschString(HTML, ">", "&gt;")
    ASCReTausch = HTML
  Exit Function


 '### Fehlerbehandlung
 ERRASCReTausch:
    Call ERRSTACK(Err.Number, Err.Description, "DeTager", "ASCReTasch")
    Resume Next
 End Function



 '######################################################################
 '#
 '#  'TauschString' kann einen vorgegeben String ('SUCH$')gegen einen
 '#                 anderen ('TAUSCH$') in einem Text ('HTML$')aus-
 '#                 tauschen.
 '#

 Private Function TauschString(ByVal HTML$, SUCH$, TAUSCH$) As String
  If ErrorIgnore Then On Error Goto ERRTauschString
  Dim x&, POS&
    
    x = 1
    Do While x < Len(HTML)
        POS = InStr(x, HTML, SUCH)
        If POS = 0 Then
            Exit Do
        Else
            HTML = Left$(HTML, POS - 1) & TAUSCH & Mid$(HTML, POS + Len(SUCH), Len(HTML))
            x = x + Len(TAUSCH)
        End If
    Loop
    TauschString = HTML
  Exit Function
    
    
 '### Fehlerbehandlung
 ERRTauschString:
    Call ERRSTACK(Err.Number, Err.Description, "DeTager", "TauschString")
    Resume Next
 End Function


 '######################################################################
 '#
 '#  'ASCRechnung' Rechnet HTML ASCII in die jeweiligen Textzeichen um
 '#
 Private Function ASCRechnung(ByVal HTML$) As String
  If ErrorIgnore Then On Error Goto ERRASCRechnung
  Dim FLAG As Boolean
  Dim y%, z%
  Dim x&, POS&, E&
  Dim ASCString$, AscChar$
    
    x = 1
    FLAG = False
    Do While x < Len(HTML)
        POS = InStr(x, HTML, "&")
        If POS = 0 Then
            '### Kein '&' mehr gefunden
            Exit Do
        Else
            If Mid$(HTML, POS + 1, 1) = "#" Then
                '### Kombination '&#' gefunden
                E = InStr(POS, HTML, ";")
                If E <> 0 And E - POS < 6 And E - POS > 2 Then
                    '### Kombination '&#.;' oder '&#..;' oder '&#...;' gefunden
                    ASCString = Mid$(HTML, POS + 2, E - POS - 2)
                    '### Prüfen ob '...' = Numerisch (0123456789)
                    For y = 1 To Len(ASCString)
                        z = Asc(Mid$(ASCString, y, 1))
                        If z < Asc("0")Or z > Asc("9")Then FLAG = True
                    Next y
                    
                    '### '...' in Zahl umwandeln und prüfen ob zwischen 0 & 255
                    z = Val(ASCString)
                    If FLAG = False And z > -1 And z < 256 Then
                        AscChar = Chr$(z)
                        '### ASC II in den Text einsetzen
                        HTML = Left$(HTML, POS - 1) & AscChar & Mid$(HTML, E + 1, _
                                                                     Len(HTML))
                    End If
                End If
            End If
            x = POS + 1
        End If
      
    Loop
    ASCRechnung = HTML
  Exit Function
    
    
 '### Fehlerbehandlung
 ERRASCRechnung:
    Call ERRSTACK(Err.Number, Err.Description, "DeTager", "ASCRechnung")
    Resume Next
 End Function


 '######################################################################
 '#
 '#  'EventHandler' regelt die Anzahl der DoEvents und den Progressbar
 '#                 Mit 'X&' wird die aktuelle Textposition übergeben
 '#

 Private Sub EventHandler(ByVal x&)
  If ErrorIgnore Then On Error Goto ERREventHandler
  Static LastPos&
  Static TaskCount&
  
    TaskCount = TaskCount + 1
    If TaskCount > Abs(TaskNum) Then
      '### Funktion 'EventHandler' wurde 'TaskCount' mal aufgerufen
      '    Es wird jetzt ein DoEvent zugelassen
      TaskCount = 0
      
      If TaskNum > 0 And LastPos <> x Then
         '### Progressbar soll aktualisiert werden, der Wert hat sich seit
         '    der letzen Aktualisierung geändert
         Progress.Value = x
         LastPos = x
      End If
      '### Ressourcen freigeben
      DoEvents
    End If
  Exit Sub


 '### Fehlerbehandlung
 ERREventHandler:
    Call ERRSTACK(Err.Number, Err.Description, "DeTager", "EventHandler")
    Resume Next
 End Sub



 '######################################################################
 '#
 '#  'ImgTag' analysiert den aktuellen Tag auf eine Bildressource hin
 '#

 Public Function ImgTag(ByVal TAG$) As String
  If ErrorIgnore Then On Error Goto ERRImgTag
  Dim AA$, UP$, AltTag$, Test As Boolean
 
    ImgTag = ""
    If TAG = "" Or Len(TAG) < 13 Then Exit Function '<imgsrc=1.au>
    
    AA = RMEOL(TAG)
    AA = DeSpace(AA, Chr$(34))
    UP = UCase(AA)
    If InStr(1, UP, "SRC=") = 0 Or Left$(UP, 4) <> "<IMG" Then Exit Function
    
    ImgTag = SRC_FINDER(TAG, "SRC")
    If InStr(1, UP, "ALT=") <> 0 Then AltTag = SRC_FINDER(TAG, "ALT")
    Test = GRFX_DOUBLE_FIND(ImgTag, AltTag, True)
  Exit Function


 '### Fehlerbehandlung
 ERRImgTag:
    Call ERRSTACK(Err.Number, Err.Description, "DeTager", "ImgTag")
    Resume Next
    
 End Function



 '######################################################################
 '#
 '#  'BgrTag' analysiert den aktuellen Tag auf eine Bildressource die
 '#           als Hintergrund im Body-Tag oder Table-Tag etc. auftritt
 '#           hin.
 '#

 Public Function BgrTag(ByVal TAG$) As String
  If ErrorIgnore Then On Error Goto ERRBgrTag
  Dim AA$, UP$, Test As Boolean
 
    BgrTag = ""
    If TAG = "" Or Len(TAG) < 17 Then Exit Function '<background=1.au>
    
    AA = RMEOL(TAG)
    AA = DeSpace(AA, Chr$(34))
    UP$ = UCase(AA)
    If InStr(1, UP, "BACKGROUND=") = 0 Then Exit Function
    
    BgrTag = SRC_FINDER(TAG, "BACKGROUND")
    Test = GRFX_DOUBLE_FIND(BgrTag, "",True)
  Exit Function


 '### Fehlerbehandlung
 ERRBgrTag:
    Call ERRSTACK(Err.Number, Err.Description, "DeTager", "BgrTag")
    Resume Next
    
 End Function



 '######################################################################
 '#
 '#  'RefTag' analysiert den aktuellen Tag auf eine Linkressource hin.
 '#

 Public Function RefTag(ByVal TAG$) As String
  If ErrorIgnore Then On Error Goto ERRRefTag
  Dim AA$, UP$, Test As Boolean
    
    RefTag = ""
    If TAG = "" Or Len(TAG) < 13 Then Exit Function '<ahref=1.htm>
    
    AA = RMEOL(TAG)
    AA = DeSpace(AA, Chr$(34))
    UP$ = UCase(AA)
    If InStr(1, UP, "HREF=") = 0 Or Left$(UP, 2) <> "<A" Then Exit Function
    
    RefTag = SRC_FINDER(TAG, "HREF")
    If RefTag <> "" Then AA = SRC_FINDER(TAG, "TARGET")
    If RefTag <> "" Then Test = REF_DOUBLE_FIND(RefTag, True)
    If AA <> "" Then Test = TAR_DOUBLE_FIND(AA, True)
  Exit Function


 '### Fehlerbehandlung
 ERRRefTag:
    Call ERRSTACK(Err.Number, Err.Description, "DeTager", "RefTag")
    Resume Next
    
 End Function



 '######################################################################
 '#
 '#  'EmbdTag' analysiert den aktuellen Tag auf eine Embededressource hin.
 '#

 Public Function EmbdTag(ByVal TAG$) As String
  If ErrorIgnore Then On Error Goto ERREmbdTag
  Dim AA$, UP$, Test As Boolean
    
    EmbdTag = ""
    If TAG = "" Or Len(TAG) < 15 Then Exit Function '<EMBED SRC=x.m>
    
    AA = RMEOL(TAG)
    AA = DeSpace(AA, Chr$(34))
    UP$ = UCase(AA)
    If InStr(1, UP, "SRC=") = 0 Or _
       ((Left$(UP, 6) <> "<EMBED")And (Left$(UP, 8) <> "<BGSOUND")) Then Exit Function
    EmbdTag = SRC_FINDER(TAG, "SRC")
    If EmbdTag <> "" Then Test = REF_DOUBLE_FIND(EmbdTag, True)
  Exit Function


 '### Fehlerbehandlung
 ERREmbdTag:
    Call ERRSTACK(Err.Number, Err.Description, "DeTager", "EmbdTag")
    Resume Next
    
 End Function



 '######################################################################
 '#
 '#  'AncTag' analysiert den aktuellen Tag auf einen Anker in der
 '#           aktuellen Seite hin
 '#

 Public Function AncTag(ByVal TAG$) As String
  If ErrorIgnore Then On Error Goto ERRAncTag
  Dim AA$, UP$, Test As Boolean
    AncTag = ""
    If TAG = "" Or Len(TAG) < 9 Then Exit Function '<aname=1>
    
    AA = RMEOL(TAG)
    AA = DeSpace(AA, Chr$(34))
    UP$ = UCase(AA)
    If InStr(1, UP, "NAME=") = 0 Or Left$(UP, 2) <> "<A" Then Exit Function
    
    AncTag = SRC_FINDER(TAG, "NAME")
    If AncTag <> "" Then Test = ANC_DOUBLE_FIND(AncTag, True)
  Exit Function


 '### Fehlerbehandlung
 ERRAncTag:
    Call ERRSTACK(Err.Number, Err.Description, "DeTager", "AncTag")
    Resume Next
    
 End Function



 '######################################################################
 '#
 '#  'FrmTag' analysiert den aktuellen Tag auf einen Frameset hin
 '#

 Public Function FrmTag(ByVal TAG$) As String
  If ErrorIgnore Then On Error Goto ERRFrmTag
  Dim AA$, UP$, Test As Boolean
 
    FrmTag = ""
    If TAG = "" Or Len(TAG) < 16 Then Exit Function '<FRAMESRC=1.htm>
    
    AA = RMEOL(TAG)
    AA = DeSpace(AA, Chr$(34))
    UP$ = UCase(AA)
    If InStr(1, UP, "SRC=") = 0 Or Left$(UP, 6) <> "<FRAME" Then Exit Function
    
    FrmTag = SRC_FINDER(TAG, "SRC")
    If FrmTag <> "" Then AA = SRC_FINDER(TAG, "NAME")
    If FrmTag <> "" Then Test = REF_DOUBLE_FIND(FrmTag, True)
    If AA <> "" Then Test = TAR_DOUBLE_FIND(AA, True)
  Exit Function


 '### Fehlerbehandlung
 ERRFrmTag:
    Call ERRSTACK(Err.Number, Err.Description, "DeTager", "FrmTag")
    Resume Next
    
 End Function



 '######################################################################
 '#
 '#  'LnkTag' analysiert den aktuellen Tag auf einen Linktag hin
 '#

 Public Function LnkTag(ByVal TAG$) As String
  If ErrorIgnore Then On Error Goto ERRLnkTag
  Dim AA$, UP$, Test As Boolean
 
    LnkTag = ""
    If TAG = "" Or Len(TAG) < 14 Then Exit Function '<linksrc=1.dd>
    
    AA = RMEOL(TAG)
    AA = DeSpace(AA, Chr$(34))
    UP$ = UCase(AA)
    If InStr(1, UP, "HREF=") = 0 Or Left$(UP, 5) <> "<LINK" Then Exit Function
    
    LnkTag = SRC_FINDER(TAG, "HREF")
    If LnkTag <> "" Then Test = REF_DOUBLE_FIND(LnkTag, True)
  Exit Function


 '### Fehlerbehandlung
 ERRLnkTag:
    Call ERRSTACK(Err.Number, Err.Description, "DeTager", "LnkTag")
    Resume Next
    
 End Function



 '######################################################################
 '#
 '#  'MetTag' analysiert den aktuellen Tag auf eine Metatags wie De-
 '#           scription, Keywords und dem Link-Refreshtag hin
 '#

 Public Function MetTag(ByVal TAG$) As String
  If ErrorIgnore Then On Error Goto ERRMetTag
  Dim AA$, UP$, Test As Boolean

    MetTag = ""
    If TAG = "" Or Len(TAG) < 30 Then Exit Function '<META NAME=KEYWORDS CONTENT=X>
    
    AA = RMEOL(TAG)
    AA = DeSpace(AA, Chr$(34))
    UP$ = UCase(AA)
    If InStr(1, UP, "CONTENT") = 0 Or Left$(UP, 5) <> "<META" Then Exit Function
    
    If InStr(1, UP, "HTTP-EQUIV") <> 0 And InStr(1, UP, "REFRESH") <> 0 _
    And InStr(1, UP, "URL") <> 0 Then
         MetTag = GetMetaContent(TAG)
         If MetTag <> "" Then Test = REF_DOUBLE_FIND(MetTag, True)
    Else
         If Left$(UP, 10) = "<METANAME=" Then
             AA = DeSpace(RMEOL(TAG), "")
             UP = UCase(AA)
             MetTag = ASCTausch(GetMetaContent(TAG))
             If MetTag <> "" Then
                If InStr(1, UP, "NAME=" & Chr$(34) & "DESCRIPTION" & Chr$(34)) _
                Or InStr(1, UP, "NAME=DESCRIPTION")Then
                    Result.MetaDescription = Result.MetaDescription & MetTag
                ElseIf InStr(1, UP, "NAME=" & Chr$(34) & "KEYWORDS" & Chr$(34)) _
                Or InStr(1, UP, "NAME=KEYWORDS")Then
                    Result.MetaKeywords = Result.MetaKeywords & MetTag
                ElseIf InStr(1, UP, "NAME=" & Chr$(34) & "REVISIT-AFTER" & Chr$(34)) _
                Or InStr(1, UP, "NAME=REVISIT-AFTER")Then
                    Result.MetaRevisit = Result.MetaRevisit & MetTag
                ElseIf InStr(1, UP, "NAME=" & Chr$(34) & "CONTENT-LANGUAGE" & Chr$(34)) _
                Or InStr(1, UP, "CONTENT-LANGUAGE")Then
                    Result.MetaLanguage = Result.MetaLanguage & MetTag
                End If
             End If
         End If
    End If
  Exit Function


 '### Fehlerbehandlung
 ERRMetTag:
    Call ERRSTACK(Err.Number, Err.Description, "DeTager", "MetTag")
    Resume Next
    
 End Function



 '######################################################################
 '#
 '#  'GetMetaContent' filtert aus dem aktuellen Tag, speziell dem Metatag
 '#                   den CONTENT herraus
 '#

 Private Function GetMetaContent(ByVal TAG$) As String
  If ErrorIgnore Then On Error Goto ERRGetMetaContent
  Dim Content$, x&, y&, AA$
    Content = SRC_FINDER(TAG, "CONTENT")
    y = InStr(1, Content, "=")
    If y Then
      For x = y + 1 To Len(Content)
        AA = Mid$(Content, x, 1)
        If InStr(1, FORBIDDEN, AA) = 0 Then Exit For
      Next x
      Content = Mid$(Content, x, Len(Content))
    End If
    GetMetaContent = Content
  Exit Function


 '### Fehlerbehandlung
 ERRGetMetaContent:
    Call ERRSTACK(Err.Number, Err.Description, "DeTager", "GetMetaContent")
    Resume Next
    
 End Function



 '######################################################################
 '#
 '#  'GRFX_DOUBLE_FIND' prüft ob eine Grafikressource bereits vorhanden
 '#                     ist, trägt unbekannte in die entsprechende Liste
 '#                     ein bzw. zählt deren Häufigkeit mit.
 '#

 Private Function GRFX_DOUBLE_FIND(ByVal Path$, ByVal Alt$, ADD As Boolean) As Boolean
  If ErrorIgnore Then On Error Goto ERRGRFX_DOUBLE_FND
  Dim x&, y&
    
    If Result.ImageListCount Then
      For x = 0 To Result.ImageListCount - 1
        If Result.ImageList(x) = Path Then
          GRFX_DOUBLE_FIND = True
          If InStr(1, Result.AlterList(x), Alt) = 0 And Alt <> "" Then
            Result.AlterList(x) = Result.AlterList(x) & "<>" & Alt
          End If
          Result.ImageMass(x) = Result.ImageMass(x) + 1
          Exit Function
        End If
      Next x
    Else
    ReDim Result.ImageList(0)
    Result.ImageListCount = 0
    End If
    
    If ADD Then
      
      ReDim Preserve Result.ImageList(0 To Result.ImageListCount)
      ReDim Preserve Result.AlterList(0 To Result.ImageListCount)
      ReDim Preserve Result.ImageMass(0 To Result.ImageListCount)
      Result.ImageList(Result.ImageListCount) = Path
      Result.AlterList(Result.ImageListCount) = Alt
      Result.ImageMass(Result.ImageListCount) = 1
      Result.ImageListCount = Result.ImageListCount + 1
    End If
    GRFX_DOUBLE_FIND = False
  Exit Function


 '### Fehlerbehandlung
 ERRGRFX_DOUBLE_FND:
    Call ERRSTACK(Err.Number, Err.Description, "DeTager", "GRFX_DOUBLE_FND")
    Resume Next   
 End Function



 '######################################################################
 '#
 '#  'REF_DOUBLE_FIND' prüft ob eine Linkressource bereits vorhanden ist
 '#                    trägt unbekannte in die entsprechende Liste ein
 '#                    bzw. zählt deren Häufigkeit mit.
 '#

 Private Function REF_DOUBLE_FIND(ByVal Path$, ADD As Boolean) As Boolean
  If ErrorIgnore Then On Error Goto ERRREF_DOUBLE_FND
  Dim x&, y&

    If Result.ReferListCount Then
      For x = 0 To Result.ReferListCount - 1
        If Result.ReferList(x) = Path Then
          REF_DOUBLE_FIND = True
          Result.ReferMass(x) = Result.ReferMass(x) + 1
          Exit Function
        End If
      Next x
    Else
      ReDim Result.ReferList(0)
      Result.ReferListCount = 0
    End If
    
    If ADD Then
      ReDim Preserve Result.ReferList(0 To Result.ReferListCount)
      ReDim Preserve Result.ReferMass(0 To Result.ReferListCount)
      Result.ReferList(Result.ReferListCount) = Path
      Result.ReferMass(Result.ReferListCount) = 1
      Result.ReferListCount = Result.ReferListCount + 1
    End If
    REF_DOUBLE_FIND = False
  Exit Function


 '### Fehlerbehandlung
 ERRREF_DOUBLE_FND:
    Call ERRSTACK(Err.Number, Err.Description, "DeTager", "REF_DOUBLE_FND")
    Resume Next
    
 End Function



 '######################################################################
 '#
 '#  'ANC_DOUBLE_FIND' prüft ob ein Anker bereits vorhanden ist, trägt
 '#                    unbekannte in die entsprechende Liste ein bzw.
 '#                    zählt deren Häufigkeit mit.
 '#

 Private Function ANC_DOUBLE_FIND(ByVal Path$, ADD As Boolean) As Boolean
  If ErrorIgnore Then On Error Goto ERRANC_DOUBLE_FND
  Dim x&, y&
    
    If Result.AncorListCount Then
      For x = 0 To Result.AncorListCount - 1
        If Result.AncorList(x) = Path Then
          ANC_DOUBLE_FIND = True
          Exit Function
        End If
      Next x
    Else
      ReDim Result.AncorList(0)
      Result.AncorListCount = 0
    End If
    
    If ADD Then
      ReDim Preserve Result.AncorList(0 To Result.AncorListCount)
      Result.AncorList(Result.AncorListCount) = Path
      Result.AncorListCount = Result.AncorListCount + 1
    End If
    ANC_DOUBLE_FIND = False
  Exit Function


 '### Fehlerbehandlung
 ERRANC_DOUBLE_FND:
    Call ERRSTACK(Err.Number, Err.Description, "DeTager", "ANC_DOUBLE_FND")
    Resume Next
    
 End Function



 '######################################################################
 '#
 '#  'TAR_DOUBLE_FIND' prüft ob ein Link-Target bereits vorhanden ist,
 '#                    trägt unbekannte in die entsprechende Liste ein
 '#                    bzw. zählt deren Häufigkeit mit.
 '#

 Private Function TAR_DOUBLE_FIND(ByVal Path$, ADD As Boolean) As Boolean
  If ErrorIgnore Then On Error Goto ERRTAR_DOUBLE_FND
  Dim x&, y&
    
    If Result.TargetListCount Then
      For x = 0 To Result.TargetListCount - 1
        If Result.TargetList(x) = Path Then
          TAR_DOUBLE_FIND = True
          Result.TargetMass(x) = Result.TargetMass(x) + 1
          Exit Function
        End If
      Next x
    Else
      ReDim Result.TargetList(0)
      Result.TargetListCount = 0
    End If
    
    If ADD Then
      ReDim Preserve Result.TargetList(0 To Result.TargetListCount)
      ReDim Preserve Result.TargetMass(0 To Result.TargetListCount)
      Result.TargetList(Result.TargetListCount) = Path
      Result.TargetMass(Result.TargetListCount) = 1
      Result.TargetListCount = Result.TargetListCount + 1
    End If
    TAR_DOUBLE_FIND = False
  Exit Function


 '### Fehlerbehandlung
 ERRTAR_DOUBLE_FND:
    Call ERRSTACK(Err.Number, Err.Description, "DeTager", "TAR_DOUBLE_FND")
    Resume Next
    
 End Function



 '######################################################################
 '#
 '#  'ERRSTACK' Speichert alle vom Modul verursachten internen Fehler
 '#             in dem dafür vorgesehenen Stack auf
 '#

 Public Sub ERRSTACK(ByVal ERRNO%, ByVal ERRSTRING$, ByVal MODUL$, ByVal FUNKTION$)
  ReDim Preserve Result.ErrorList(Result.ErrorListCount)
  Result.ErrorList(Result.ErrorListCount) = Str(ERRNO) & " " & ERRSTRING & " " _
                                            & MODUL & " " & FUNKTION
  Result.ErrorListCount = Result.ErrorListCount + 1
 End Sub



 '######################################################################
 '#
 '#  'RMEOL' Entfernt alle Zeileumbrüche aus einem Text
 '#

 Public Function RMEOL(ByVal TXT$) As String
  If ErrorIgnore Then On Error Goto ERRRMEOL
  Dim x&
  Dim AA$, BB$
   
    If TXT = "" Or (InStr(1, TXT, Chr$(13)) = 0 And InStr(1, TXT, Chr$(10))) Then
      RMEOL = TXT
      Exit Function
    End If
    
    For x = 1 To Len(TXT)
      AA = Mid$(TXT, x, 1)
      If AA <> "" And AA <> Chr$(10) And AA <> Chr$(13) Then BB = BB & AA
    Next x
    
    RMEOL = BB
  Exit Function


 '### Fehlerbehandlung
 ERRRMEOL:
    Call ERRSTACK(Err.Number, Err.Description, "DeTager", "RMEOL")
    Resume Next
    
 End Function



 '######################################################################
 '#
 '#  'DeSpace' Entfernt alle Leerzeichen aus einem Text. Ausgenommen
 '#            wird der Text der von zwei Trennzeichen (definiert durch
 '#            den String Zeichen) umschlossen wird.
 '#            Wird Zeichen="" übergeben werden ausnahmslos alle Leer-
 '#            zeichen eleminiert.
 '#

 Public Function DeSpace(ByVal TXT$, ByVal ZEICHEN$) As String
  If ErrorIgnore Then On Error Goto ERRDeSpace
  Dim x&
  Dim AA$, BB$
  Dim ZA As Boolean
    
    If TXT = "" Then
        '### Es wurde ein leerer Text an die Funktion übergeben, daher Abbruch
        DeSpace = TXT
        Exit Function
    End If
    
    
    If ZEICHEN = "" Then
        '### Kein Trennzeichen übergeben
        For x = 1 To Len(TXT)
            BB = Mid$(TXT, x, 1)
            '### Alle ' ' übergehen
            If BB <> Chr$(32) And BB <> Chr$(160) Then AA = AA & BB
        Next x
        DeSpace = AA
        Exit Function
    End If
        
    '### Trennzeichen vorhanden
    For x = 1 To Len(TXT)
        AA = Mid$(TXT, x, 1)
        If ZA Then
            '### Flag für öffnendes Zeichen gesetzt
            If AA = ZEICHEN Then
                '### Schließendes Zeichen gefunden
                BB = BB + AA
                ZA = False
            Else
                '### Schließendes Zeichen nicht gefunden, $ bedingungslos aufsummieren
                BB = BB + AA
            End If
        ElseIf AA = ZEICHEN Then
            '### Flag für öffendes Zeichen nicht gesetzt, aber öffendes Zeichen
            '    gefunden -> Flag für öffendes Zeichen setzen
            ZA = True
            BB = BB + AA
        Else
            '### Text außerhalb der Zeicheumklammerung -> alle ' ' übergehen
            If AA <> Chr$(32) And AA <> Chr$(160) Then BB = BB + AA
        End If
    Next x
    
    DeSpace = BB
  Exit Function


 '### Fehlerbehandlung
 ERRDeSpace:
    Call ERRSTACK(Err.Number, Err.Description, "DeTager", "DeSpace")
    Resume Next
    
 End Function



 '######################################################################
 '#
 '#  'SRC_FINDER' Findet eine Ressource die durch LABEL$ näher spezifiziert
 '#               wird. Als Begrenzung für die Ressource werden Leerzeichen
 '#               bzw. Anführungszeichen anerkannt.
 '#

 Public Function SRC_FINDER(ByVal TAG$, LABEL$) As String
  If ErrorIgnore Then On Error Goto ERRSRC_FINDER
  Dim POS&, K1&, K2&, L&, MimePos&, Test&, x&
  Dim UPC$, AA$, BB$
  Dim MimeFlag As Boolean, FLAG As Boolean
      
    POS = 1
    UPC = UCase(TAG)
    
    Do While POS < Len(UPC)
        
        '### Testen auf Chr(34)
        K1 = InStr(POS, UPC, Chr$(34))
        If K1 <> 0 Then
            K2 = InStr(K1 + 1, UPC, Chr$(34))
        End If
        
        
        If K1 = 0 Then
            '### Kein Chr(34) vorhanden, es wird nach dem Label gesucht
            L = InStr(1, UPC, LABEL)
            Exit Do
        ElseIf K2 = 0 Then
            '### Es ist zwar ein öffnendes Chr(34) aber kein schleißendes vorhanden
            Exit Do
        Else
            '### Öffnendes und schließendes Chr(34) vorhanden, Labelsuche
            L = InStr(POS, UPC, LABEL)
            '### Wenn das Label gefunden wurde, das vor dem öffnenden
            '    Chr(34) steht, wird die Schleife verlassen
            If L = 0 Or L < K1 Then Exit Do
            POS = K2 + 1
        End If
    Loop
    
    
    '### Position des Labels in 'L&', falls kein Label gefunden wurde
    '    ist 'L&' gleich Null
    If L Then
        '### Label vorhanden, alles vor dem Label abschneiden und in 'AA$' ablegen
        AA = LTrim$(Mid$(TAG, L + Len(LABEL), Len(TAG)))
        
        '### Alle überflüssigen Zeichen hinter dem Label überspringen.
        '    Wird das Zuweisungszeichen '=' gefunden und befindet sich ein
        '    überflüssiges Zeichen dazwischen, wird 'Flag' gesetzt
        For x = 1 To Len(AA)
            BB = Mid$(AA, x, 1)
            Test = InStr(1, FORBIDDEN, BB)
            If Test Then
                '### Überflüssiges Zeichen gefunden
                FLAG = True
            ElseIf BB = "=" Then
                '### Trennzeichen '=' gefunden; Schleife verlassen,
                '    Position+1 in 'X' merken
                x = x + 1
                Exit For
            Else
                '### Ungültiges Zeichen zwischen Label und Trennzeichen gefunden -> Fehler
                Exit Function
            End If
        Next x
        
        '### Nur den Text ab dem Trennzeichen '=' übernehmen
        AA = LTrim$(Mid$(AA, x, Len(AA)))
                
        '### Herantasten an den eigentlichen Parameter (überspringen von Leerzeichen etc.)
        For x = 1 To Len(AA)
            BB = Mid$(AA, x, 1)
            If InStr(1, FORBIDDEN, BB) = 0 Then Exit For
        Next x
        '### Text vor dem Parameter abschneiden
        AA = Mid$(AA, x, Len(AA))
        
        
        If Left$(AA, 1) = Chr$(34) Then
            '### Erstes Zeichen des Parameters ist ein Chr(34)
            K2 = InStr(2, AA, Chr$(34))
            '### Wenn schließendes Chr(34) gefunden, Parameter ausschneiden
            If K2 Then SRC_FINDER = Mid$(AA, 2, K2 - 2)
            Exit Function
        Else
            '### Erstes Zeichen kein Chr(34) -> letzes Zeichen = ' ' oder '>'
            For x = 1 To Len(AA)
                BB = Mid$(AA, x, 1)
                If BB = "." Then
                    '### Punkt gefunden, könnte eventuell Zeichen für die Extension sein.
                    '    Daher Position merken und Extensionflag setzen!
                    MimeFlag = True
                    MimePos = x
                End If
                
                If (BB = " " Or BB = ">")And MimeFlag = True Then
                    '### Letztes Zeichen gefunden (' ' oder '>') und Extensionflag gesetzt
                    '    Jetzt noch auf '#' Prüfen (ob es sich um einen Anker handelt)
                    K2 = InStr(MimePos + 1, AA, "#")
                    If K2 = 0 Or K2 < x Then
                        '### Kein Anker, Endposition um eine Stelle verkleinern
                        x = x - 1
                    Else
                        '### Anker, Parameter unwichtig -> x=0
                        x = 0
                    End If
                    Exit For
                End If
            Next x
            '### Parameter ausschneiden
            SRC_FINDER = Left$(AA, x)
        End If
    End If
  Exit Function


 '### Fehlerbehandlung
 ERRSRC_FINDER:
    Call ERRSTACK(Err.Number, Err.Description, "DeTager", "SRC_FINDER")
    Resume Next
    
 End Function