Logo Foltyn Presentation
Table of Contents Previous Page Next Page
Content-Symbol-Img
Ein Programm in der Programmiersprache A program in the programming language
vbScript
zur Eliminierung von unmittelbar aufeinanderfolgenden Farb-TAGs gleicher Farbe in einem HTML-Text for elimination of immediate consecutive color-TAGs of the same color in a HTML-Text

     Das Programm reduziert mehrfach vorkommende Farb-TAGS mit derselben Farbe in einem HTML-Text. Eine Prozedur sucht das nächste TAG und konvertiert es in ein Array-Format in welchem alles Selbstverständliche weggelassen ist, was nach der Erkennung nicht mehr gebraucht wird. So lassen sich TAGs leichter vergleichen und das Programm ist vorbereitet auf eine spätere Erweiterung für die Verarbeitung von mehreren Attributen in den Farb-TAGs mit vertauschter Reihenfolge. Unter TAG versteht man in der HTML-Sprache einen Ausdruck, der von < und > begrenzt ist. Er enthält eine Anweisung für den Browser. Im Folgenden wird allerdings unter dem Ausdruck TAG prinzipiell auch der Text mit verstanden, der dem TAG vorangeht. Wenn keiner vorhanden ist, dann ist es ein Leerstring. Denn eine TAG-Reduktion kann nur richtig funktionieren, wenn zwischen den TAGs kein Text ist, welcher eine andere Farbe haben darf. Wenn der Text aber nur aus Leerzeichen oder &nbsp; -s besteht, dann kann auch dann reduziert werden.

     Ein Flussdiagramm zeigt die Funktionsweise. Da es im vbScript keine GOTOs gibt, wird das mit DO-LOOP-Schleifen gemacht, aus denen man an jeder Stelle heraus springen kann. Das erspart eine kompliziertere Schreibweise wie mit IF-THEN-ELSE-Anweisungen, weil wenn ein Vorgang erledigt ist, braucht man sich nicht mehr kümmern, wo das Endzeichen ist. Das Hineinspringen in eine IF-ENDIF-Anweisung erfolgt mittels einer Flag-Variablen als Label-Ersatz. Dadurch ist die Übersichtlichkeit über die gesamte Funktion ein Maximum.

Die komplette Beschreibung ist in einer PDF-Datei.

     The program reduces severalfold occurring color-TAGs with the same color in a HTML-text. A procedure seeks the next TAG and converts it into an array-format, in which everything of course is ommitted, which is after recognition no longer needed. So TAGs let themselves easier compare and the program is prepared for a later processing of several attributes in the color-TAGs in a changed order. Under TAG it is understood in the HTML-language an expression, which is limited by < and > - characters. It contains an instruction for the browser. But in the following, under the expression TAG, is understood the preceeding text combined with the TAG. If no one is extant, than it is an empty string. Because a TAG-reduction can only work correct, if there is no text between the TAGs which can have another predefined color. But if the text consists only of blanks and &nbsp; -s, it can be reduced nevertheless too .

     The flowchart shows the kind of function. Because there are no GOTOs in vbScript, this is made by DO-LOOPs, from which one can jump out at any position. This saves a more complicated writing style as with IF-THEN-ELSE-instructions, because if a sequence is concluded, one needs no longer care, where is the end-sign or the marker for the next. The jumping-in into an IF-ENDIF-instruction is made by means of a Flag-Variable as substitute for a label. Therefor the clarity over the total function is a maximum.

The complete description is in a PDF-File.

Das Programm ist getestet vor der Publikation, aber es kann keine Garantie gegeben werden, dass es fehlerfrei ist
The program ist tested before publication, but there can be given no guarantee, that it is free of errors
27. März 2013 March 27th 2013



Option Explicit

Dim DATA, Text

'     ....+....1....+....2....+.. ..3....+ ....4....+....5
Read "text<BR>text11<font color=""#A52A2A"">txt12</font>"
Read "&nbsp;<font color=""#A52A2A"">text22</font>"
Read "&nbsp;<font color=""#A52A2A"">text32</font>"
Read "More Pure Text without TAGs"
Text = Join(DATA,"")

