Quellcode
Option Explicit
Public Type DetagerType HtmlText As String BlockingRate As Long DoEventsRate As Integer ProgressBar As Control ErrorString As String ErrorIgnore As Boolean MakeText As Boolean MakeTags As Boolean End Type
Public Type DetagerResultType Text As String ImageListCount As Long ImageList() As String ImageMass() As Integer AlterList() As String ReferListCount As Long ReferList() As String ReferMass() As Integer AncorListCount As Long AncorList() As String TargetListCount As Long TargetList() As String TargetMass() As Integer CommentListCount As Long CommentList() As String ErrorListCount As Long ErrorList() As String HTMLErrorCount As Long Title As String MetaDescription As String MetaKeywords As String MetaLanguage As String Java As String MetaRevisit As String End Type
Private AllowTasks As Boolean Private TaskNum% Private ERRTxt$ Private Progress As Control Private ErrorIgnore As Boolean Private BLOCK$(), BLOCKCNT& Private Result As DetagerResultType Private LIMIT& Private FORBIDDEN$ Public DeTagerActive As Boolean
Public Function Detag(DOC As DetagerType) As DetagerResultType
If DOC.ErrorIgnore Then If ErrorIgnore Then On Error Goto ERRDeTag
Dim x&, AA$
If DeTagerActive = True Then
Exit Function
Else
DeTagerActive = True
End If
FORBIDDEN = Chr$(9) & Chr$(10) & Chr$(13) & Chr$(32) & Chr$(160)
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 = ""
BLOCKCNT = 0
ERRTxt = DOC.ErrorString
TaskNum = DOC.DoEventsRate
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
If Abs(TaskNum) <> 0 Then
AllowTasks = True
If TaskNum > 0 Then
Set Progress = DOC.ProgressBar
Progress.Min = 0
Progress.Value = 0
If Len(DOC.HtmlText) > 0 Then Progress.Max = Len(DOC.HtmlText)
End If
Else
AllowTasks = False
End If
LIMIT = DOC.BlockingRate
If LIMIT < 1 Or LIMIT > 500000 Then Exit Function
ReDim BLOCK(0 To Len(DOC.HtmlText) / LIMIT + 10)
DOC.HtmlText = GetTitle(DOC.HtmlText, DOC.MakeText)
If DOC.MakeText Then
Call DelTag(DOC.HtmlText, DOC.MakeTags)
For x = 0 To BLOCKCNT - 1
Call DeBLock(x)
Result.Text = Result.Text & BLOCK(x)
Next x
Else
Call GetTag(DOC.HtmlText)
End If
Detag = Result
DeTagerActive = False
Exit Function
ERRDeTag:
Call ERRSTACK(Err.Number, Err.Description, "DeTager", "DeTag")
Resume Next
End Function
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)
If x <> 0 Then
If Len(BLOCK(x - 1)) > 1 Then
BB = Right$(BLOCK(x - 1), 1)
If BB = Chr$(13) Or BB = Chr$(10) Then
For y = Len(BLOCK(x - 1)) To 1 Step -1
BB = Mid$(BLOCK(x - 1), y, 1)
If InStr(1, FORBIDDEN, BB) = 0 Then Exit For
Next y
BLOCK(x - 1) = RTrim$(Left$(BLOCK(x), y)) & Chr$(13) & Chr$(10)
EOLflag = True
End If
End If
End If
If EOLflag Or x = 0 Then
For y = 1 To Len(AA)
BB = Mid$(AA, y, 1)
If InStr(1, FORBIDDEN, BB) = 0 Then Exit For
Next y
AA = LTrim$(Mid$(AA, y, Len(AA)))
Else
BB = Left$(LTrim$(AA), 1)
If BB = Chr$(13) Or BB = Chr$(10) Then
BLOCK(x - 1) = BLOCK(x - 1) & Chr$(13) & Chr$(10)
For y = 1 To Len(AA)
BB = Mid$(AA, y, 1)
If InStr(1, FORBIDDEN, BB) = 0 Then Exit For
Next y
AA = Mid$(AA, y, Len(AA))
End If
End If
Do While POS < Len(AA)
P1 = InStr(POS, AA, Chr$(10))
P2 = InStr(POS, AA, Chr$(13))
If P1 = 0 And P2 = 0 Then
BLOCK(x) = AA
Exit Sub
End If
If (P1 < P2 And P1 <> 0) Or P2 = 0 Then
P = P1
Else
P = P2
End If
CC = Left$(AA, P - 1) & Chr$(13) & Chr$(10)
POS = P + 2
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
AA = CC & Mid$(AA, z, Len(AA))
Loop
BLOCK(x) = AA
Exit Sub
ERRDeBlock:
Call ERRSTACK(Err.Number, Err.Description, "DeTager", "DeBlock")
Resume Next
End Sub
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)
TAG1 = InStr(POS, HTML, "<")
If TAG1 = 0 Then
If TAG2 = 0 Then TAG2 = S - 1
TXT = MakeBlock(TXT & ASCTausch(Mid$(HTML, TAG2 + 1, Len(HTML))), True)
Exit Function
End If
TAG2 = InStr(TAG1, HTML, ">")
If TAG2 = 0 Then
DelTag = MakeBlock(TXT & ASCTausch(Mid$(HTML, S, Len(HTML))), True)
Exit Function
End If
TestTag = InStr(TAG1 + 1, HTML, "<")
If (TestTag > TAG2) Or TestTag = 0 Then
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
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
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
COM = Mid$(HTML, TAG1, TAG3 - TAG1 + 3)
Call SaveComment(COM)
TAG2 = TAG3 + 2
End If
End If
POS = TAG2 + 1
S = POS
If AllowTasks Then Call EventHandler(POS)
Loop
DelTag = MakeBlock(TXT & ASCTausch(Mid$(HTML, TAG2 + 1, Len(HTML))), True)
Exit Function
ERRDelTag:
Call ERRSTACK(Err.Number, Err.Description, "DeTager", "DelTag")
Resume Next
End Function
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
ERRSaveComment:
Call ERRSTACK(Err.Number, Err.Description, "DeTager", "SaveComment")
Resume Next
End Sub
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
TAG2 = InStr(TAG1, HTML, ">")
If TAG2 = 0 Then Exit Function
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
ERRGetTag:
Call ERRSTACK(Err.Number, Err.Description, "DeTager", "GetTag")
Resume Next
End Function
Private Function MakeBlock(ByVal Text$, Ende As Boolean) As String
If ErrorIgnore Then On Error Goto ERRMakeBlock
Dim x&, AA$
If UBound(BLOCK) < BLOCKCNT + 3 Then
ReDim Preserve BLOCK(0 To BLOCKCNT + 10)
End If
For x = 1 To Len(Text) - LIMIT Step LIMIT
BLOCK(BLOCKCNT) = Mid$(Text, x, LIMIT)
BLOCKCNT = BLOCKCNT + 1
Next x
AA = Mid$(Text, x, LIMIT)
If Ende Then
BLOCK(BLOCKCNT) = AA
BLOCKCNT = BLOCKCNT + 1
End If
MakeBlock = AA
Exit Function
ERRMakeBlock:
Call ERRSTACK(Err.Number, Err.Description, "DeTager", "MakeBlock")
Resume Next
End Function
Private Function TagSens(ByVal TAG$) As String
If ErrorIgnore Then On Error Goto ERRTagSens
Dim AA$, BB$
AA = UCase(TAG)
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
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
If Left$(AA, 4) = "<!--" And Right$(AA, 3) = "-->" Then Call SaveComment(TAG)
If InStr(1, AA, "EMBED")Or InStr(1, AA, "BGSOUND")Then
BB = EmbdTag(TAG)
End If
Exit Function
ERRTagSens:
Call ERRSTACK(Err.Number, Err.Description, "DeTager", "DelTag")
Resume Next
End Function
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
Do While x < Len(HTML$)
y = InStr(x, AA, "TITLE")
If y = 0 Then Exit Function
z = InStr(y + 6, AA, "/TITLE")
If z = 0 Then Exit Function
For U = y To 1 Step -1
BB = Mid$(HTML, U, 1)
A1 = U
If BB = "<" Then Exit For
Next U
For U = z To Len(AA)
B2 = U
BB = Mid$(HTML, U, 1)
If BB = ">" Then Exit For
Next U
CC = DeSpace(Mid$(AA, A1, B2 - A1 + 1), "")
If Left$(CC, 7) = "<TITLE>" And Right$(CC, 8) = "</TITLE>" Then
For U = y To Len(HTML)
BB = Mid$(HTML, U, 1)
A2 = U + 1
If BB = ">" Then Exit For
Next U
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
Result.Title = Result.Title & Mid$(HTML, A2, B1 - A2 + 1)
If Del Then
HTML = Left$(HTML, A1 - 1) & Mid$(HTML, B2 + 1, Len(HTML))
GetTitle = HTML
AA = UCase(HTML)
z = A1 - 7
End If
End If
End If
x = z + 7
Loop
Exit Function
ERRGetTitle:
Call ERRSTACK(Err.Number, Err.Description, "DeTager", "GetTitle")
Resume Next
End Function
Private Function ASCTausch(ByVal HTML$) As String
If ErrorIgnore Then On Error Goto ERRASCTausch
HTML = TauschString(HTML, " ", " ")
HTML = TauschString(HTML, """, Chr$(34))
HTML = TauschString(HTML, "ä", "ä")
HTML = TauschString(HTML, "Ä", "Ä")
HTML = TauschString(HTML, "ö", "ö")
HTML = TauschString(HTML, "Ö", "Ö")
HTML = TauschString(HTML, "ü", "ü")
HTML = TauschString(HTML, "Ü", "Ü")
HTML = TauschString(HTML, "ß", "ß")
HTML = TauschString(HTML, "&", "&")
HTML = TauschString(HTML, "<", "<")
HTML = TauschString(HTML, ">", ">")
HTML = TauschString(HTML, "©", "Copyright")
HTML = TauschString(HTML, "®", "Eingetragenes Warenzeichen")
HTML = ASCRechnung(HTML)
ASCTausch = HTML
Exit Function
ERRASCTausch:
Call ERRSTACK(Err.Number, Err.Description, "DeTager", "ASCTasch")
Resume Next
End Function
Public Function ASCReTausch(ByVal HTML$) As String
If ErrorIgnore Then On Error Goto ERRASCReTausch
HTML = TauschString(HTML, "&", "&")
HTML = TauschString(HTML, Chr$(34), """)
HTML = TauschString(HTML, "ä", "ä")
HTML = TauschString(HTML, "Ä", "Ä")
HTML = TauschString(HTML, "ö", "ö")
HTML = TauschString(HTML, "Ö", "Ö")
HTML = TauschString(HTML, "ü", "ü")
HTML = TauschString(HTML, "Ü", "Ü")
HTML = TauschString(HTML, "ß", "ß")
HTML = TauschString(HTML, "<", "<")
HTML = TauschString(HTML, ">", ">")
ASCReTausch = HTML
Exit Function
ERRASCReTausch:
Call ERRSTACK(Err.Number, Err.Description, "DeTager", "ASCReTasch")
Resume Next
End Function
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
ERRTauschString:
Call ERRSTACK(Err.Number, Err.Description, "DeTager", "TauschString")
Resume Next
End Function
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
Exit Do
Else
If Mid$(HTML, POS + 1, 1) = "#" Then
E = InStr(POS, HTML, ";")
If E <> 0 And E - POS < 6 And E - POS > 2 Then
ASCString = Mid$(HTML, POS + 2, E - POS - 2)
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
z = Val(ASCString)
If FLAG = False And z > -1 And z < 256 Then
AscChar = Chr$(z)
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
ERRASCRechnung:
Call ERRSTACK(Err.Number, Err.Description, "DeTager", "ASCRechnung")
Resume Next
End Function
Private Sub EventHandler(ByVal x&)
If ErrorIgnore Then On Error Goto ERREventHandler
Static LastPos&
Static TaskCount&
TaskCount = TaskCount + 1
If TaskCount > Abs(TaskNum) Then
TaskCount = 0
If TaskNum > 0 And LastPos <> x Then
Progress.Value = x
LastPos = x
End If
DoEvents
End If
Exit Sub
ERREventHandler:
Call ERRSTACK(Err.Number, Err.Description, "DeTager", "EventHandler")
Resume Next
End Sub
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
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
ERRImgTag:
Call ERRSTACK(Err.Number, Err.Description, "DeTager", "ImgTag")
Resume Next
End Function
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
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
ERRBgrTag:
Call ERRSTACK(Err.Number, Err.Description, "DeTager", "BgrTag")
Resume Next
End Function
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
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
ERRRefTag:
Call ERRSTACK(Err.Number, Err.Description, "DeTager", "RefTag")
Resume Next
End Function
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
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
ERREmbdTag:
Call ERRSTACK(Err.Number, Err.Description, "DeTager", "EmbdTag")
Resume Next
End Function
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
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
ERRAncTag:
Call ERRSTACK(Err.Number, Err.Description, "DeTager", "AncTag")
Resume Next
End Function
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
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
ERRFrmTag:
Call ERRSTACK(Err.Number, Err.Description, "DeTager", "FrmTag")
Resume Next
End Function
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
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
ERRLnkTag:
Call ERRSTACK(Err.Number, Err.Description, "DeTager", "LnkTag")
Resume Next
End Function
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
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
ERRMetTag:
Call ERRSTACK(Err.Number, Err.Description, "DeTager", "MetTag")
Resume Next
End Function
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
ERRGetMetaContent:
Call ERRSTACK(Err.Number, Err.Description, "DeTager", "GetMetaContent")
Resume Next
End Function
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
ERRGRFX_DOUBLE_FND:
Call ERRSTACK(Err.Number, Err.Description, "DeTager", "GRFX_DOUBLE_FND")
Resume Next
End Function
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
ERRREF_DOUBLE_FND:
Call ERRSTACK(Err.Number, Err.Description, "DeTager", "REF_DOUBLE_FND")
Resume Next
End Function
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
ERRANC_DOUBLE_FND:
Call ERRSTACK(Err.Number, Err.Description, "DeTager", "ANC_DOUBLE_FND")
Resume Next
End Function
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
ERRTAR_DOUBLE_FND:
Call ERRSTACK(Err.Number, Err.Description, "DeTager", "TAR_DOUBLE_FND")
Resume Next
End Function
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
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
ERRRMEOL:
Call ERRSTACK(Err.Number, Err.Description, "DeTager", "RMEOL")
Resume Next
End Function
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
DeSpace = TXT
Exit Function
End If
If ZEICHEN = "" Then
For x = 1 To Len(TXT)
BB = Mid$(TXT, x, 1)
If BB <> Chr$(32) And BB <> Chr$(160) Then AA = AA & BB
Next x
DeSpace = AA
Exit Function
End If
For x = 1 To Len(TXT)
AA = Mid$(TXT, x, 1)
If ZA Then
If AA = ZEICHEN Then
BB = BB + AA
ZA = False
Else
BB = BB + AA
End If
ElseIf AA = ZEICHEN Then
ZA = True
BB = BB + AA
Else
If AA <> Chr$(32) And AA <> Chr$(160) Then BB = BB + AA
End If
Next x
DeSpace = BB
Exit Function
ERRDeSpace:
Call ERRSTACK(Err.Number, Err.Description, "DeTager", "DeSpace")
Resume Next
End Function
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)
K1 = InStr(POS, UPC, Chr$(34))
If K1 <> 0 Then
K2 = InStr(K1 + 1, UPC, Chr$(34))
End If
If K1 = 0 Then
L = InStr(1, UPC, LABEL)
Exit Do
ElseIf K2 = 0 Then
Exit Do
Else
L = InStr(POS, UPC, LABEL)
If L = 0 Or L < K1 Then Exit Do
POS = K2 + 1
End If
Loop
If L Then
AA = LTrim$(Mid$(TAG, L + Len(LABEL), Len(TAG)))
For x = 1 To Len(AA)
BB = Mid$(AA, x, 1)
Test = InStr(1, FORBIDDEN, BB)
If Test Then
FLAG = True
ElseIf BB = "=" Then
x = x + 1
Exit For
Else
Exit Function
End If
Next x
AA = LTrim$(Mid$(AA, x, Len(AA)))
For x = 1 To Len(AA)
BB = Mid$(AA, x, 1)
If InStr(1, FORBIDDEN, BB) = 0 Then Exit For
Next x
AA = Mid$(AA, x, Len(AA))
If Left$(AA, 1) = Chr$(34) Then
K2 = InStr(2, AA, Chr$(34))
If K2 Then SRC_FINDER = Mid$(AA, 2, K2 - 2)
Exit Function
Else
For x = 1 To Len(AA)
BB = Mid$(AA, x, 1)
If BB = "." Then
MimeFlag = True
MimePos = x
End If
If (BB = " " Or BB = ">")And MimeFlag = True Then
K2 = InStr(MimePos + 1, AA, "#")
If K2 = 0 Or K2 < x Then
x = x - 1
Else
x = 0
End If
Exit For
End If
Next x
SRC_FINDER = Left$(AA, x)
End If
End If
Exit Function
ERRSRC_FINDER:
Call ERRSTACK(Err.Number, Err.Description, "DeTager", "SRC_FINDER")
Resume Next
End Function