' Convert Source-Code to HTML-Text, Programming Language vbScript

Option Explicit ' Guarantees, that all variables are explicitly declared

' Declarations of Variables and objects
Dim ProgressBarWidth, ProgressBarHeight, LineNr             ' Numerics
Dim HtaFlag                                                 ' Booleans
Dim fSpec_Source, fSpec_Dest, fSpec_DestTmp                 ' Strings   ' fSpecs
Dim Path_Script, Path_Source, Path_Dest                                 ' Pathes
Dim Fldr_BakFiles, Fldr_LastCodeConverted                               ' Folders
Dim Txt_Script, Txt_HTML, Txt_NewHTML                                   ' Text
Dim OldLine, NewLine, PrevChar, ProgressBarTitle, Title                 ' others
Dim Language, Lg
Dim Keywords_BasStm, Keywords_BasOps, Keywords_VbsStm       ' Arrays
Dim SM, ReadTmp

Const Dummy = False ' Dummy is no hard disk operation       ' Constants
Const Test = False  ' Test replaces Browse for Files by fSpecs from last ones in INI
Const MaxNrOfCopies = 10
Const RD = 1, WR = 2, Up = 1, Down = -1
Const SpecChrs_HTML = "äÄöÖüÜß ""<>&§;auml;Auml;ouml;Ouml;uuml;Uuml;szlig;nbsp;quot;lt;gt;amp;sect"
Const alphabet =            "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
Const numerics =            "0123456789"
Const Chars_Prev =          "([{ /*\,;:=<>+-"
Const Chars_Next =          ")]} /*\,;:=<>+-"
Const Chars_Keyword_Prev =  " ,<>|+-*:;=([{"
Const Ops_BAS =             "()+-*/\<=>"

Const TAG_Table1 =  "<table border=""0"" cellpadding=""0"" cellspacing=""0""><tr><td width="""
Const TAG_Table2 =  """ height=""15"" bgcolor=""#0000FF"">&nbsp;</td></tr></table>"
Const TAG_p1 =      "<p align=""center"">Progress "
Const TAG_p2 =      " %</p>"
Const TAG_FontF1 =  "<font face=""Courier New"" SIZE=""2"">" 
Const TAG_FontC1 =  "<font color="
Const TAG_Fontx2 =  "</font>"

Const Markers_Script =  "HTML,SCRIPT Language=""VBScript"",/SCRIPT,/HTML"
Const Marker1 =         "<!-- Start of Source-Code -->"
Const Marker2 =         "<!-- End of Source-Code -->"

Const LanguageList =    "hta,vbs,bas,inc" ' BrowseFile Parameters
Const ExtFilterSource = "VBS HTA BAS INC, vbs hta bas inc"
Const ExtFilterDest =   "HTM HTML, htm html"

Const Col_Typs =    "Txt,Key,Rem,Qum,Nrs,Ops,Fms,Att,Tag" ' Qum quotation mark, Fms Forms
Const Col_hta =     "000000,0000FF,007F00,408080,A52A2A,,,FF0000,A52A2A"
Const Col_vbs =     "000000,0000FF,007F00,808080,A52A2A,,,FF0000,A52A2A"
Const Col_bas =     "000000,0000C0,007F00,C020C0,000000,8000FF,C06400,,"

Dim A0: A0 = Array()                                                        ' Quasi Constants
ProgressBarWidth =  400
ProgressBarHeight = 150
ProgressBarTitle = "Progress-Bar"
Dim INIarray, Protocol: INIarray = A0: Protocol = A0                        ' Initialise Arrays
Dim ErrMsg: ErrMsg = ""                                                     ' Initialise Strings

' Assignment of Subfolders
Fldr_BakFiles =             "BakFiles"                                      ' Subfolders ' before OWN
Fldr_LastCodeConverted =    "LastCodesConverted"

' Instantiations of Objects
Dim WshShell:   Set WshShell =  CreateObject("WScript.Shell")               ' Objects
Dim fso:        Set fso =       CreateObject("Scripting.FileSystemObject")
Dim ColSet:     Set ColSet =    CreateObject("Scripting.Dictionary")
Dim col:        Set col =       CreateObject("Scripting.Dictionary")
Dim OWN:        Set OWN =       New OwnSysSpecs                             ' Classes
Dim FIO:        Set FIO =       New FilesAndFolders

' oExplr needed for Function "DisplayProgress"
Dim oExplr:     Set oExplr =    WScript.CreateObject("InternetExplorer.Application")

' Default Values for no INI
Path_Source =   "c:\...your path ..."
Path_Dest =     "c:\...your path ..."

' Default Values for Testmode
fSpec_Source =  BPth(Path_Source, "ConvertSourceCodeToHTML.vbs")
fSpec_Dest =    BPth(Path_Dest, "vbs-tmp.html")
fSpec_DestTmp = BPth(Path_Dest, "Tmp.htm" )

' Load ColSpecs into dictionary
ColSet.Add "ColTyps",   Col_Typs
ColSet.Add "hta",       Col_hta
ColSet.Add "vbs",       Col_vbs
ColSet.Add "bas",       Col_bas

' Assignment of edited Parameters to Variables
SM = Split("<" & Replace(UCase(Markers_Script),",",">,<") & ">",",")

' =============== Program ================

GetJobDone ' Main-Program
DisplayResult

Sub GetJobDone: Title = "Error"
    If Not Test Then GetSourceAndDestFileSpecs
    If ErrMsg <> "" Then Exit Sub
    Language = LCase(FiExt(fSpec_Source))
    If Language = "inc" Then Language = "bas"
    If Not LoadKeywords(Language) Then Exit Sub
    RDWRfile RD, Txt_Script, fSpec_Source
    If Not RemoveLeadingEmptyLines(Txt_Script) Then Exit Sub
    ConvertTextFromSourceCodeToHTML ' From Txt_Script --> Txt_HTML
    DisplayArray Txt_Script, "Txt_Script"
    DisplayArray Txt_HTML, "Txt_HTML"
    SaveCopyOfHTMLtext(OWN.Path_LastCodeConverted) ' HTML-version of Source-Code
    If Not InsertCodeIntoPage(Txt_NewHTML, Txt_HTML, fSpec_Dest) Then Exit Sub
    DisplayNewDestPageBeforeOverwrite
    OverwriteOldDestPageIfOK
End Sub

' =============== Procedures ================

' ------- GetSourceAndDestFileSpecs ----------

Sub GetSourceAndDestFileSpecs ' From INI and then from the 2 BrowseFiles
    Dim i: ErrMsg = "BreakOff by the user"
    Do: GetPathesFromINI
        fSpec_Source = BrowseFile(GetParameters("Choose SourceFile"))
        If fSpec_Source = "" Then Exit Sub
        i = InStr(LanguageList,FiExt(fSpec_Source))
        If i = 0 Then MsgBox "nonadmitted file-extension, try again or break off",,"Error"
    Loop Until i > 0
    fSpec_Dest = BrowseFile(GetParameters("Choose DestFile"))
    If fSpec_Dest = "" Then Exit Sub
    Path_Source = FoP(fSpec_Source)
    Path_Dest = FoP(fSpec_Dest)
    fSpec_DestTmp = BPth(Path_Dest, "Tmp.htm" )
    PutPathesToINI: ErrMsg = ""
End Sub

Function GetParameters(Title): Dim A: A = A0: PUSH A, Title
    Select Case Title
        Case "Choose SourceFile":   PUSH A, Array(Path_Source, "*.*", ExtFilterSource)
        Case "Choose DestFile":     PUSH A, Array(Path_Dest, "*.htm*", ExtFilterDest)
    End Select: GetParameters = A
End Function

Function BrowseFile(ByVal Parameters) ' Parameters: Title, Path, Filter, ExtFilter
    Dim IE, HTA, ShAp, sFilter, i, s1, iCount, A, A1, CharCode
    A = Parameters: A(1) = BPth(A(1), A(2)): BrowseFile = ""
    CreateObject("WScript.Shell").Run _
        "MSHTA.EXE ""javascript:new ActiveXObject" & _
        "('InternetExplorer.Application').PutProperty('ID1', window);""", 0                
    Set ShAp = CreateObject("Shell.Application"): On Error Resume Next: iCount = 1
    Do Until iCount = 10
        For Each IE In ShAp.Windows
            If IsObject(IE.GetProperty("ID1")) Then _
                Set HTA = IE.GetProperty("ID1"): IE.quit: Exit Do
        Next: WScript.sleep 100: INC iCount
    Loop: Set ShAp = Nothing: HTA.document.body.innerHTML = _
        "<OBJECT ID=Dlg CLASSID=CLSID:3050f4e1-98b5-11cf-bb82-00aa00bdce0b></object>"
    Do: If A(3) = "" Then _
        BrowseFile = HTA.Dlg.object.openfiledlg(CStr(A(1)),,, CStr(A(0))): Exit Do
        A1 = Split(A(3), ","): sFilter = ""
        For i = 0 To Ubd(A1) Step 2: sFilter = sFilter & Trim(A1(i))
            s1 = Trim(A1(i + 1)): s1 = Replace("*." & s1, " ", ";*.")
            sFilter = sFilter & " (" & s1 & ")|" & s1 & "|"
        Next: BrowseFile = HTA.Dlg.object.openfiledlg(CStr(A(1)),, CStr(sFilter), CStr(A(0)))
    Loop Until True: HTA.close : Set HTA = Nothing
    For i = 1 To Len(BrowseFile): CharCode = Asc(Mid(BrowseFile,i))
        If CharCode < 32 Or CharCode > 127 Then Exit For
    Next: BrowseFile = Left(BrowseFile,i-1)
    WshShell.SendKeys "% x" ' should maximise succeeding windows like msgbox