MsgBox RemoveSameColorTAGs(Text),,"Result"

'              Data-Format in Buffer
'      Single TAG     EndTAG    TAGpairs with EndTAG
' 0    txt     txt     txt       txt11        txt21
' 1    name    name    /name     name         name    
' 2            att               txt12/       att    
' 3                                           txt22/    
    
Function RemoveSameColorTAGs(AnyLine)
    ' B1 = Buffer1, B2 = Buffer2, L = TAGlenght, L2 = EndTAGlenght
    ' TAGlenght always inclusive preceeding text
    Dim Line, L, L2, NL, B1, B2, EndTAG, GOTOnocolTAG
    B1 = Array(): B2 = Array(): Line = AnyLine ' NL = NewLine
    Do While Line <> "": L = FindTAG(B2, Line)
        If L = 0 Then Line = "": Exit Do ' L = 0 means noTAG
        GOTOnocolTAG = False ' TAG found
        Do: If Not TAGisColTAG(B2) Or GOTOnocolTAG Then _
            Shift NL, B1: Shift NL, B2: L2 = 0: Exit Do ' nocolTAG
            L2 = FindTAG(EndTAG, Mid(Line,L+1))
            If L2 > 0 And TAGisEndTAG(B2, EndTAG) Then
                Push B2, EndTAG(0) & "/"
                If CompTAGs(B1,B2) Then _
                MoveTxt B1, B2: Exit Do
                Shift NL, B1: Shift B1, B2: Exit Do
            End If: GOTOnocolTAG = True ' noEndTAG -> GOTO nocolTAG
        Loop: Line = Mid(Line, L + L2 + 1) 
    Loop: Shift NL, B1: Shift NL, B2: RemoveSameColorTAGs = NL
End Function

Function TAGisColTAG(AnyB)
    TAGisColTAG = False
    If UBound(AnyB) < 2 Then Exit Function
    If LCase(AnyB(1)) <> "font" Or _
    LCase(Left(AnyB(2),5)) <> LCase("color") Then Exit Function
    TAGisColTAG = True
End Function

Function TAGisEndTAG(AnyBuffer, EndTAG)
    TAGisEndTAG = False
    If UBound(EndTAG) <> 1 Or Left(EndTAG(1),1) <> "/" Then Exit Function
    If UCase(AnyBuffer(1)) = UCase(Mid(EndTAG(1),2)) Then TAGisEndTAG = True
End Function

Sub Shift(ByRef AnyVar, byRef AnyB) ' to shift buffer into NL or other buffer
    If IsArray(AnyVar) Then _
    AnyVar = AnyB Else AnyVar = AnyVar & RestringTAG(AnyB)
    AnyB = Array()
End Sub

Sub MoveTxt(byRef AnyB1, byRef AnyB2) 
    ' adds txt from TAG-array2 to TAG-array1 and clears Ta2
    Dim U1, U2, L: U1 = UBound(AnyB1): U2 = UBound(AnyB1)
    AnyB1(U1) = Left(AnyB1(U1),Len(AnyB1(U1))-1) & AnyB2(0) & AnyB2(U2)
    AnyB2 = Array()
End Sub

Function FindTAG(byRef Buffer, Line) 
    ' finds the next string and converts it to an array
    ' thereafter preceeding txt (noTAG) is a component of the TAG
    ' and returns TAG-lenght = Len(Txt & TGtxt) + 2, 0 = noTAG
    ' it is forseen to have more atts in next version
    ' TAG with EndTAG    without EndTAG    noTAG (pure text)
    
    ' 0    txt        txt        txt
    ' 1    name       name       /name
    ' 2               att
    
    ' i1 = len(Txt)+1 : i2 = i1 + len(TGtxt)+1
    Dim Txt, TGtxt, Flag, i, i1, i2 
    Buffer = Array(): Flag = False
    i1 = 0: i2 = 0: FindTAG = 0
    For i = 1 To Len(Line)
        If Mid(Line, i, 1) = "<" Then
            If Flag Then Exit Function
            Flag = True
        ElseIf Mid(Line, i, 1) = ">" Then
            If Not Flag Then Exit Function
            Flag = False
        End If
    Next: Txt = Line: FindTAG = 0
    i1 = InStr(Line, "<"): If i1 = 0 Then Push Buffer, Line: Exit Function
    i2 = InStr(i1+1,Line, ">"): If i2 = 0 Then Push Buffer, Line: Exit Function
    Txt = Left(Line,i1-1): TGtxt = Mid(Line,i1+1,i2-i1-1)
    Push Buffer, Txt: Push Buffer, Split(TGtxt, " ")
    FindTAG = Len(Txt & TGtxt) + 2
