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 Konversion von Power BASIC- und Hta-vbScript- Quellcode in HTML-Text for conversion of Power BASIC- und Hta-vbScript- Source-Code in HTML-text

     Das Programm konvertiert einen einfarbigen Quellcode von 3 BASIC-Dialekten in einen farbigen HTML-Code und fügt ihn in eine Webseite an der richtigen Stelle ein. Beide Dateien werden in einem Datei-Auswahl-Fenster ausgewählt und das Programm merkt sich die Pfade der letzten Auswahl für die nächste Vorauswahl. In der Zieldatei müssen Markierungen gemacht werden, an welcher Stelle der Code eingefügt werden soll. Dann kann man das Programm starten.

Nachdem der konvertierte Code an der richtige Seite eingefügt ist, wird die Seite auf dem Bildschirm angezeigt und nach einem OK durch den Benutzer wird das Ergebnis unter dem alten Namen abgespeichert.

Das Programm ist vollständig in vbScript geschrieben, wobei die Datei-Auswahl-Fenster eine Spezialität ist, die nicht jeder hat.

Die Schlüsselwörter für die blaue Farbe sind in einer Liste einzutippen unter dem Dateinamen: "Keywords-bas-stm.dat" im selben Verzeichnis wie das Script.

Das Programm funktioniert sowohl zur Konversion von Power-BASIC-Source-Code, wie auch von Hta+vbScript-Code zu HTML.

Es berücksichtigt Zeilenvorschübe innerhalb von TAGs, korrigiert Groß- und Kleinschreibung von Schlüsselwörtern und konvertiert Sonderzeichen, wie deutsche Umlaute, in HTML-Code. Und hat eine Fortschrittsanzeige.

     The program converts a mono-color source-code of 3 BASIC-dialects into a colorful HTML-code and inserts it in a website at the right position. Both files are selected in a file-select-window and the program remembers the last choice for the next pre-selection. In the destination-file markers have to be made, at which position the code is to insert. Then the program can be started.

After the converted code is inserted at the right position, the page is displayed on the screen and after an OK by the user the result is stored on disk under the old name.

The program is written completely in vbScript, whereby the file-selection-windows are a speciality, which not has everybody.

The keywords for the blue and other colors are to type-in in a list under the filename: "Keywords-bas-stm.dat" etc. in the same folder as the script.

The program works for conversion of Power-BASIC-Source-Code as well as Hta+vbScript-Code to HTML.

It considers linefeeds within TAGs, corrects lower-case and upper-case characters in keywords and converts special characters, as also german modified vowels, into HTML-Code. And has a progress display.

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
14. Feb. 2016 Feb 14th 2016

These language-selection-windows are generated by the program




After conversion the result is inserted into the destination-file
and the page is displayed on the screen before saving on disk under the same name

the program is updated to better programming methods,
all is tested and should work properly as it is
it shows the volume of code and the complexity needed for that purpose

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

Keywords-vbs-stm.dat

AbsErrorLeftSpace
AndEvalLenSplit
ArrayExecuteLetSqr
AscExecuteGlobalLogStep
AscBExitLoopStop
AtnExpMidStrComp
CBoolExplicitModStrReverse
CByteFalseMsgBoxString
CCurFixNextSub
CDateForNotThen
CDblForReadingNothingTo
CIntForWritingNullTrim
CLngFunctionOnTrue
CSngIfOptionUBound
CStrImpOrUCase
CallInPreserveUntil
CaseInStrPrivateWend
ChrInStrRevPropertyWhile
ClassInputBoxPublicWith
ConstIntRGBXor
CosIsRTrimvbCr
CreateObjectIsArrayRandomizevbCrLf
DimIsDateReDimvbLf
DoIsEmptyReplacevbNo
EachIsNullResumevbOK
ElseIsNumericRightvbOKCancel
ElseIfIsObjectRndvbOKOnly
EmptyJoinRoundvbTab
EndLBoundSelectvbYes
EqvLCaseSetvbYesNo
EraseLTrimSinvbYesNoCancel

Keywords-bas-stm.dat

#COMPILE EXEADDIFRIGHT
#DIM ALLARRAYIMPRIGHT$
#ENDIFASINCRROTATE
#IFASCINPUTRTRIM$
#INCLUDEBROWSEINSERTSAVEFILE
#TOOLSBYREFINSTRSCAN
$CRLFBYVALINTEGERSELECT
%ARCHIVECALLISFILESET
%BIF_EDITBOXCALLBACKISNOTHINGSHIFT
%BN_CLICKEDCASEITERATESHOW
%DEFCBCTLJOIN$SORT
%DS_3DLOOKCBCTLMSGKILLSTATIC
%DS_MODALFRAMECBHNDLLABELSTATUS
%DS_NOFAILCREATECBMSGLBOUNDSTRING
%DS_SETFONTCBWPARAMLCASE$STRREVERSE$
%HIDDENCHR$LEFTSUB
%HWND_DESKTOPCLOSELEFT$SUSPEND
%IDC_BUTTON1COLORLENTAB
%IDC_LABEL1CONTROLLETTAB$
%IDC_LISTBOX1CREATELINETALLY
%IDD_DIALOG1CURDIR$LISTBOXTAN
%LBN_DBLCLKDECLARELOCALTANH
%LBS_NOTIFYDECRLONGTEXT
%NORMALDELETELTRIM$THEN
%OFN_ALLOWMULTISELECTDIALOGMACROTHREAD
%OFN_ENABLESIZINGDIMMCASE$TIME$
%OFN_FILEMUSTEXISTDIR$MEMBERTIMEOUT
%OFN_NOVALIDATEDISPLAYMENUTO
%OFN_OVERWRITEPROMPTDWORDMID$TRACE
%OFN_PATHMUSTEXISTELSEMODALTRIM$
%READONLYELSEIFMSGBOXTRN
%SS_CENTERENDNEWTRY
%SS_SUNKENERASENEXTTXT
%SUBDIRERRORNOTHINGTYPE
%SYSTEMEXE.NAME$NUL$UBOUND
%WHITEEXE.PATH$NULLUCASE$
%WM_COMMANDEXITOBJECTUNTIL
%WM_INITDIALOGEXPOFUSING$
%WM_NCACTIVATEEXTENDEDOFFVAL
%WS_BORDEREXTRACT$ONVARIANT
%WS_CHILDFIELDOPENVARIANT$
%WS_CLIPSIBLINGSFILESCANOPENFILEVERIFY
%WS_DLGFRAMEFILLOUTPUTWEND
%WS_EX_CLIENTEDGEFORPARSEWHILE
%WS_EX_CONTROLPARENTFORMAT$PARSE$WIDTH
%WS_EX_LEFTFUNCTIONPARSECOUNTWINDOW
%WS_EX_LTRREADINGGETPBMAINWORD
%WS_EX_RIGHTSCROLLBARGETATTRPRESERVEWRITE
%WS_POPUPGLOBALPRINTWRITE#
%WS_SYSMENUGOSUBRECORDSXPRINT
%WS_TABSTOPGOTOREDIMXPRINT$
%WS_VISIBLEGRAPHICRESET
%WS_VSCROLLHANDLERESUME

Keywords-bas-ops.dat

&/>=MOD
&=<ANDNOT
(<=EQVOR
)<>IMPXOR
*=ISFALSE\
->ISTRUE