End Function

' ---------- Load Keywords --------------

Function LoadKeywords(Language): LoadKeywords = False: ErrMsg = "Keyword-List not found"
    Lg = Language: If Lg = "hta" Then Lg = "vbs"
    Dim fSpc, A: fSpc = BPth(Path_Script, "Keywords-" & Lg)
    A = LoadFromDisk(fSpc & "-stm.dat"): If IsRid(A) Then Exit Function
    If Lg = "vbs" Then
        Keywords_VbsStm = A
    ElseIf Lg = "bas" Then
        Keywords_BasStm = A
        A = LoadFromDisk(fSpc & "-ops.dat"): If IsRid(A) Then Exit Function
        Keywords_BasOps = A
    End If: LoadKeywords = True: ErrMsg = ""
End Function

Function LoadFromDisk(AnyFileSpec): Dim A, ErrMsg: ErrMsg = "": A = A0: LoadFromDisk = A
    ' Loads and Sorts and Writes Back and Sorts for Wordlenght
    Do: If Not(FiE(AnyFileSpec)) Then ErrMsg = AnyFileSpec & "not found": Exit Do
        RDWRfile RD, A, AnyFileSpec 
        If IsRid(A) Then ErrMsg = AnyFileSpec: Exit Do
        RDWRfile WR, A, OWN.GetfSpecBak(AnyFileSpec)
        A = SORT(A, Up): A = RemoveSameItems(A)
        RDWRfile WR, A, AnyFileSpec 
        A = SORTforWordLenght(A): LoadFromDisk = A
    Loop Until True: If ErrMsg <> "" Then MsgBox ErrMsg,,"Error"
End Function

' ---------- Convert Code --------------

Sub ConvertTextFromSourceCodeToHTML: Dim PrevLg, htaBuffer, BRbuffer, BR, BR1
    BRbuffer = "": htaBuffer = A0: Txt_HTML = A0: Lg = Language
    If Lg = "hta" Then PrevLg = "vbs"
    If Lg = "vbs" Then PrevLg = "hta"
    PUSH Txt_HTML, TAG_FontF1: DisplayProgress "Open",""
    For LineNr = 0 To Ubd(Txt_Script): Txt_Script(LineNr) = ReplaceTABs(CLine, 4)
        Select Case Lg
            Case "hta", "vbs": SetHTAflag ' Affects Lg
                If Lg <> PrevLg Then AssignColors Lg: PrevLg = Lg
                If Lg = "hta" Then 
                    PUSH htaBuffer, CLine
                    If LineNr = Ubd(Txt_Script) Then _
                        PUSH Txt_HTML, BRbuffer & "<BR>": _
                        PUSH Txt_HTML, ConvertHTAcode(htaBuffer): _
                        PUSH Txt_HTML, TAG_Fontx2
                ElseIf Lg = "vbs" Then 
                    PUSH Txt_HTML, ConvertHTAcode(htaBuffer)
                    Do: BR = GetBRs(BRbuffer): If BR = "" Then Exit Do
                        If LineNr = 0 Then BR = ""
                        PUSH Txt_HTML, BR & ConvertCodeLine(CLine)
                    Loop Until True 
                End If: ResetHTAflag ' Affects Lg
            Case "bas"
                If LineNr = 0 Then AssignColors Lg
                Do: BR = GetBRs(BRbuffer): If BR = "" Then Exit Do 
                    If LineNr = 0 Then BR = ""
                    PUSH Txt_HTML, BR & ConvertCodeLine(CLine)
                Loop Until True
        End Select: DisplayProgressText LineNr, Ubd(Txt_Script)
    Next: DisplayProgress "Close",""
    PUSH Txt_HTML, TAG_Fontx2 : RemoveConsecutiveSameColTAGs Txt_HTML      