End Function

Function CompTAGs(AnyB1,AnyB2) 
    ' compares 2 TAGs in their array-format with reference to its names and atts
    ' txt between the TAGs is regarded as unequal unless it is either
    ' empty string or blanks plus &nbsp; - s only
    ' CompTAGs detects automaticly noTAG-text in TAGList, which is regarded as unequal
    Dim i, B1, B2: B1 = AnyB1: B2 = AnyB2: CompTAGs = False
    If UBound(B1) < 1 Or UBound(B2) < 1 Then Exit Function
    If Trim(Replace(LCase(B2(0)),LCase("&nbsp;")," ")) <> "" Then Exit Function
    For i = 1 To 2
        If Trim(UCase(B1(i))) <> Trim(UCase(B2(i))) Then Exit Function
    Next: CompTAGs = True
End Function

Function RestringTAG(ByVal AnyArray) 
    ' Reconverts TAG from array-format to string
    ' Pure text without TAGs can be in the array too as UBound(A) = 0
    Dim A, U, i, t: A = AnyArray: U = UBound(A): t = ""
    RestringTAG = t: If U < 0 Then Exit Function
    t = AnyArray(0): If U > 0 Then t = t & "<"
    If Right(A(U),1) = "/" Then _
    A(U) = ">" & Replace(A(U),"/","</" & A(1))
    For i = 1 To U
        t = t & A(i)    
    Next: If U > 0 Then t = t & ">"
    RestringTAG = t
End Function

' Generally used procedures

Function Read (AnyLine) 
    ' to read in use as sub
    ' to reset and read out use as function with "" as input
    ' needs DATA as public array
    If Not IsArray(DATA) Then DATA = Array()
    If AnyLine = "" Then Read = DATA: DATA = Array(): Exit Function
    Push DATA, AnyLine: Read = Array()
End Function

Sub Push(ByRef AnyArr, ByVal AnyVar) ' Push variant or array to an array
    ' AnyVar can be a String, Numeric or a Variant Array
    Dim item: If IsEmpty(AnyArr) Then ReDim AnyArr(-1)
    If Not IsArray(AnyVar) Then AnyVar = Array(AnyVar)
    For Each item In AnyVar
        ReDim Preserve AnyArr(UBound(AnyArr)+1): AnyArr(UBound(AnyArr)) = item
    Next
End Sub

Sub Del(ByRef AnyArray, ByVal AnyPos) ' Deletes item in an array
    Dim i: If AnyPos < 0 Or Anypos > UBound(AnyArray) Then Exit Sub
    For i = AnyPos + 1 To UBound(AnyArray)
        AnyArray(i-1) = AnyArray(i)
    Next: ReDim Preserve AnyArray(UBound(AnyArray)-1)
End Sub

Function Copy(AnyArray) ' copies array
    Copy = AnyArray
End Function


Eine andere Methode, dieselbe Funktion zu erhalten ist, den Text in der Zeile zu belassen und Zeiger zu versetzen anstatt Pufferinhalte zu shiften. Dazu wären nur 3 Zeiger notwendig, für den Vergleich der zwei TAGs würde die Konversion ins Array-Format weiterhin alle Möglichkeiten bieten. Es könnte vielleicht mit weniger Code auskommen. Aber das ist nicht mehr in Betracht.

Another method to get the job done is to leave the text in the Line and displace pointers instead of shifting buffers. There would be only 3 pointers necessary, for comparison of the two TAGs the conversion to array-format would still offer all possibilities. It could get the functions done with less code. But this is no more in consideration.