End Sub

Function ReplaceTABs(aLine, NrOfBlanks): Dim i, j, Char, n: n = NrOfBlanks: i = 1
    While i <= Len(aLine): Char = Mid(aLine,i,1)
        If Char = vbTab Then
            For j = 1 To 200 Step n: If j > i Then Char = Space(j-i): Exit For
            Next
        End If: aLine = Left(aLine,i-1) & Char & Mid(aLine, i+1): i = i + Len(Char)
    Wend: ReplaceTABs = aLine
End Function

Sub AssignColors(xLanguage) ' Result in the public array col.Items
    Dim ColTyp, a1, a2, Lg: Lg = xLanguage
    a1 = Split(ColSet.Item("ColTyps"),",")
    a2 = Split(ColSet.Item(Lg),",")
    If col.Count > 0 Then col.RemoveAll
    For Each ColTyp In a1: col.Add ColTyp, DEQUEUE(a2): Next
End Sub

Function ConvertCodeLine(aLine): Dim CharTyp, Color, Word, NewWord, sTmp, sTmp2, i, j, Char
    OldLine = aLine: NewLine = "": PrevChar = "" ' OldLine, NewLine, PrevChar = public
    While Len(OldLine): Char = Left(OldLine, 1)
        CharTyp = PreSelect ' CharTyps = *'"0@#
        RecogniseWord CharTyp, Word, Color ' OldLine, Language = public
        Do: If Word = "" Then NewWord = Char: Word = Char: Exit Do
            NewWord = ReplaceSpecChars(Word): If Color <> "" Then NewWord = enTAG(Color, NewWord)
        Loop Until True: DisposeOff NewLine, NewWord, OldLine, Word ' bestows the PrevChar
    Wend: ConvertCodeLine = NewLine
End Function

Function PreSelect: PreSelect = "*": Dim Char: Char = Left(OldLine,1)
    ' InStrOnly("A0 _[]ßäöüÄÖÜ€|", AnyString)
    ' ( ) * - / \ < <= <> = > >=   Ops_BAS = ()+-*/\<=>
    If InStrOnly("'""", Char) Then PreSelect = Char
    If InStrOnly("#%$&", Char) And Language = "bas" Then PreSelect = "#"
    If InStrOnly("A", Char) Then PreSelect = "A"
    If InStrOnly("0.+-", Char) Then PreSelect = "0"
    If InStrOnly(Ops_BAS, Char) And Language = "bas" Then PreSelect = "o"
End Function

Sub RecogniseWord(ByVal aCharTyp, ByRef aWord, ByRef aColor)
    Dim Color: aWord = OldLine: Color = "": AssignColors Language
    Select Case aCharTyp
        Case "*":   aWord = ""
        Case "'":   Color = col.Item("Rem")
        Case """":  aWord = DetectQuote(OldLine)
                    If aWord <> "" Then Color = col.Item("Qum")
        Case "0":   aWord = DetectNumber(PrevChar, OldLine)
                    If aWord <> "" Then Color = col.Item("Nrs")  
        Case "A":   Do: If UCase(Left(OldLine,4)) = "REM " Then _
                        aWord = "REM " & Mid(OldLine, 5): Color = col.Item("Rem"): Exit Do 
                        aWord = DetectKeyWord(Color, OldLine)
                    Loop Until True
        Case "#":   Do: If Left(aWord,9) = "#PBFORMS " Then Color = col.Item("Fms"): Exit Do
                        aWord = DetectKeyWord(Color, OldLine)
                    Loop Until True
        Case "o":   aWord = DetectKeyWord(Color, OldLine)
    End Select: If aWord = "" Then aWord = Left(OldLine, 1): Color = ""
    aColor = Color
End Sub

' ---------- Detect Words --------------

Function DetectKeyWord(ByRef aColor, byVal aLine)
    ' Converts keyword from black-white to color
    ' If KeyWord found, it returns Keyword with col-TAGs
    ' and returns aLine displaced
    ' If KeyWord not found, it returns "" and
    ' leaves aLine unchanged
    Dim KeyWord, Color, NextChar, Pos, del, bTmp, C1: KeyWord = "" 
    Do: If PrevChar <> "" And Not InStrOnly(Chars_Keyword_Prev, PrevChar) Then Exit Do
        Select Case Language
        Case "bas"
            Do: DetectWord KeyWord, Color, aLine, "bas-stm", Keywords_BasStm
                If KeyWord = "" Then
                    DetectWord KeyWord, Color, aLine, "bas-ops", Keywords_BasOps
                    If KeyWord = "" Then Exit Do
                End If ' A%$# are no letter-ops
                If InStrOnly("A%$#", Left(KeyWord,1)) Then del = "A0_ßäöüÄÖÜ" Else del = " "
                bTmp = InStrOnly(del, GetNextChar(KeyWord, aLine))
                If del = " " Then bTmp = Not bTmp
                If bTmp Then KeyWord = ""
            Loop Until True
        Case "hta","vbs"
            DetectWord KeyWord, Color, aLine, "vbs-stm", Keywords_VbsStm
            NextChar = GetNextChar(KeyWord, aLine)
            If KeyWord <> "" And InStrOnly("A0_ßäöüÄÖÜ", NextChar) Then KeyWord = ""
        End Select
    Loop Until True: If KeyWord = "" Then aColor = ""
    DetectKeyWord = KeyWord: aColor = Color
End Function

Sub DetectWord(byRef aKeyWord, byRef aColor, byVal aLine, byVal KwdTyp, byVal KwdList)
    Dim Color, Keyword, K, L, Ls, item, Found, NextChar: Found = False
    Select Case KwdTyp
        Case "bas-stm","vbs-stm":   K = "Key"
        Case "bas-ops":             K = "Ops"
    End Select: Color = col.Item("Txt"): Ls = Len(aLine)
    For Each KeyWord In KwdList: L = Len(KeyWord) 
        Do: If L > Ls Then Exit Do
            If UCase(KeyWord) <> UCase(Left(aLine,L)) Then Exit Do
            NextChar = GetNextChar(KeyWord, aLine)
            If InStrOnly("A", NextChar) Then Exit For
            Color = col.Item(K) 
            If KwdTyp = "bas-stm" Then
                For Each item In Split("%IDC_,%IDD_",",")
                    If UCase(KeyWord) = UCase(item) Then Color = col.Item("Txt")
                Next
            End If: Found = True: Exit For
        Loop Until True
    Next: If Not Found Then Exit Sub
    NextChar = GetNextChar(KeyWord, aLine)
    If InStrOnly("0", NextChar) Then Exit Sub
    If Len(Color) <> 6 Then Color = "000000"
    If Not(InStrOnly("A0", Color)) Then Color = "000000"
    aKeyWord = Keyword: aColor = Color
End Sub

Function DetectQuote(aLine): Dim i, i1: DetectQuote = "": i = 2
    If Left(aLine, 1) <> """" Then Exit Function
    Do: i1 = InStr(i, aLine, """"): If i1 = 0 Then Exit Function
        If Mid(aLine,i1+1,1) <> """" Then Exit Do
        i = i1 + 2
    Loop: DetectQuote = Left(aLine, i1)
End Function

Function DetectNumber(AnyPrevChar, AnyString): Dim Cp: Cp = AnyPrevChar
    If Cp <> "" And Not InStrOnly(Chars_Prev, Cp) Then Exit Function
    Dim CharPos, Char, sTmp, Trunc, L, cpTmp, IsFinalChar
    DetectNumber = "": sTmp = AnyString: L = Len(sTmp)
    For CharPos = L To 1 Step -1: Char = Mid(sTmp,CharPos,1)
        Do: IsFinalChar = InStr(Chars_Next, Char) > 0: cpTmp = 0
            If IsFinalChar Then cpTmp = CharPos - 1 Else If CharPos = L Then cpTmp = CharPos
            If cpTmp = 0 Then Exit Do
            Trunc = Left(sTmp, cpTmp)
            If IsNumber(Trunc) Then DetectNumber = Trunc: Exit Function
        Loop Until True
    Next
End Function

Function IsNumber(AnyString) ' for integer and floating point numbers
    Dim L, Cp, Cx, Cs, i, sTmp, a: L = Len(AnyString): IsNumber = False
    Cp = Chars_Prev: Cx = numerics: Cs = ".e+": sTmp = AnyString 
    If sTmp = "" Or sTmp = "." Then Exit Function   
    If InStr(Cx & ".", Right(sTmp,1)) = 0 Then Exit Function
    sTmp = Replace(Replace(LCase(sTmp),"d","e"),"-","+")
    For i = 1 To L: If InStr(Cx & Cs, Mid(sTmp,i,1)) = 0 Then Exit Function
    Next: For i = 1 To Len(Cs): If Ubd(Split(sTmp,Mid(Cs,i,1))) > 1 Then Exit Function
    Next: a = Split(sTmp,"e"): If InStr(a(0),"+") > 0 Then Exit Function
    If Ubd(a) > 0 Then If InStr(a(1),".") > 0 Then Exit Function
    IsNumber = True
End Function

Sub DisposeOff(ByRef aNewLine, ByVal aNewWord, ByRef anOldLine, ByVal aWord)
    PrevChar = Right(aWord, 1)
    ADD aNewLine, aNewWord: anOldLine = Mid(anOldLine, Len(aWord)+1)
End Sub

Function GetNextChar(aWord, aLine): Dim Pos: Pos = Len(aWord)
    If aWord = "" Then Pos = 1: End If: GetNextChar = Mid(aLine, Pos + 1, 1)
End Function

Function GetBRs(byRef aBRbuffer): GetBRs = "": ADD aBRbuffer, "<BR>"
    If Trim(CLine) <> "" Then GetBRs = aBRbuffer: aBRbuffer = ""
End Function

' ---------- ConvertHTACode --------------

Function ConvertHTAcode(byRef xArr): ConvertHTAcode = A0 ' List of multiple lines
    If IsRid(xArr) Then Exit Function
    Dim Code, TAGdyed, j, k: Code = Join(xArr, vbCrLf): TAGdyed = ""
    Do While Len(Code): j = InStr(Code,"<"): k = InStr(Code,">")
        If j = 0 Or k = 0 Or j > k Then
            TAGdyed = enTAG(col.Item("Txt"), _
                SpecChar(Code, "<>")): Exit Do
        Else: TAGdyed = TAGdyed & DyeTAG(Left(Code,k)): Code = Mid(Code,k+1)
        End If
    Loop:   TAGdyed = Replace(TAGdyed, vbCrLf, vbCrLf & "<BR>")
            TAGdyed = Replace(TAGdyed, "<BR>" & vbCrLf, "<BR>")
            ConvertHTAcode = RemoveBlanksAfterBreaks(Split(TAGdyed, vbCrLf))
            xArr = A0
End Function

Function RemoveBlanksAfterBreaks(AnyText): RemoveBlanksAfterBreaks = A0
    Dim A1, A2, Line, NewLine, item, x, found
    A1 = Array("<BR>","&nbsp;"," ")
    A2 = Array("<BR>","&nbsp;","&nbsp;")
    For Each Line In AnyText: NewLine = ""
        Do: For Each item In A1: x = -1
                If Left(Line, Len(item)) = item Then x = FIND(A1,item,1)
                found = False: If x > -1 Then found = True: Exit For
            Next: If Not found Then NewLine = NewLine & Line: Line = "": Exit Do 
            NewLine = NewLine & A2(x): Line = Mid(Line, Len(item) + 1)
        Loop: PUSH RemoveBlanksAfterBreaks, NewLine
    Next
End Function

Function DyeTAG(AnyString) ' One single TAG
    ' "....<..."  "....>..." "....>...<..." "....<...>..."
    Dim TAG, TAGtxt, TAGname, TAGattr, TAGdyed, sTmp, sTmp2, i, j, k, Txt1
    TAG = "": TAGtxt = "": TAGname = "": TAGattr = "": TAGdyed = "" 
    If AnyString = "" Then Exit Function
    j = InStr(AnyString,"<"): k = InStr(AnyString,">")
    If j > 1 Then
        TAGdyed = SpecChar(Left(AnyString, j-1), """ ")
        AnyString = Mid(AnyString,j): j = 1: k = InStr(AnyString,">")
    End If: TAG = Left(AnyString,k): If TAG = "" Then Exit Function
    i = InStr(TAG," "): If i = 0 Then i = Len(TAG)
    ' split in TAGname and TAGattr
    TAGname = Mid(TAG,2,i-2): TAGattr = Mid(TAG, i, Len(TAG) - i)
    If Mid(TAG,2,3) = "!--" Then ' RemarkTAG 
        DyeTAG = TAGdyed & enTAG(col.Item("Rem"), "&lt;" & _
        TAGname & TAGattr & "&gt;"): Exit Function
    End If
    TAGdyed = TAGdyed & enTAG(col.Item("Key"), "&lt;") & _
    enTAG(col.Item("Tag"), TAGname) ' encolor leading <
    ' Dye Attributes for example size="3" name="mylistbox"
    If Len(TAGattr) Then
        sTmp2 = "": i = 1 ' several attributes
        Do: j = InStr(i, TAGattr,"="): If j = 0 Then Exit Do
            sTmp = SpecChar(Mid(TAGattr,i,j-i), " ")
            sTmp2 = sTmp2 & enTAG(col.Item("Att"), sTmp) ' encolors attname
            i = j: j = InStr(j,TAGattr,""""): If j = 0 Then Exit Do ' no " found
            j = InStr(j+1,TAGattr,""""): If j = 0 Then Exit Do ' no second " found
            sTmp2 = sTmp2 & enTAG(col.Item("Qum"), _
                SpecChar(Mid(TAGattr,i,j-i+1),""" ")) ' encolors attval
            i = j + 1 ' next att
        Loop
    End If
    DyeTAG = TAGdyed & sTmp2 & enTAG(col.Item("Key"), "&gt;") ' encolor trailing >
End Function

Function TAG1(xColor) ' Creates StartTAG with color Attribute
    TAG1 = "": If xColor = "" Then Exit Function
    If Len(xColor) <> 6 Then xColor = "000000"
    If Not(InStrOnly("A0", xColor)) Then xColor = "000000"
    TAG1 = TAG_FontC1 & """#" & xColor & """>" ' "<font color=""#007F00"">"
End Function

' equippes txt with start- and endTAG
Function enTAG(AnyCol, AnyStrg): enTAG = TAG1(AnyCol) & AnyStrg & TAG_Fontx2: End Function

Sub RemoveConsecutiveSameColTAGs(ByRef AnyHTMLtext): Dim A, i: A = AnyHTMLtext
    For i = 0 To Ubd(A): RemoveSameColTAGsInLine A(i): Next: AnyHTMLtext = A
End Sub

Sub RemoveSameColTAGsInLine(ByRef AnyLine): Dim i(8),j,s,c,Line,UL,str 
    ' Const TAG_FontC1 = "<font color="
    str = Array(UCase(TAG_FontC1), """", """", ">", UCase(TAG_Fontx2))
    Line = AnyLine: i(0) = 1  
    Do: UL = UCase(Line)
        For j = 0 To 4: If Not InLine(i(j+1), i(j), UL, str(j)) Then Exit Do
        Next: i(6) = i(5) + Len(str(4))-1
        Do: If Not InLine(i(7),i(6),UL,Mid(UL,i(1),i(4)-i(1)+1)) Then i(0)=i(6)+1: Exit Do
            s = Mid(Line, i(6) + 1, i(7) - i(6) - 1)
            c = Trim(Replace(s, "&nbsp;", " "))
            If c <> "" Then i(0) = i(7): Exit Do
            InLine i(8), i(7), UL, str(3)
            Line = Left(Line, i(5) - 1) & LCase(s) & Mid(Line, i(8) + 1): i(0) = i(1)
        Loop Until True
    Loop: AnyLine = Line
End Sub: Function InLine(ByRef x2, ByVal x1, xStr, fStrg)
            x2 = InStr(x1, xStr, fStrg): InLine = x2 > 0: End Function

Sub SetHTAflag: Dim Line: Line = UCase(CLine) "
    If InStr(Line,SM(0)) Or InStr(Line,SM(2)) Then Lg = "hta"
End Sub

Sub ResetHTAflag: Dim Line: Line = UCase(CLine)
    If InStr(Line,SM(1)) Or InStr(Line,SM(3)) Then Lg = "vbs"
End Sub

Function ReplaceSpecChars(Line): Line = Replace(Line, vbTab, "    ")
    ReplaceSpecChars = SpecChar(Line, "äÄöÖüÜß ""<>&§")
End Function

Function SpecChar(Line, CharMask): Dim A, i, k, Char: SpecChar = ""
    ' z.B. CharMask = """ "
    ' insert HTML-code for special characters
    ' &&amp must be on first place
    ' at the end ";" must be missing
    A = Split(SpecChrs_HTML,";")
    For i = 1 To Len(Line): Char = Mid(Line, i, 1): k = 0
        If InStr(CharMask, Char) > 0 Then k = InStr(A(0), Char)
        If k > 0 Then Char = "&" & A(k) & ";": End If: ADD SpecChar, Char
    Next
End Function

Sub SaveCopyOfHTMLtext(xPath): If Not FoE(xPath) Then fso.CreateFolder(xPath)
    Dim fSpec: fSpec = BPth(xPath, FiB(fSpec_Source)) & "-" & GetNowTime & ".htm"
    RDWRfile WR, Txt_HTML, fSpec
    FIO.KeepNrOfFilesDownToMax(xPath)
End Sub

Function CLine: CLine = Txt_Script(LineNr): End Function

' ------- InsertCodeIntoPage ----------

Function InsertCodeIntoPage(ByRef Txt_NewHTML, ByVal Txt_HTML, DestFspec)
    Dim Line, Block1, Block2, A, PageText, i, j
    InsertCodeIntoPage = False: PageText = A0: Txt_NewHTML = A0: A = A0: i = 0: j = 0
    ErrMsg = "no destfile found": If Not FiE(DestFspec) Then Exit Function
    RDWRfile RD, PageText, DestFspec
    ErrMsg = "no code in file": If IsRid(PageText) Then Exit Function
    For Each Line In PageText ' Get Markers
        If Trim(Line) = Marker1 Then INC i
        If Trim(Line) = Marker2 Then INC j
    Next: ErrMsg = "no markers found in dest-file"
    Block1 = True: If i <> 1 Or j <> 1 Or i > j Then Exit Function
    For Each Line In PageText ' Insert Code between Markers
        If Trim(Line) = Marker2 Then Block2 = True
        If Block1 Or Block2 Then PUSH A, Line
        If Trim(Line) = Marker1 Then NL A: PUSH A, Txt_HTML: NL A: Block1 = False
    Next: ErrMsg = "no code converted"
    Txt_NewHTML = A: If aON(A) Then ErrMsg = "": InsertCodeIntoPage = True
End Function

Sub OverwriteOldDestPageIfOK
    If MsgBox("is Conversion OK ?", vbYesNo, "Insert Code and Save") = vbYes Then _
        RDWRfile WR, Txt_NewHTML, fSpec_Dest: ErrMsg = "New File saved"
    Title = "Msg"
End Sub

' ----------- General Used Procedures ----------------
Class OwnSysSpecs
    Public fSpec_Script, fName_Script, fSpec_INI, fSpec_Protocol, fSpec_ScriptTmp 
    Public Path_BakFiles, Path_LastCodeConverted, ScreenWidth, ScreenHeight
    Private Sub Class_Initialize
        GetMonitorProperties
        GetScriptSpecs
    End Sub
    Private Sub GetMonitorProperties
        Dim strComputer, objWMIService, objItem, colItems, VMD: strComputer = "."
        Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
        Set colItems = objWMIService.ExecQuery("Select * from Win32_VideoController")
        For Each objItem In colItems: VMD = objItem.VideoModeDescription: Next
        ' VMD = 1280 x 1024 x 4294967296 Farben
        VMD = Split(VMD, " x "): ScreenWidth = Eval(VMD(0)): ScreenHeight = Eval(VMD(1))
    End Sub
    Private Sub GetScriptSpecs
        fSpec_Script =              WScript.ScriptFullName
        Path_Script =               FoP(fSpec_Script)
        fName_Script =              FiB(fSpec_Script)
        fSpec_INI =                 BPth(Path_Script, fName_Script & ".INI")
        fSpec_Protocol =            BPth(Path_Script, "Protocol.txt")
        fSpec_ScriptTmp =           BPth(Path_Script, "tmp.txt")
        Path_BakFiles =             BPth(Path_Script, Fldr_BakFiles)
        Path_LastCodeConverted =    BPth(Path_Script, Fldr_LastCodeConverted)
        If Not FoE(Path_BakFiles) Then          fso.CreateFolder(Path_BakFiles)
        If Not FoE(Path_LastCodeConverted) Then fso.CreateFolder(Path_LastCodeConverted)
    End Sub
    Public Function GetfSpecBak(xfSpec)
        GetfSpecBak = BPth(Path_BakFiles, FiB(xfSpec) & ".bak." & FiExt(xfSpec))
    End Function
End Class

Class FilesAndFolders
    ' ----------------------- Files -----------------------
    Public Function GetFiles(BaseFldr, Tree, BaseFldrLeft, SD)
        ' BaseFldr/"", 0/1, False/True, -1/1
        Dim BFL, FL, f1, Fo, af, A: BFL = BaseFldrLeft: GetFiles = A0: A = A0
        FL = INOK(BaseFldr): If FL(0) = "" Then Exit Function
        If Tree Then PUSH A, GetFolders(BaseFldr, Tree, True, 1) Else PUSH A, FL(0)
        For Each Fo In SORT(A, SD): af = A0
            For Each f1 In fso.GetFolder(Fo).Files
                If f1 <> "" Then If BFL Then PUSH af, f1 Else PUSH af, Mid(f1, FL(1)+1)
            Next: PUSH GetFiles, SORT(af, SD): Next
    End Function
    Public Sub KillFile(FiSpec)
        If Not Dummy And FiE(FiSpec) Then fso.DeleteFile FiSpec, True: End If: End Sub
    Public Function SORTfilesForDate(xfSpecs, SD): Dim DT1, DT2, fPos, Found
        Do: Found = False
            For fPos = 0 To Ubd(xfSpecs)-1
               DT1 = fso.GetFile(xfSpecs(fPos)).DateLastModified
               DT1 = GetDateTimeFormatted(DT1)
               DT2 = fso.GetFile(xfSpecs(fPos+1)).DateLastModified
               DT2 = GetDateTimeFormatted(DT2)
               If (SD = 1 And DT2 < DT1) Or (SD = -1 And DT2 > DT1) Then _
                    SWAP xfSpecs(fPos), xfSpecs(fPos+1): Found = True
            Next
        Loop Until Found = False: SORTfilesForDate = xfSpecs
    End Function
    Public Sub DeleteFilesMoreThenNr(xNr, fSpecs): Dim i
        If Not aON(fSpecs) Or xNr < 1 Then Exit Sub
        For i = xNr To Ubd(fSpecs): FiD(fSpecs(i)): Next: End Sub
    Public Sub KeepNrOfFilesDownToMax(xPath): Dim fSpecs
        fSpecs = GetFiles(xPath, False, True, 1)
        fSpecs = SORTfilesForDate(fSpecs, -1)
        DeleteFilesMoreThenNr MaxNrOfCopies,fSpecs
    End Sub
    ' ---------------- Folders -----------------------
    Public Function GetFolders(BaseFldr, Tree, BaseFldrsLeft, SD)
        ' BaseFldr/"", 0/1, False/True, -1/1
        Dim BFL, Path, Fldrs, FoPtr, FL, f1
        BFL = BaseFldrsLeft: Fldrs = A0: GetFolders = A0
        FoPtr = 0: FL = INOK(BaseFldr): If FL(0) = "" Then Exit Function
        Do: If FoPtr = 0 Then Path = FL(0): If Tree Then PUSH Fldrs, Path 
            If FoPtr > 0 Then Path = Fldrs(FoPtr)
            For Each f1 In fso.GetFolder(Path).SubFolders: PUSH Fldrs, f1: Next
            If Not Tree Then Exit Do
        Loop Until INC(FoPtr) > Ubd(Fldrs)
        If BFL Then GetFolders = Fldrs Else _
            For Each Path In Fldrs: PUSH GetFolders, Mid(Path, FL(1)+1): Next
        GetFolders = SORT(GetFolders, SD)
    End Function
    Public Function FolderEmpty(foSpec): Dim f, f1, fo, fi
        FolderEmpty = vbUseDefault ' FolderEmpty = -2 if FolderNotExists
        If FoE(foSpec) Then Set f = fso.GetFolder(foSpec) Else Exit Function
        Set fo = f.SubFolders: Set fi = f.Files: FolderEmpty = True
        If fo.Count > 0 Or fi.Count > 0 Then FldrEmpty = False
    End Function
    ' ----------------- Small Service Routines -----------------------
    Private Function INOK(BaseFldr): Dim BF: INOK = Array("", 0)
        ' INOK(0) = BaseFldr/"", INOK(1) = 0/L
        BF = BaseFldr: If BF = "" Then Exit Function
        If Not FoE(BF) Then Exit Function
        BF = BkSl(BF, -1): BF = UCase(Left(BF, 1)) & Mid(BF, 2): INOK = Array(BF, Len(BF)+1)
    End Function
    Private Function PathValid(AnyPath)
        Dim Pth, drv: Pth = AnyPath: drv = UCase(Left(Pth,1)): PathValid = ""
        If Not (drv >= "A" And drv <= "Z") Then Exit Function
        Pth = Pth & Right (":\", 3 - Len(Pth) And Len(Pth) < 4)
        If Mid(Pth,2,2) <> ":\" Then Exit Function
        If InStr(Pth, "\\") <> 0 Then Exit Function
        If Len(Pth) > 3 Then Pth = BkSl(Pth, -1)
        PathValid = Pth
    End Function
End Class

Function InStrOnly(Subset, AnyString): Dim i, j, c, s: InStrOnly = False
    ' InStrAny(AnyString, "A0 _[]ßäöüÄÖÜ<>|""{}")
    For i = 1 To Len(AnyString): c = Mid(AnyString, i, 1)
        For j = 1 To Len(Subset): s = Mid(Subset, j, 1): InStrOnly = True
            If UCase(s) = "A" And InStr(alphabet, UCase(c)) > 0 Then Exit For 
            If s = "0" And InStr(numerics, c) > 0 Then Exit For
            If InStr(Subset, c) > 0 Then Exit For
            InStrOnly = False
        Next: If Not InStrOnly Then Exit Function
    Next
End Function

Function GetNowTime: GetNowTime = GetDateTimeFormatted(Now): End Function

Function GetDateTimeFormatted(xDT): Dim A, DT:  ' 13.02.2016 11:50:03 -> 20160213115003
    DT = Replace(Replace(xDT, ".", " "), ":", " "): A = Split(DT, " ") ' 13 02 2016 11 50 03
    SWAP A(0), A(2): A(3) = "-" & A(3): GetDateTimeFormatted = Join(A, "")
End Function

Function RemoveSameItems(AnyArray): Dim i, j: i = 0
    While i <= Ubd(AnyArray)-1
        If UCase(Trim(AnyArray(i))) = UCase(Trim(AnyArray(i+1))) Then
            For j = i+2 To Ubd(AnyArray): AnyArray(j-1) = Trim(AnyArray(j)): Next
            DEC i: ReDim Preserve AnyArray(Ubd(AnyArray)-1)
        End If: INC i
    Wend: RemoveSameItems = AnyArray
End Function

Function RemoveLeadingEmptyLines(ByRef AnyArray): Dim item, Ptr, i: Ptr = -1
    RemoveLeadingEmptyLines = False: ErrMsg = "no text in array"
    If IsRid(AnyArray) Then Exit Function
    RemoveLeadingEmptyLines = True: ErrMsg = ""
    For Each item In AnyArray: If Trim(item) = "" Then INC Ptr Else Exit For
    Next: If Ptr < 0 Then Exit Function
    For i = Ptr+1 To Ubd(AnyArray): AnyArray(i-Ptr-1) = AnyArray(i): Next
    ReDim Preserve AnyArray(Ubd(AnyArray)-Ptr)
End Function

Function FIND(AnyArray, AnyString, AnyComp): FIND = -1: Dim item
    If AnyComp <> 0 And AnyComp <> 1 Then Exit Function
    If IsRid(AnyArray) Or AnyString = "" Then Exit Function
    For Each item In AnyArray: INC FIND
        If StrComp (item, AnyString, AnyComp) = 0 Then Exit Function 
    Next: FIND = -1
End Function

Function SORT(xArray, SortDir) ' SortDir Up = 1, Down = -1
    Dim A, ItemPos, Pointer, PointerToPeakValue, CmpOp, SD
    SD = SortDir: A = xArray: SORT = A
    If IsRid(A) Or Abs(SD) <> 1 Then Exit Function
    For ItemPos = 0 To Ubd(A): PointerToPeakValue = ItemPos
        For Pointer = ItemPos + 1 To Ubd(A): CmpOp = 0
            If A(Pointer) < A(PointerToPeakValue) Then CmpOp = -1
            If A(Pointer) > A(PointerToPeakValue) Then CmpOp = 1
            If CmpOp <> SD Then PointerToPeakValue = Pointer
        Next: SWAP A(PointerToPeakValue), A(ItemPos)
    Next: SORT = A
End Function

Function SORTforWordLenght(ByVal AnyArray): Dim i, Flag, A: A = AnyArray: Flag = True
    While Flag = True: Flag = False
        For i = 0 To Ubd(A)-1
            If Len(A(i)) < Len(A(i+1)) Then SWAP A(i), A(i+1): Flag = True 
        Next
    Wend: SORTforWordLenght = A
End Function

Sub PUSH(ByRef xArr, ByVal xVar): Dim item, u
    ' AnyVar can be a String, Numeric or a Variant Array
    For Each item In CArr(xVar): u = Ubd(xArr) + 1
        ReDim Preserve xArr(u): xArr(u) = item: Next: End Sub
Function CArr(ByRef aVar): CArr = aVar
    If Not IsArray(aVar) Then aVar = Array(aVar): CArr = aVar: End If: End Function
Function DEQUEUE(ByRef xArr): If IsRid(xArr) Then Exit Function
    Dim i: DEQUEUE = xArr(0): For i = 1 To Ubd(xArr): xArr(i-1) = xArr(i): Next
    ReDim Preserve xArr(Ubd(xArr)-1)
End Function

Function BPth(aStrg, bStrg): BPth = fso.BuildPath(aStrg, bStrg): End Function
Function Ubd(xA): Ubd = UBound(xA): End Function
Function aON(xA): aON = Ubd(xA) > -1: End Function
Function IsRid(aArray): IsRid = Not aON(aArray): End Function
Function FiE(FiSpec): FiE = fso.FileExists(FiSpec): End Function
Function FiB(FiSpec): FiB = fso.GetBaseName(FiSpec): End Function
Function FiExt(FiSpec): FiExt = fso.GetExtensionName(FiSpec): End Function
Sub FiD(FiSpec): If FiE(FiSpec) Then fso.DeleteFile(FiSpec): End If: End Sub
Function FoE(FoSpec): FoE = fso.FolderExists(FoSpec): End Function
Function FoP(FiSpec): FoP = fso.GetParentFolderName(FiSpec): End Function
Function INC(ByRef AnyNr): AnyNr = AnyNr + 1: INC = AnyNr: End Function
Function DEC(ByRef AnyNr): AnyNr = AnyNr - 1: DEC = AnyNr: End Function
Sub NL(ByRef xArr): PUSH xArr, "": End Sub
Sub ADD(ByRef aStr, ByVal bStr): aStr = aStr & bStr: End Sub
Sub SWAP(byRef xStrg1, byRef xStrg2): Dim sTmp
    sTmp = xStrg1: xStrg1 = xStrg2: xStrg2 = sTmp: End Sub
Function BkSl(ByRef aPath, Mode): Dim bSlsh: bSlsh = Right(aPath,1) = "\"
    ' Backslash, Mode = 1 / -1
    If Mode = 1 And Not bSlsh Then aPath = aPath & "\"
    If Mode = -1 And bSlsh Then CUT aPath, 1: End If: BkSl = aPath
End Function
Function CUT(ByRef s, ByVal i) ' Cutoff bytes from right side
    s = Left(s,(Len(s)- i) And Len(s)>= i): CUT = s: End Function

' ----------- Display-Procedures ----------------

Sub DisplayNewDestPageBeforeOverwrite
    RDWRfile WR, Txt_NewHTML, fSpec_DestTmp
    WshShell.Run "iexplore " & fSpec_DestTmp, 3, True
    WshShell.SendKeys "% x" ' maximises consecutive windows
    FiD fSpec_DestTmp
End Sub

Sub DisplayArray(ByVal AnyArray, Title): Dim A: A = A0 
    PUSH A, "Title of the display = "& Title
    PUSH A, String(50,"="): PUSH A, AnyArray
    RDWRfile WR, A, OWN.fSpec_ScriptTmp
    WshShell.Run "notepad " & OWN.fSpec_ScriptTmp, 3, True
    FiD OWN.fSpec_ScriptTmp
End Sub

Sub DisplayProgress (Mode,AnyText): Dim String1, String2, colServices
    ' Mode = Open, Display, Close
    ' AnyText only used in Display-Mode
    With oExplr: Mode = UCase(Left(Mode,1)) & LCase(Mid(Mode,2))
        Select Case Mode
            Case "Open"
                .Navigate "about:blank"
                .ToolBar = False: .StatusBar = False
                .Width = ProgressBarWidth: .Height = ProgressBarHeight
                .Left = (OWN.ScreenWidth - ProgressBarWidth) \ 2
                .Top = (OWN.ScreenHeight - ProgressBarHeight) \ 2
                .Visible = True
                With .Document
                    .title = ProgressBarTitle
                    .ParentWindow.focus()
                    With .Body.Style
                        .backgroundcolor =  "#F0F7FE"
                        .color =            "#0060FF"
                        .Font =             "11pt 'Calibri'"
                    End With
                End With: While .Busy: Wend
                String1 = "winmgmts:\\.\root\cimv2"
                String2 = "Select * from Win32_Service"
                Set colServices = GetObject(String1).ExecQuery(String2)
            Case "Display": .Document.Body.InnerHTML = AnyText
            Case "Close":   WScript.Sleep 1000: .Quit
        End Select
    End With
End Sub

Sub DisplayProgressText(ProgressX, ProgressMax): If ProgressMax < 0 Then Exit Sub
    Dim Text, margins, m, k, p: Text = ""
    If ProgressMax = 0 Then ProgressMax = 1
    k = ProgressMax \ 100: If k < 1 Then k = 1
    If k > 1 And ProgressX Mod k <> 0 Then Exit Sub
    margins = 2*19+21: m = (ProgressBarWidth - margins): p = ProgressX / ProgressMax
    ADD Text, TAG_p1 & CStr(Int(100 * p)) & TAG_p2
    If m*p > 0 Then ADD Text, TAG_Table1 & CStr(m*p) & TAG_Table2
    DisplayProgress "Display",Text
End Sub

Sub DisplayResult: If ErrMsg = "" Then MsgBox "Job done",,Title Else MsgBox ErrMsg,,Title
End Sub

' ----------- INI-Procedures ----------------

Sub GetPathesFromINI: Dim WriteNew: WriteNew = False
    Do: If Not FiE(OWN.fSpec_INI) Then WriteNew = True: Exit Do
        RDWR_INI RD, INIarray
        If Ubd(INIarray) <> 1 Then WriteNew = True Else _
            WriteNew = Not FoE(INIarray(0)) Or Not FoE(INIarray(1))
    Loop Until True: If WriteNew Then PutPathesToINI
    Path_Source = INIarray(0): Path_Dest = INIarray(1)
End Sub

Sub PutPathesToINI: INIarray = Array(Path_Source, Path_Dest)
    RDWR_INI WR, INIarray: End Sub

Sub RDWR_INI(Dir, ByRef AnyArr): If Dir <> RD And Dir <> WR Then Exit Sub
    RDWRfile Dir, AnyArr, OWN.fSpec_INI: End Sub

' ----------- Harddisk-Procedures ----------------

Sub RDWRfile(ByVal Dir, ByRef AnyList, ByVal xfSpec)
    Dim f, LastLine, Line, format, A: format = False ' False = ASCII
    If Dir = RD Then 'returns lines in an array
        AnyList = A0: If Not FiE(xfSpec) Then Exit Sub
        Set f = fso.OpenTextFile(xfSpec, RD,, format)
        While Not f.AtEndOfStream: PUSH AnyList, f.ReadLine: Wend: f.Close
    ElseIf Dir = WR Then
        If FiE(xfSpec) Then FiD(xfSpec)
        A = AnyList: If Not aON(A) Then Exit Sub
        Set f = fso.OpenTextFile(xfSpec, WR, True, format)
        LastLine = A(Ubd(A)): If Ubd(A) > 0 Then _
            ReDim Preserve A(Ubd(A)-1): For Each Line In A: f.WriteLine Line: Next
        f.Write LastLine: f.Close
    End If
End Sub

' =============== End of Procedures ================