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 jedem BASIC-code in HTML-Text durch Verwendung des Publishers von MS-Office for conversion of any BASIC-Code in HTML-text by use of the Publisher from MS-Office

     der BASIC-Code wird vom Editor per Zwischenablage in den Publisher importiert und dann im HTML-Format exportiert, welches dann mit diesem Programm in eine Form konvertiert wird, dass man es in jede Webseite implementieren kann.

TAB-Zeichen werden im HTML-Text durch Leerzeichen ersetzt, weil der Publisher die TABs nicht richtig verarbeitet, aber damit bei einer Einrückung der Textbeginn immer an derselben Stelle ist, muss die Anzahl der Leerzeichen pro TAB verschieden sein, abhängig von der Position des TAB-Zeichens in der Zeile. Das wird mit der Menü-Funktion "ReplaceTABs" im sw-Quellcode gemacht. Dieser wird dann in den vbScript-Editor geladen und der farbige Text von da mittels Screen-Shot und Zwischenablage in den Publisher eingefügt.

TAB-Zeichen durch Leerzeichen zu ersetzen ist nur bei Code aus dem vbScript-Editor nötig, weil Visual Studio für VB 2015 erzeugt keine TABs im Code. Der Code ohne TABs wird per Zwischenablage in den Publisher importiert.

Der Publisher kann 2 Arten von HTML-text erzeugen, was das Programm automatisch erkennen muss, damit sowohl der Code effizient ist, wie auch die Darstellung mittels Browser fehlerfrei. In der ersten Form ist für jede Zeile ein p-TAG, das einen Zeilenvorschub erzeugt und in welchem sich eine Kette von span-TAGs befindet, mit oder ohne zusätzlichem Zeilenvorschub. Wenn ein Line-Break in einem span-TAG drinnen ist, erkennt das der Browser, aber dann ist kein Zeilenvorschub bei der Betrachtung vom Quell-Text, das macht die Untersuchung für den Programmierer schwieriger. Daher sind die BRs aus den span-TAGs heraus verschoben worden.

Das Programm befaßt sich damit, die Farben und Absätze heraus zu suchen und damit selbst einen Code zu erzeugen.

     the BASIC-code is imported per clipboard into the Publisher and than exported in HTML-Format, which than can be converted by this program into a code, which can be implemented into any website.

TAB-characters are replaced in HTML-text by spaces, because the publisher does not process the TABs correctly, but that by an indent the beginning of the text is always at the same position, the numbers of spaces must be different dependant at which positions the TAB was in the line. This is done by the menu- function "ReplaceTABs" in the black-white source-code. This is thereafter loaded into the vbScript-Editor and the colored text from there into the clip-board by means of screen-shot. And from there pasted into the publisher.

To replace TAB-characters by blanks is only needed for Code from vbScript-Editor, because Visual Studio for VB 2015 generates no TABs in Code. The code without TABs will be imported per clip-board into the publisher.

The publisher can generate two forms of HTML-text, which the program must recognise automaticly, so that the code is efficient, as also the depiction by means of browser free of errors. In the first form for each line there is a p-TAG, which produces a line-feed, in which there is a chain of span-TAGs with or without more line-breaks, in the second there is one p-TAG for the entire text and line-breaks are among the span-TAGs. If some are enclosed in span-TAGs, the browser recognises it, but there is no line-break by the view of the source-text, what makes the investigation harder for the programmer. Therefor the BRs are moved out of the span-TAGs.

The program deals with, to seek out the colors and paragraphs in order to generate a code itsself with it.

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
20. Juli 2016 July 20th 2016

Code for Menu
called from program to select either ReplaceTABs or ConvertHTML
Code in *.hta is shown here, it produces such a Menu-Window


<html>
<head>
<title>Select a Task</title>
<HTA:APPLICATION ID="Menu"
  APPLICATIONNAME="Multiple-selection List Box"
  BORDER="dialog"
  INNERBORDER="no"
  MAXIMIZEBUTTON="no"
  SCROLL="no"
  VERSION="1.0">
</head>

<SCRIPT Language="VBScript">

Option Explicit

Const fName_tmp = "tmp.txt", fExt_Help = ".Help.docx"                   ' Constants

Dim A0: A0 = Array() 
Const RD = 1, WR = 2 ' needed for DisplayResult if BrkErrMsg

Dim OneSelected: OneSelected = False                                    ' Booleans
Dim aParameters, MenuTable, ErrMsg, BrkErrMsg                           ' Arrays
aParameters = A0: MenuTable = A0: ErrMsg = A0: BrkErrMsg = A0

Dim fso:        Set fso = CreateObject("Scripting.FileSystemObject")    ' Objects
Dim WshShell:   Set WshShell = CreateObject("Wscript.Shell")
' OWN needs fso, generates BrkErrMsg
Dim OWN:        Set OWN = New OwnSysSpecs                               ' Classes
Dim CLD:        Set CLD = New Called

' ------------------- Procedures -------------------

Sub Window_OnLoad: Dim ListboxWidth, WindowWidth, WindowHeight  
    Dim objOption, item, i: i = -1
    ' WindowWidth and WindowHeight without listbox
    ListboxWidth = 150: WindowWidth = 70: WindowHeight = 200 
    ' ful automatic listbox size and window size from nr of tasks
    mylistbox.style.width = CStr(ListboxWidth) & "px"
    mylistbox.size =        Ubd(MenuTable) + 1
    WindowWidth =           WindowWidth + ListboxWidth
    WindowHeight =          WindowHeight + 16 * mylistbox.size
    self.ResizeTo WindowWidth, WindowHeight
    self.MoveTo (screen.AvailWidth-WindowWidth)/2, _
                (screen.AvailHeight-WindowHeight)/2
    If BrkErrON() Then Job("") ' from class initialise
    For Each item In MenuTable
        Set objOption = Document.createElement("OPTION")
        objOption.Text = item: objOption.Value = INC(i)
        mylistbox.Add(objOption)
    Next
End Sub

Sub ItemSelected(ButMsg): Dim j, items: items = A0: OneSelected = False
    Select Case ButMsg
    Case "Run"
        For j = 0 To mylistbox.length-1
            If mylistbox(j).selected Then _
                PUSH items, mylistbox(j).Text: OneSelected = True
        Next: Job(items): If OneSelected Then window.close 
    Case "Help": DisplayHelp(OWN.fSpec_Help) 
    End Select
End Sub

Sub Job(SelectedItems): Dim A: A = A0
    If BrkErrON() Then _
        MsgBox Join(BrkErrMsg, vbCrLf): window.close: Exit Sub
    PUSH A, "ErrMsg if any": PUSH A, SelectedItems
    CLD.aTxt = A: If aOff(aParameters) Then MsgBox "Job done"
End Sub

' ======================== General Used Procedures =========================
Class OwnSysSpecs
    Public fSpec, Path, FulName, BaseName, BaseSpec, fSpec_Tmp, fSpec_Help 
    Private Sub Class_Initialize
        GetOwnFileSpec Menu.commandline: If BrkErrON Then Exit Sub
        Path =          FoP(fSpec)
        FulName =       FiN(fSpec)
        BaseName =      FiB(fSpec)
        BaseSpec =      BPth(Path, BaseName)
        fSpec_Tmp =     BPth(Path, fName_tmp)
        fSpec_Help =    BaseSpec & fExt_Help
    End Sub

    Sub GetOwnFileSpec(HTA_ID_CmdLine) ' HTA_ID_CmdLine = Menu.commandline
        ' HTA_ID_CmdLine comes from <HTA:APPLICATION ID="Menu"
        fSpec = deqo(Trim(HTA_ID_CmdLine))
        If Not FiE(fSpec) Then PUSH BrkErrMsg, "no own-fSpec found"
    End Sub
End Class

Class Called: Private A ' for handover of data and run external files
    Private Sub Class_Initialize: Dim Caller, Called
        Do: RDWRfile RD, A, OWN.fSpec_Tmp:      If aOFF(A) Then Exit Do
            Caller = LCase(FiB(DEQUEUE(A))):    If aOFF(A) Then Exit Do
            Called =  LCase(Split(OWN.BaseName, ".")(0))
            If Caller = "" Or  Called = "" Then A = A0
            If Caller <> Called Then A = A0
        Loop Until True: aParameters = A
        GetMenuTable: WRbrkOffMsgOnDisk("") ' For Breakoff by the User
    End Sub
    Private Sub GetMenuTable: Dim i, A: A = A0: If BrkErrON() Then Exit Sub
        Do: If aON(aParameters) Then PUSH A, aParameters: Exit Do
            For i = 1 To 13: PUSH A, "item-" & Right("0" & CStr(i),2): Next
        Loop Until True: MenuTable = A
    End Sub
    Public Property Get aTxt(): aTxt = aParameters: End Property
    Public Property Let aTxt(Value): WRbrkOffMsgOnDisk(Value): End Property
    Private Sub WRbrkOffMsgOnDisk(Value): A = A0
        PUSH A, OWN.FulName: PUSH A, CArr(Value)
        RDWRfile WR, A, OWN.fSpec_Tmp
    End Sub
End Class

Sub DisplayHelp(fSpec)
    If Not FiE(fSpec) Then MsgBox "no Helpfile found",,"Error": Exit Sub
    WshShell.Run fSpec, 1, True ' 3 = Fulscreen, True = Wait for Pgm finish
End Sub

Sub PUSH(ByRef AnyArr, ByVal AnyVar): Dim item, u: CArr AnyArr: CArr AnyVar
    ' AnyVar can be a String, Numeric or a Variant Array
    For Each item In AnyVar: u = Ubd(AnyArr) + 1
    ReDim Preserve AnyArr(u): AnyArr(u) = item: Next
End Sub

Sub QUEUE(ByRef AnyArr, ByVal AnyVar)
    CArr AnyVar: PUSH AnyVar, AnyArr: AnyArr = AnyVar: End Sub

Function DEQUEUE(ByRef xArr) ' Pop from LowBound, returns only one single item
    DEQUEUE = vbNull: If aON(xArr) Then DEQUEUE = xArr(0): DelItem xArr, 0
End Function

Sub DelItem(ByRef xArr, ByVal xPos): Dim i, A: A = xArr
    If aOFF(A) Or xPos < 0 Or  xPos > Ubd(A) Then Exit Sub
    For i = xPos To Ubd(A) - 1: A(i) = A(i + 1): Next
    ReDim Preserve A(Ubd(A)-1): xArr = A
End Sub 

Sub SWAP(ByRef AnyVar1, ByRef AnyVar2)
    Dim vTmp: vTmp = AnyVar1: AnyVar1 = AnyVar2: AnyVar2 = vTmp: End Sub
Function CArr(ByRef aVar): CArr = aVar: If Not IsArray(aVar) Then _
    aVar = Array(aVar): CArr = aVar: End If: End Function
Function INC(ByRef AnyNr): AnyNr = AnyNr + 1: INC = AnyNr: End Function
Function FiE(FiSpec): FiE = fso.FileExists(FiSpec): End Function
Function FiB(FiSpec): FiB = fso.GetBaseName(FiSpec): End Function
Function FiN(FiSpec): FiN = fso.GetFileName(FiSpec): End Function
Sub FiD(FiSpec): If FiE(FiSpec) Then fso.DeleteFile(FiSpec): End If: End Sub
Function FoP(FiSpec): FoP = fso.GetParentFolderName(FiSpec): End Function
Function BrkErrON: BrkErrON = aON(BrkErrMsg): End Function
Function BPth(xStr1, xStr2): BPth = fso.BuildPath(xStr1, xStr2): End Function
Function Ubd(xA): Ubd = UBound(xA): End Function
Function aON(xA): aON = Ubd(xA) > -1: End Function
Function aOFF(xA): aOFF = Not aON(xA): End Function
Function qo(xStr): qo = """" & xStr & """": End Function
Function deqo(xStr): deqo=xStr: Dim L: L=Len(xStr): If L<2 Then Exit Function
    If Left(xStr,1) & Right(xStr,1) = """""" Then deqo = Mid(xStr,2,L-2)
End Function

Sub RDWRtmpMsg(Dir, ByRef Msg): RDWRfile Dir, Msg, OWN.fSpec_Tmp: End Sub

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

</SCRIPT>

<body bgcolor="buttonface">
<p align="center">Convert HTML<BR>from Publisher<BR><BR>
<select name="mylistbox"></select><BR><BR>
<table border="0" cellpadding="0" cellspacing="0"><!-- button-positioning -->
    <colgroup><col width="35"><col width="35"><col width="25">
        <col width="35"><col width="34"></colgroup><tr><td></td>
    <td align="center"><!-- button Run -->
        <input type="button"
            name="Run" id="Run" value="Run " onclick="ItemSelected('Run')">
    </td><td></td>
    <td align="center"><!-- button Help -->
        <input type="button" 
            name="Help" id="Help" value="Help" onclick="ItemSelected('Help')">
    </td><td></td></tr>
</table></p></body></html>

Program
for conversion from HTML-format exported from publisher to own HTML-format

' Program in vbScript
' Converts HTML-code produced by Publisher for inserting into website
' Code from Publisher / Export / HTML publish / Website HTML / HTML publish

Option Explicit

' Constants and Variables Definitions before Classes
Const SubFldrs =            "ToPublish,htm"
Const Path_HomePage =       "C:\YourPath"
Const fExt_Called =         ".Menu.hta"
Const fExt_Help =           ".Help.docx"
Const nExt_TABsReplaced =   ".TABsReplaced"
Const MenuItems1 =          "ReplaceTABs,ConvertHTML"
Const Titles =              "ScriptFile,SourceFile,DestFile" ' On FileSelectWindows
Const ErrTxt =              "BreakOff by the user"

Dim A0, CR0: A0 = Array(): CR0 = vbNullChar

' needed here for DisplayResult if BrkErrMsg
Const RD = 1, WR = 2
Dim ErrMsg, BrkErrMsg, Report, aErrTxt: ErrMsg = A0: BrkErrMsg = A0: Report = A0
SetupArrayStyleOfVariables ' after Const ErrTxt
Dim WshShell: Set WshShell = CreateObject("WScript.Shell")

' fso needed here for OWN
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")

Do: ' OWN needs fso, generates BrkErrMsg
    Dim OWN: Set OWN = New OwnSysSpecs: If BrkErrON() Then Exit Do
    Dim CLR: Set CLR = New Caller:      If BrkErrON() Then Exit Do
    Dim RTB: Set RTB = New ReplaceTABsByBlanks
    Dim CHC: Set CHC = New ConvertHTMLcode
    Dim SCM: Set SCM = New SourceCodeMarkers
   
    ' Declarations of Variables
    Dim Txt_NewHTML, fSpecWebSite, Title, sTAG0                 ' Strings (Title for Err-Msg)
    Dim aTABLES, aTitles                                        ' Arrays
    Dim aMarkers, StyleSheets, mmDe, mmEn
    Dim aMenuItems1, aFehler
    Dim aMarkersCode, aMarkersDate, aTAGsCmt, mLines
   
    ' Constants and Variables Definitions after Classes
    Const numerics = "0123456789"
    Const HTMLSpecChrs = "<>&""§äöüÄÖÜß;lt;gt;amp;quot;sect;auml;ouml;uuml;Auml;Ouml;Uuml;szlig"
    Const monthsDe = "Jänner,Feber,März,Apr.,Mai,Juni,Juli,Aug.,Sept.,Okt.,Nov.,Dez."
    Const monthsEn = "Jan,Feb,Mar,Apr,May,June,July,Aug,Sept,Oct,Nov,Dec"

    Const TAGsCmt = "<!-- , -->"
    Const Markers = "Start, of Source-Code#,End;Date, ge, en"
    ' aMarkersCode(0) = "<!-- Start of Source-Code# -->"
    ' aMarkersCode(1) = "<!-- End of Source-Code# -->"
    ' aMarkersDate(0) = "<!-- Date ge -->"
    ' aMarkersDate(1) = "<!-- Date en -->"
   
    Const sTAG01 = "<span lang=de style='font-family:Courier New;font-size:10.0pt;color:#000000;'>"
    Const sTAG02 = "<span class=""HTML"">": sTAG0 = sTAG01
    Const StyleSheet = "span.HTML ,<style type=""text/css"">,<!--,-->,</style>"
    Const SpanStyle = "span.HTML {lang:de;font-family:Courier New;font-size:10.0pt;color:#000000;'}"
    Const sTAG1 = "<span>", sTAG2 = "</span>", sTAGc1 = "<span style='color:", sTAGc2 = "'>"
    Const TABLES = "<table ,</table>"
    Const Fehler1 = "<span style='color:blue'>To</span><span>2</span>"
    Const Fehler2 = "<span style='color:blue'>To</span><span> 2</span>"
   
    ' =============== Parameters For Browsefile ======================
    Dim ScriptPath, SourcePath, DestPath, fSpec_ToPublish
    ' WshShell needed here unless exist
    ScriptPath =        "YourPath1"
    SourcePath =        "YourPath2"
    DestPath =          "YourPath3"
    fSpec_ToPublish =   "YourFileSpec"
    Const ExtFilterScript = "vbs files|*.vbs|All Files|*.*"
    Const ExtFilterSource = "HTML files|*.htm*|All Files|*.*"
    Const ExtFilterDest =   "HTML files|*.htm*|All Files|*.*"
    ' =========== End of Parameters For Browsefile ====================
    SetupArrayStyleOfVariables
   
    ' =================================== Program =====================================
    Main
    DisplayResult
Loop Until True

' =================================== Procedures =====================================
Sub SetupArrayStyleOfVariables
    If Not IsObject(CLR) Then aErrTxt = Split(ErrTxt, ","): Exit sub
    aMenuItems1 =   Split(MenuItems1, ",")
    aTABLES =       Split(TABLES, ",")
    aTitles =       Split(Titles, ",")
    aMarkers =      Split(Markers, ",")
    StyleSheets =   Split(StyleSheet, ",")
    mmDe =          Split(monthsDe, ",")
    mmEn =          Split(monthsEn, ",")
    aFehler =       Array(Fehler1, Fehler2)
   
    Dim CD, A1, A2: aTAGsCmt = Split(TAGsCmt, ",")
    CD = Split(Markers, ";"): A1 = Split(CD( 0),","): A2 = Split(CD( 1),",")
    aMarkersCode = Array(enTAG(A1( 0) & A1( 1)), enTAG(A1( 2) & A1( 1)))
    aMarkersDate = Array(enTAG(A2( 0) & A2( 1)), enTAG(A2( 0) & A2( 2)))
End Sub

Sub Main
    ' ------------ Call Menu and Get Response -----------------
    CallMenu( 1)
End Sub

' =========================== Class ReplaceTABsByBlanks ===========================
Class ReplaceTABsByBlanks
    Public Sub Main: Dim fSpec, HTMLtxt, A: A = A0
        ' Get Code from Source
        If Not GetFileSpec(fSpec, aTitles( 0)) Then Exit Sub
        If Not FiE(fSpec) Then PUSH BrkErrMsg, "file " & fSpec & " not found": Exit Sub
        RDWRfile RD, HTMLtxt, fSpec
        PUSH A, HTMLtxt
        DisplayArray A, "vbScript"
        ReplaceTabs  A
        DisplayArray A, "vbScript, TABreplaced"
        RDWRfile WR, A, GetfSpecOut(fSpec)
    End Sub

    Private Function GetFileSpec(ByRef xfSpec, xTitle): Dim fExt, P, A: A = A0
        PUSH A, "Unknown Browsefile-Title": PUSH A, "no valid file chosen"
        P = GetParameters(xTitle): GetFileSpec = False
        If Not aON(P) Then PUSH BrkErrMsg, A( 0): Exit Function
        Do: xfSpec = BrowseFile(P): fExt = LCase(FiExt(xfSpec))
            If xfSpec = "" Or fExt = "vbs" Then Exit Do
            MsgBox A( 1)
        Loop: If xfSpec <> "" Then GetFileSpec = True: Exit Function
        Select Case xTitle
            Case "ScriptFile": PUSH BrkErrMsg, aErrTxt( 0)
        End Select
    End Function

    Private Sub ReplaceTabs(ByRef aTxt): Dim i, LineNr, s: If Not aON(aTxt) Then Exit Sub
        ' 5,9,13, .... 1-4 -> 5   5-8 -> 9
        ' space(4-((i-1) Mod 4))
        For LineNr = 0 To Ubd(aTxt): i = 1
            Do: i = InStr(i, aTxt(LineNr), vbTab): If i = 0 Then Exit Do
                s = Space( 4-((i- 1) Mod 4))
                aTxt(LineNr) = Substitute(aTxt(LineNr), i, i, s)
                i = i + Len(s) - 1
            Loop
        Next
    End Sub
   
    Private Function GetfSpecOut(xfSpec): Dim fBase, fExt
        fBase = FiB(xfSpec): fExt = "." & FiExt(xfSpec)
        GetfSpecOut = BPth(FoP(xfSpec), fBase & nExt_TABsReplaced & fExt)
    End Function
End Class

' ============================= Class ConvertHTMLcode =============================
Class ConvertHTMLcode
    Public Sub Main: Dim HTMLtxt, SingleLineTxt, HTMLtxtIn, HTMLtxtOut, HTMLtxtWebSite
        Dim fSpec, A: A = A0: HTMLtxtOut = A0
    ' Get Code from Source
        If Not GetFileSpec(fSpec, aTitles( 1)) Then Exit Sub
        RDWRfile RD, HTMLtxt, fSpec
        PUSH A, HTMLtxt
        HTMLtxtIn = GetTextInTable(A)
        SingleLineTxt = GetSingleLineFromHTMLtxt(A) ' Removes vbCrLfs correctly, UCase("<br>")
        RemoveUnwantedCode SingleLineTxt ' f.i. <span dir=ltr></span>
        ReplaceBlanks SingleLineTxt
    ' ===================================
        HTMLtxtOut = ConvertTxt(SingleLineTxt)
        ' push contents of <p>-TAGs and <span>-TAGs in Arrays
    ' ===================================
        RDWRfile WR, HTMLtxtOut, GetfSpecOut(fSpec)
        DisplayArray HTMLtxtIn, "HTMLtxtIn"
        DisplayArray HTMLtxtOut, "HTMLtxtOut"
    ' Get Code from Destination
        If Not GetFileSpec(fSpecWebSite, aTitles( 2)) Then Exit Sub
        RDWRfile RD, HTMLtxtWebSite, fSpecWebSite
            SCM.GetAllMarkers(HTMLtxtWebSite): If aON(BrkErrMsg) Then Exit Sub
        If Not CallMenu( 2) Then Exit Sub ' Call Menu and Get Response
    ' Put Code into Destination
        Txt_NewHTML = HTMLtxtWebSite
        If Not InsertCodeBetweenMarkers(Txt_NewHTML, mLines, HTMLtxtOut) Then Exit Sub
        InsertDate Txt_NewHTML
        CorrectFehler Txt_NewHTML
        DisplayNewDestPage "before" ' BeforeOverwrite
        If Not GetOKforOverwritePage Then Exit Sub
        OverwriteOldDestPage ' Txt_NewHTML, fSpec_Dest
        DisplayNewDestPage "after" ' AfterOverwrite
    End Sub
   
    Private Function GetFileSpec(ByRef xfSpec, xTitle): Dim fExt, P, aMsg: aMsg = A0
        PUSH aMsg, Array("no valid file chosen", aErrTxt( 0))                ' aMsg(0, 1)
        PUSH aMsg, Array("job done, no Dest-File chosen", "file not found") ' aMsg(2, 3)
        PUSH aMsg, Array("SourceFile", "DestFile")                          ' aMsg(4, 5)
        PUSH aMsg, Array("Unknown Browsefile-Title")                        ' aMsg(6)
        P = GetParameters(xTitle): GetFileSpec = False
        If Not aON(P) Then PUSH BrkErrMsg, aMsg( 6): Exit Function
        Do: xfSpec = BrowseFile(P): fExt = LCase(FiExt(xfSpec))
            If xfSpec = "" Or InStr(enDot("htm.html"), enDot(fExt)) > 0 Then Exit Do
            MsgBox aMsg( 0)
        Loop:   If xfSpec = "" Then
                    Select Case xTitle
                        Case aMsg( 4): PUSH BrkErrMsg, aMsg( 1)
                        Case aMsg( 5): PUSH BrkErrMsg, aMsg( 2)
                    End Select
                ElseIf FiE(xfSpec) Then
                    GetFileSpec = True
                Else: PUSH BrkErrMsg, aMsg( 3)
                End If
    End Function

    Private Function GetTextInTable(ByRef xTxt): Dim xLine, Line, T, A, TableON
        T = aTABLES: A = Array(""): TableON = False
        For Each xLine In xTxt: Line = Trim(xLine)
            If Left(Line, L(T( 1))) = T( 1) Then TableON = False
            If TableON Then PUSH A, Line
            If Left(Line, L(T( 0))) = T( 0) Then TableON = True
        Next: xTxt = A: GetTextInTable = A
    End Function
   
    Private Function GetSingleLineFromHTMLtxt(ByVal xTxt): Dim OneLine
        OneLine = Join(xTxt, vbCrLf)
        OneLine = Replace(OneLine, ">" & vbCrLf & "<", "><")
        OneLine = Replace(OneLine, vbCrLf, " ")
        OneLine = Replace(OneLine, "<br>", "<BR>")
        GetSingleLineFromHTMLtxt = OneLine
    End Function
   
    Private Sub RemoveUnwantedCode(xOneLine)
         ' <span dir=ltr> = Schreibrichtung vom Text
        xOneLine = Replace(xOneLine, "<span dir=ltr></span>", " ")
    End Sub

    Private Function ReplaceBlanks(ByRef xTxt): Dim Line, A, IsA: A = A0
        IsA = IsArray(xTxt)
        For Each Line In CArr(xTxt)
            Line = Replace(Line, "&#8194;", " ")
            Line = Replace(Line, Chr( 160), " ")
            PUSH A, Line
        Next: If IsA Then xTxt = A Else xTxt = Join(A, "")
        ReplaceBlanks = xTxt
    End Function
   
' ---------------------------------- Convert Text ------------------------------------
    Private Function ConvertTxt(ByVal xLine): Dim A: A = A0
        A = deTAG(xLine)
        A = ExtractBRs(A)
        A = ReduceAttributes(A)
        A = RemoveColorsForBlanks(A)
        A = FirstColorBlackRemove(A)
        ' Special Chars already replaced by the Publisher
        A = ReplaceBlanksToNbsps(A) ' &nbsp;s are needed only before finish to display
        A = enTAGtxt(A)
        FontFormatText "Add", A
        PrecedeSingleBRsToNextLine A
        A = LineUpSpans(A)
        RemoveConsecutiveSameColorTAGs A
        ConvertTxt = A
    End Function
   
    Private Function deTAG(ByVal xLine): Dim pContent, Span, aSpan, A, aP: A = A0
        For Each pContent In GetTAGinfo("p", xLine): aP = Split(pContent, CR0)
            ' PreTxt = aP(0), Col = aP(1), pContent = aP(2)
            For Each Span In GetTAGinfo("span", aP( 2)): aSpan = Split(Span, CR0)
                aSpan( 2) = RemoveBlanksBeforeNumbers(aSpan( 2))
                aSpan( 1) = GetColor(aSpan( 1))
                PUSH A, Join(aSpan, CR0)
            Next: PUSH A, "<BR>"
        Next: deTAG = A
    End Function

    Private Function GetColor(xLine): Dim i, c, clip, col: GetColor = ""
' lang=de style='font-size:9.5pt;line-height:119%;font-family:Consolas; color:blue;language:de'
' style='color:blue;'
        i = InStr(xLine, "style='"): If i = 0 Then Exit Function
        clip = Mid(xLine, i+ 7): If Len(clip) < 1 Then Exit Function
        clip = Mid(clip, 7): i = InStr(clip, "'"): If i > 0 Then clip = Left(clip, i- 1)
        i = InStr(clip, "color:"): If i = 0 Then Exit Function
        clip = Mid(clip,i+ 6): c = ";": If Len(clip) < 1 Then Exit Function
        Do: i = InStr(clip, c): If i > 0 Then Exit Do
            If c <> " " Then c = " " Else Exit Do
        Loop: If i = 0 Then i = Len(clip) Else i = i- 1: End If: col = Left(clip, i)
        If col <> "" Then GetColor = " style='color:" & col & ";'"
    End Function
   
    Private Function ExtractBRs(ByVal aTxt): Dim Line, aLine, A: A = A0
        For Each Line In aTxt
            Do: If Line = "" Then Exit Do
                aLine = Split(Line, CR0): If Ubd(aLine) <> 2 Then Exit Do
                If Split(Line, CR0)( 2) = "<BR>" Then Line = "<BR>"
            Loop Until True: PUSH A, Line
        Next: ExtractBRs = A
    End Function
   
    Private Function ReduceAttributes(ByVal aTxt): Dim Line, aLine, A, i, j
        A = A0: i = 0: j = 0
        For Each Line In aTxt
            Do: If Line = "" Then Exit Do
                aLine = Split(Line, CR0): If Ubd(aLine) <> 2 Then Exit Do
                i = InStr(aLine( 1), "color:"): If i = 0 Then Exit Do
                j = InStr(i+ 6, aLine( 1), ";"): aLine( 1) = SubStrg(aLine( 1), i+ 6, j- 1)
                Line = Join(aLine, CR0)
            Loop Until True: PUSH A, Line
        Next: ReduceAttributes = A
    End Function
   
    Private Function RemoveColorsForBlanks(aTxt): Dim Line, aLine, A: A = A0
        For Each Line In aTxt
            Do: If Line = "" Then Exit Do
                aLine = Split(Line, CR0): If Ubd(aLine) <> 2 Then Exit Do
                If Replace(aLine( 2), " ", "") = "" Then aLine( 1) = ""
                Line = Join(aLine, CR0)
            Loop Until True: PUSH A, Line
        Next: RemoveColorsForBlanks = A
    End Function
   
    Private Function FirstColorBlackRemove(aTxt): Dim Line, aLine, Break, A: A = A0: Break = False
        For Each Line In aTxt
            Do: If Line = "" Then Exit Do
                If Line = "<BR>" Then Break = True: Exit do
                aLine = Split(Line, CR0): If Ubd(aLine) <> 2 Then Exit Do
                If Break Then
                    If aLine( 1) = "black" Or aLine( 1) = "#000000" Then aLine( 1) = ""
                    Break = False
                End If: Line = Join(aLine, CR0)
            Loop Until True: PUSH A, Line
        Next: FirstColorBlackRemove = A
    End Function
   
    Private Function ReplaceBlanksToNbsps(aTxt): Dim Line, aLine, A, i, c, txt, Blk2, Nr: A = A0
        For Each Line In aTxt
            Do: If Line = "" Then Exit Do
                aLine = Split(Line, CR0): If Ubd(aLine) <> 2 Then Exit Do
                txt = "": Blk2 = False
                For i = Len(aLine( 2)) To 1 Step - 1: c = Mid(aLine( 2),i, 1)
                    Do: If c <> " " Then Blk2 = False: Exit Do
                        If Blk2 Then c = "&nbsp;"
                        Blk2 = True
                    Loop Until True: txt = c & txt         
                Next: aLine( 2) = txt: Line = Join(aLine, CR0)
            Loop Until True: PUSH A, Line
        Next: ReplaceBlanksToNbsps = A 
    End Function
   
    Private Function enTAGtxt(aTxt): Dim Line, aLine, Col, xTG1, A: A = A0
        For Each Line In aTxt
            Do: If Line = "" Then Exit Do
                aLine = Split(Line, CR0): If Ubd(aLine) <> 2 Then Exit Do
                Col = aLine( 1)
                If Trim(Replace(aLine( 2), "&nbsp;", " ")) <> "" Then
                    If Col = "" Then xTG1 = sTAG1 Else xTG1 = sTAGc1 & Col & sTAGc2
                    If IsNumber(aLine( 2)) Then aLine( 2)= " " & aLine( 2)
                    Line = xTG1 & aLine( 2) & sTAG2
                Else: Line = aLine( 2)
                End If
            Loop Until True: PUSH A, Line
        Next: enTAGtxt = A
    End Function
   
    Private Sub FontFormatText(Mode, ByRef xTxt): Dim LineNr, A: A = A0
        If Mode = "Replace" Then
            xTxt( 1) = sTAG0 & xTxt( 1)
            xTxt(Ubd(xTxt)- 1) = xTxt(Ubd(xTxt)- 1) & sTAG2
            For LineNr = 1 To Ubd(xTxt)- 1:  PUSH A, xTxt(LineNr): Next
            xTxt = A
        ElseIf Mode = "Add" Then
            PUSH A, sTAG0: PUSH A,xTxt: PUSH A, sTAG2: xTxt = A
        End If
    End Sub
   
    Private Sub PrecedeSingleBRsToNextLine(ByRef xTxt): Dim Line, buf, A, x: A = A0: buf = ""
        For Each Line In CArr(xTxt): x = RTrim(Replace(Line, "&nbsp;", " "))
            If x = "" Or x = "<BR>" Then buf = buf & Line Else _
                                        PUSH A, buf & Line: buf = ""
        Next: If buf <> "" Then PUSH A, buf
        xTxt = A
    End Sub
   
    Private Function LineUpSpans(xTxt)
        LineUpSpans = Split(Replace(Join(xTxt, ""), "<BR>", vbcrlf & "<BR>"), vbcrlf)
    End Function
    ' -----------------------------End of Convert Text--------------------------------
   
    ' -----------------------------Subs for Convert Text------------------------------
    Private Function GetTAGinfo(xTAG, ByVal xLine): Dim t, A: A = A0
        Do: t = GetNextTAGparams(xLine, xTAG, 1): If t( 1) = 0 Then Exit Do
            PUSH A, Join(Array(t( 5), t( 6), t( 7)), Chr( 0))
            xLine = Mid(xLine, t( 4)+ 1)
        Loop: GetTAGinfo = A
    End Function
   
    Private Function GetNextTAGparams(xLine, xT, x1): Dim A, TG1, TG2, L1, L2
        A = Array( 0, 0, 0, 0, 0,"","",""): GetNextTAGparams = A
        If Not(xT = "span" Or xT = "p") Then Exit Function
        TG1 = "<" & xT: TG2 = "</" & xT & ">" ' xT = "span" or "p"
        L1 = Len(TG1): L2 = Len(TG2)
        A( 1) = InStr(x1, xLine, TG1): If A( 1) = 0 Then Exit Function
        A( 2) = InStr(A( 1)+L1, xLine, ">"): If A( 2) = 0 Then Exit Function
        A( 3) = InStr(A( 2)+ 1, xLine, TG2): If A( 3) = 0 Then Exit Function
        A( 4) = A( 3) + L2 - 1
        A( 5) = SubStrg(xLine, x1, A( 1) - 1)         ' PreTxt
        A( 6) = SubStrg(xLine, A( 1) + L1, A( 2) - 1)  ' Attributes
        A( 7) = SubStrg(xLine, A( 2) + 1, A( 3) - 1)   ' Content
        GetNextTAGparams = A
    End Function
   
    Private Function ReplaceSpecialChars(aTxt): Dim Line, aLine, sc, txt, c, p, i, A: A = A0
        sc = Split(HTMLSpecChrs,";")
        For Each Line In aTxt
            Do: If Line = "" Then Exit Do
                aLine = Split(Line, CR0): If Ubd(aLine) <> 2 Then Exit Do
                txt = ""
                For i = 1 To Len(Line): c = Mid(Line,i, 1): p = InStr(sc( 0),c)
                    If p > 0 Then txt = txt & "&" & sc(p) & ";" Else txt = txt & c
                Next: aLine( 2) = txt: Line = Join(aLine, CR0)
            Loop Until True: PUSH A, Line
        Next: ReplaceSpecialChars = A
    End Function
   
    Private Function ReplaceNbsPs(ByRef xTxt): Dim Line, A: A = A0
        For Each Line In CArr(xTxt)
            Line = Replace(Line, " ", "&nbsp;")
            'Line = Replace(Line, " ", chr(160))
            PUSH A, Line
        Next: xTxt = A: ReplaceNbsPs = A
    End Function
       
    Private Sub RemoveConsecutiveSameColorTAGs(ByRef xTxt)
        ' <span style='color:blue'>Public</span>&nbsp;<span style='color:blue'>
        ' 1.......................2......3.....4......1.......................2
        Dim aT1, aT2, i, x1, Bytes, Ctr, Msg: Msg = A0
        PUSH Msg, "Nr of ConsecutiveSameColorTAGs Removed: "
        PUSH Msg,  Array(", Nr of Bytes = ", " out of: ")
        ReDim aT1( 7): ReDim aT2( 7): Ctr = 0: Bytes = Len(Join(xTxt, ""))
        For i = 0 To Ubd(xTxt): x1 = 1
            Do: Do: aT1 = GetNextTAGparams(xTxt(i), "span", x1)
                    If aT1( 1) = 0 Then Exit Do
                    aT2 = GetNextTAGparams(xTxt(i), "span", aT1( 4)+ 1)
                    If aT2( 1) = 0 Then Exit Do
                    If aT1( 6) <> aT2( 6) Then x1 = aT1( 4) + 1 Else Exit Do
                Loop: If aT1( 1) = 0 Or aT2( 1) = 0 Then Exit Do
                xTxt(i) = Substitute(xTxt(i), aT1( 3), aT2( 2), aT2( 5)): INC Ctr
            Loop
        Next: PUSH Report,  Msg( 0) & CStr(Ctr) & _
                            Msg( 1) & CStr(Bytes - Len(Join(xTxt, ""))) & _
                            Msg( 2) & CStr(Bytes)       
    End Sub
   
    Private Function GetfSpecOut(xfSpec): Dim fBase, fExt
        fBase = FiB(xfSpec): fExt = "." & FiExt(xfSpec)
        GetfSpecOut = BPth(FoP(xfSpec), fBase & ".Output" & fExt)
    End Function
   
    Public Function InsertCodeBetweenMarkers(ByRef aText, ByVal aCodeLines, ByVal Code)
        Dim LineNr, p, A: LineNr = - 1: p = aCodeLines: A = A0
        InsertCodeBetweenMarkers = False
        Do: INC LineNr ' Insert Code between Markers
            If LineNr <= p( 0) Or LineNr > p( 1) Then
                PUSH A, aText(LineNr)
            Else: NL A: PUSH A, Code: NL A: LineNr = p( 1): PUSH A, aText(LineNr)
            End If
        Loop Until LineNr = Ubd(aText)
        If aOFF(A) Then PUSH BrkErrMsg, "no code converted"
        aText = A: InsertCodeBetweenMarkers = True
    End Function
   
    ' Date --------------  
    Private Sub InsertDate(ByRef xTxt): Dim Line, LineNr, i, j, k, c, s, lg
        Dim Mask, NewDate, DF: s = String( 5, "-"): DF = False
        Dim DateInfo( 1, 2), Dlg, r, aMasks( 1, 3), A: A = A0
        Dlg = Array("<!-- Date ge -->", "<!-- Date en -->")
        PUSH A, Array(">#. @", ">##. @", " ####<", " ####<")
        PUSH A, Array(">@", ">@", " #<@@@>@@<@@@@> ####<", " ##<@@@>@@<@@@@> ####<")
        For i = 0 To 1: For j = 0 To 3: aMasks(i,j) = A( 4*i+j): Next: Next: A = A0
        PUSH Report, s & " Date Replace " & s
        For Each Line In xTxt: i = 0: j = 0: r = A0
            Mask = GetMaskFromLine(lg, aMasks, Dlg, Line) ' lg comes out
            Do: If Mask = "" Then PUSH A, Line: Exit Do
                GetDateij i, j, Mask, aMasks, lg
                If i = 0 Or j = 0 Then PUSH A, Line: Exit Do
                NewDate = GetDateFormatted(lg): DF = True
                r = " date" & aMarkers(lg+ 3) & ": "
                PUSH Report, "old" & r & SubStrg(Line, i, j)
                PUSH Report, "new" & r & NewDate
                PUSH A, Substitute(Line, i, j, NewDate)
            Loop Until True
        Next: If DF Then xTxt = A: Exit Sub
        PUSH Report, "no date replaced"
    End Sub
   
    Private Function GetDateFormatted(lg): Dim D, i, dd, de, sD, aEnd, e
        d = Split(Date, ".") ' dd.mm.yy
        For i = 0 To 1: d(i) = CStr(Eval(d(i))): Next
        dd = d( 0) & ". " & mmDe(Eval(d( 1)- 1)) & " " & d( 2)
        aEnd = Array( 1,"st", 2, "nd", 3, "rd", 21, "st", 22, "nd", 31, "st"): e = "th"
        For i = 0 To UBound(aEnd) Step 2
            If Eval(d( 0)) = aEnd(i) Then e = aEnd(i+ 1)
        Next: de = mmEn(Eval(d( 1)- 1)) & " " & d( 0) & "<sup>" & e & "</sup> " & d( 2)
        sD = Array(dd, de): GetDateFormatted = sD(lg)
    End Function
   
    Private Function GetMaskFromLine(ByRef lg, aMasks, Dlg, xLine): Dim i, j, c, s, Mask
        For lg = 0 To 1: i = InStrRev(xLine,Dlg(lg)): Mask = ""
            If i > 0 Then
                For j = 1 To i- 1
                    c = Mid(xLine, j, 1): s = "@"
                    If IsNumber(c) Then s = "#"
                    If InStr(". <>", c) > 0 Then s = c
                    Mask = Mask & s
                Next: If Mask <> "" Then GetMaskFromLine = Mask: Exit Function
            End If
        Next: GetMaskFromLine = ""
    End Function

    Private Sub GetDateij(ByRef i, ByRef j, Mask, aMasks, lg): Dim L
        Do: j = InStrRev(Mask, aMasks(lg, 3),- 1, 1): L = Len(aMasks(lg, 3))
            If j = 0 Then j = InStrRev(Mask, aMasks(lg, 2),- 1, 1): L = Len(aMasks(lg, 2))
            If j = 0 Then Exit Do
            i = InStrRev(Mask, aMasks(lg, 2),j, 1)
            If i = 0 Then i = InStrRev(Mask, aMasks(lg, 1),j, 1)
            If i = 0 Then Exit Do
            i = i+ 1: j = j+L- 2: Exit Sub
        Loop Until True: i = 0: j = 0
    End Sub
    ' End of Date --------------
   
    Private Sub InsertSpanStyle(ByRef xText): Dim Line, xLine, A, F, P, S: A = A0
        F = False: P = 0: S = StyleSheets
        For Each xLine In xText: Line = LTrim(xLine)
            If P <> 4 Then
                If Left(Line, Len(S( 1))) = S( 1) Then P = 1
                If Left(Line, Len(S( 2))) = S( 2) And P = 1 Then P = 2
                If Left(Line, Len(S( 3))) = S( 3) And P = 2 Then P = 3
                If Left(Line, Len(S( 4))) = S( 4) And P = 3 Then P = 4
                If P = 2 And Left(Line, Len(S( 0))) = S( 0) Then F = True
                If P = 3 And Not F Then PUSH A, SpanStyle: F = True
            End If: PUSH A, xLine
        Next: xText = A: If F Then sTAG0 = sTAG02
    End Sub
   
    Private Sub CorrectFehler(ByRef xText)
        Dim Line, A: A = A0
        For Each Line In xText
            Line = Replace(Line, aFehler( 0), aFehler( 1))
            PUSH A, Line
        Next: xText = A
    End Sub

    Private Function GetOKforOverwritePage
        GetOKforOverwritePage = MsgBox("is Conversion OK ?", _
            vbYesNo, "Insert Code and Save") = vbYes
    End Function
   
    Private Sub OverwriteOldDestPage
        RDWRfile WR, Txt_NewHTML, fSpecWebSite
        ErrMsg = "New File saved": Title = "Msg"
    End Sub
   
    Private Sub DisplayNewDestPage(xOrder): Dim Path_Dest, fSpec_DestTmp
        Select Case LCase(xOrder)
        Case "before"
            Path_Dest = FoP(fSpecWebSite)
            fSpec_DestTmp = BPth(Path_Dest, "Tmp.htm" )
            RDWRfile WR, Txt_NewHTML, fSpec_DestTmp
            DisplayHTMLfile fSpec_DestTmp
            FiD fSpec_DestTmp
        Case "after": DisplayHTMLfile fSpecWebSite
        End Select
    End Sub

    Private Sub DisplayHTMLfile(xfSpec)
        WshShell.Run "iexplore " & xfSpec, 3, True
        WshShell.SendKeys "% x" ' maximises consecutive windows
    End Sub
End Class

' ============================ Class SourceCodeMarkers ============================
Class SourceCodeMarkers
    Public MarkersInfo, MenuItems
    Private Sub Class_Initialize()
        MarkersInfo = A0: MenuItems = A0
    End Sub
   
    Public Function GetAllMarkers(xTxt): Dim Start_End, p, A
        GetAllMarkers = A0: A = A0
        Do: If Not GetMarkersInfo(p, Start_End, xTxt) Then Exit Do
            If Not RemoveEmptyLines(p) Then Exit Do
            If SingleMarker(p) Then Exit Do
            If StartEndChanged(p) Then Exit Do
            If Overlaps(p) Then Exit Do
            GetAllMarkers = p ' out from Text
            GetMenuItems p ' from Markers
            MarkersInfo = p ' Variable 
            Exit Function
        Loop Until True: QUEUE BrkErrMsg, "Error in Source-Code-Markers"
    End Function
   
    Private Function GetMarkersInfo(ByRef p, ByRef Start_End, ByVal xTxt)
        Dim Line, LineNr, mNr, ctr, se, A, mON: mON = False
        LineNr = - 1: p = A0: GetMarkersInfo = False
        If aOFF(xTxt) Then PUSH BrkErrMsg, "no HTML-Text found": Exit Function
        For Each Line In xTxt: Line = Trim(Line): INC LineNr ' GetMarkers-Info
            Do: If Not DetectMarkers(Start_End, mNr, Line) Then Exit Do
                If mNr > Ubd(p) Then ReDim Preserve p(mNr)' mNr; LineNr, ctr; LineNr, ctr
                If p(mNr) = "" Then p(mNr) = CStr(mNr) & ";-1,0;-1,0"
                A = Split(p(mNr), ";"): se = Start_End
                ctr = Eval(Split(A(se+ 1),",")( 1))
                A(se+ 1) = Join(Array(CStr(LineNr), CStr(ctr+ 1)),",")
                p(mNr) = Join(A, ";"): mON = True
            Loop Until True
        Next: If mON Then GetMarkersInfo = True: Exit Function
        PUSH BrkErrMsg, "no markers found"
    End Function
   
    Private Function DetectMarkers(ByRef Start_End, ByRef mNr, ByVal xLine)
        Dim Line, A, L, i, M, s: Start_End = - 1: mNr = - 1
        Line = Trim(xLine): M = - 1: s = "": DetectMarkers = False
        For i = 0 To 1: A = Split(aMarkersCode(i), "#"): L = Len(A( 0))
            If Left(Line, L) = A( 0) Then M = i: Exit For
        Next: If M < 0 Then Exit Function
        i = InStr(L, Line, A( 1)): If i = 0 Then Exit Function
        s = Trim(Mid(Line, L+ 1, i-L- 1))
        If s = "0" Then Exit Function
        If s = "" Then s = "0"
        If Not IsNumber(Trim(s)) Then Exit Function
        Start_End = M: mNr = Eval(s): DetectMarkers = True
    End Function
       
    Private Function Overlaps(xTxt): Dim i, j, A, aN1, aN2: A = xTxt: Overlaps = False
        For i = 0 To Ubd(A): For j = 0 To Ubd(A) ' if overlaps
            If i <> j Then
                aN1 = CVals(Split(A(i), ",")): aN2 = CVals(Split(A(j), ","))
                If (aN1( 1) > aN2( 1)) And (aN1( 1) < aN2( 2)) Or _
                   (aN1( 2) > aN2( 1)) And (aN1( 2) < aN2( 2)) Then _
                    Overlaps = True: Exit Function
            End If
        Next: Next
    End Function
   
    Private Function StartEndChanged(ByVal aTxt): Dim Line, aN: StartEndChanged = False
        For Each Line In aTxt: aN = CVals(Split(Line, ","))
            If aN( 2) < aN( 1) Then StartEndChanged = True: Exit function
        Next
    End Function
   
    Private Function SingleMarker(byRef aTxt)
        Dim Line, A, A1, AllMs, aTmp, i, LNrs( 1), mNr, ErrTxt
        SingleMarker = True: A1 = A0
        For Each Line In aTxt: A = Split(Line, ";"): AllMs = A0 ' if occur single
            For i = 1 To 2: aTmp = Split(A(i), ","): mNr = CVals(aTmp)( 1)
                If mNr <> 1 Then
                    If mNr < 1 Then ErrTxt = "missing" Else ErrTxt = "manifold (*)"
                    PUSH BrkErrMsg, "marker " & Replace(ErrTxt, "*", CStr(mNr))
                    Exit Function
                End If: LNrs(i- 1) = aTmp( 0)
            Next: PUSH AllMs, A( 0): PUSH AllMs, LNrs
            PUSH A1, Join(AllMs, ",")
        Next: aTxt = A1: SingleMarker = False
    End Function
   
    Private Sub GetMenuItems(mInfo): Dim Line, A, mNr: A = A0
        ' 0,1,3
        ' 1,14,16
        ' 2,10,12
        ' 3,5,7
        For Each Line In mInfo: mNr = Split(Line,",")( 0)
            If mNr = "0" Then mNr = "" Else mNr = " " & mNr
            PUSH A, "Markers" & mNr
        Next: MenuItems = A
    End Sub
   
    Public Function GetMarkersLines(ByVal MenuItem): Dim A, Line
        GetMarkersLines = Array(- 1,- 1)
        MenuItem = Trim(Mid(MenuItem, Len("Markers")+ 1))
        If MenuItem = "" Then MenuItem = "0"
        For Each Line In MarkersInfo: A = Split(Line, ",")
            If A( 0) = MenuItem Then _
                GetMarkersLines = CVals(Array(A( 1), A( 2))): Exit For
        Next
    End Function
   
    Private Function RemoveEmptyLines(ByRef aTxt): Dim Line, A: A = A0
        For Each Line In aTxt: If Line <> "" Then PUSH A, Line
        Next: aTxt = A: RemoveEmptyLines = aon(A)
    End Function
   
    Private Function CVals(ByVal xArr): Dim i, A: A = A0
        For i = 0 To Ubd(xArr): PUSH A, Eval(xArr(i)): Next: CVals = A
    End Function
End Class

' =============================== General Used Procedures ===============================

' =============================== Class OwnSysSpecs ===============================
Class OwnSysSpecs
    Public fSpec, Path, FulName, BaseName, BaseSpec
    Public Path_ToPublish, Path_htm, fName_Menu, fSpec_Menu, fSpec_Tmp
    Private Sub Class_Initialize: Dim A: A = Split(SubFldrs, ",")
        ' SubFldrs =        "ToPublish,htm"
        fSpec =             WScript.ScriptFullName
        Path =              FoP(fSpec)
        FulName =           FiN(fSpec)
        BaseName =          FiB(fSpec)
        BaseSpec =          BPth(Path, BaseName)
        fName_Menu =        BaseName & fExt_Called
        fSpec_Menu =        BPth(Path, fName_Menu)
        fSpec_Tmp =         BPth(Path, "tmp.txt")
        Path_ToPublish =    BPth(Path, A( 0)): FoC(Path_ToPublish)
        Path_htm =          BPth(Path, A( 1)): FoC(Path_htm)
        If Not FiE(fSpec_Menu) Then PUSH BrkErrMsg, "No Menufile found"
    End Sub
End Class

' ================================= Class Caller ==================================
Class Caller ' for handover of data and run external files
    Private fulName_Called, fSpec_Called, A
    Private Sub Class_Initialize
        fulName_Called =    OWN.BaseName & fExt_Called
        fSpec_Called =      BPth(OWN.Path, fulName_Called)
        If Not FiE(fSpec_Called) Then _
            PUSH BrkErrMsg, "No Menufile " & qo(fulName_Called) & " found"
    End Sub
    Public Property Let aTxt(Value): A = A0
        PUSH A, OWN.FulName: PUSH A, CArr(Value)
        RDWRfile WR, A, OWN.fSpec_Tmp
        WshShell.Run fSpec_Called, 1, True ' RunCalled
    End Property
    Public Property Get aTxt(): aTxt = A0: Dim Msg: Msg = ""
        RDWRfile RD, A, OWN.fSpec_Tmp
        If aOFF(A) Then Msg = "No" Else If A( 0) <> fulName_Called Then Msg = "Wrong"
        Do: If Msg = "" Then DEQUEUE A: Exit Do
            PUSH BrkErrMsg, Msg & " Response from " & qo(fulName_Called): A = A0
        Loop Until True: FiD OWN.fSpec_Tmp
        If aOFF(A) Then _
            PUSH BrkErrMsg, aErrTxt( 0) Else PUSH ErrMsg, DEQUEUE(A): aTxt = A
    End Property
End Class

Function CallMenu(MenuNr): Dim MenuInfo, A, s: s = String( 5, "-")
        ' ------------ Call Menu and Get Response -----------------
    CallMenu = False
    Select Case MenuNr
        Case 1: A = aMenuItems1
        Case 2: A = SCM.MenuItems
    End Select: CLR.aTxt = A
    ' here is waiting for the response
    MenuInfo = CLR.aTxt: If aON(BrkErrMsg) Then Exit Function
    PUSH Report, s & " Response from Menu " & s: PUSH Report, MenuInfo
    Select Case MenuNr
        Case 1: Select Case MenuInfo( 0)
                    Case A( 0): RTB.Main
                    Case A( 1): CHC.Main
                End Select
        Case 2: mLines = SCM.GetMarkersLines(MenuInfo( 0))
    End Select: CallMenu = True
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 aOFF(xA): aOFF = Not aON(xA): End Function
Function INC(ByRef AnyNr): AnyNr = AnyNr + 1: INC = AnyNr: End Function
Function FiE(FiSpec): FiE = fso.FileExists(FiSpec): End Function
Function FiB(FiSpec): FiB = fso.GetBaseName(FiSpec): End Function
Function FiN(FiSpec): FiN = fso.GetFileName(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 FoC(FoSpec): If Not FoE(FoSpec) Then fso.CreateFolder(FoSpec): End If: End Function
Function FoP(FiSpec): FoP = fso.GetParentFolderName(FiSpec): End Function
Function BrkErrON: BrkErrON = aON(BrkErrMsg): End Function
Function enDot(aStrg): enDot = "." & aStrg & ".": End Function
Function qo(xStr): qo = """" & xStr & """": End Function
Sub NL(ByRef xArr): PUSH xArr, "": End Sub
Function L(xStrg): L = Len(xStrg): End Function
Function SubStrg(xStr, x1, x2): If x1 < 1 Then x1 = 1
    If x2 > Len(xStr) Then x2 = Len(xStr)
    SubStrg = Mid(xStr, x1, x2-x1+ 1)
End Function
Function Remove(xStr, x1, xd): Remove = xStr
    If x1 < 1 Or x1 > Len(xStr) Or xd < 1 Or (x1 + xd - 1) > Len(xStr) Then _
        Exit Function
    Remove = Left(xStr, x1 - 1) & Mid(xStr, x1 + xd)
End Function
Function Insert(xStr, x1, iStr): Insert = xStr
    If x1 < 1 Or x1 > (Len(xStr)+ 1) Then Exit Function
    Insert = Left(xStr, x1 - 1) & iStr & Mid(xStr, x1)
End Function
Function Substitute(xStr, x1, x2, iStr)
    Substitute = Insert(Remove(xStr, x1, x2-x1+ 1), x1, iStr)
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
Sub QUEUE(ByRef xArr, ByVal xVar)
    CArr xVar: PUSH xVar, xArr : xArr = xVar : End Sub
Function DEQUEUE(ByRef xArr) ' Pop from LowBound, returns only one single item
    DEQUEUE = vbNull: If aON(xArr) Then DEQUEUE = xArr( 0): DelItem xArr, 0
End Function
Sub DelItem(ByRef xArr, ByVal xPos): Dim i, A: A = xArr
    If aOFF(A) Or xPos < 0 Or  xPos > Ubd(A) Then Exit Sub
    For i = xPos To Ubd(A) - 1: A(i) = A(i + 1): Next
    ReDim Preserve A(Ubd(A)- 1): xArr = A
End Sub

Function ToCharArray(xStr): Dim i, A: A = A0: ToCharArray = A0
    If xStr = "" Then Exit Function
    If IsArray(xStr) Then If aON(xStr) Then xStr = xStr( 0) Else Exit Function
    For i = 1 To Len(xStr): PUSH A, Mid(xStr, i, 1)
    Next: ToCharArray = A
End Function

Function RemoveBlanksBeforeNumbers(xLine): Dim Line, Cr
    Do: Line = Replace(xLine, " ", ""): If Line = "" Then Exit Do
        If IsNumber(Line) Then xLine = LTrim(xLine)
    Loop Until True: RemoveBlanksBeforeNumbers = xLine
End Function

Function IsNumber(xStrg): Dim Cr: IsNumber = True
    For Each Cr In ToCharArray(xStrg)
        If InStr(numerics, Cr) = 0 Then IsNumber = False: Exit Function
    Next
End Function

Function enTAG(xTxt): enTAG = aTAGsCmt( 0) & xTxt & aTAGsCmt( 1): End Function

' -------------- Display-Procedures -----------------
Sub DisplayResult: Dim A, s: A = A0: s = String( 10, "-")
    If Not (aON(Report) Or BrkErrON) Then MsgBox "Job done": Exit Sub
    If aON(Report) Then PUSH A, s & " Report " & s: PUSH A, Report
    PUSH A, s & " Errors " & s: PUSH A, BrkErrMsg
    DisplayArray A, OWN.FulName
End Sub

Sub DisplayArray(ByVal AnyArray, Title): Dim A, fi: A = A0
    fi = OWN.fSpec_Tmp
    PUSH A, "Title of the display = "& qo(Title)
    PUSH A, String( 50,"="): PUSH A, AnyArray
    RDWRfile WR, A, fi: WshShell.Run "notepad " & fi, 1, True: FiD fi
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
' ================== For BrowseFile ======================
Function GetParameters(xTitle): Dim A: A = A0: GetParameters = A0
    Select Case xTitle
        Case aTitles( 0): PUSH A, Array(ScriptPath, "*.*", ExtFilterScript)
        Case aTitles( 1): PUSH A, Array(SourcePath, "*.*", ExtFilterSource)
        Case aTitles( 2): PUSH A, Array(DestPath, "*.htm*", ExtFilterDest)
    End Select: If Not aON(A) Then Exit Function
    If Not FoE(A( 0)) Then Exit Function
    PUSH GetParameters, xTitle
    PUSH GetParameters, A
End Function

Function BrowseFile (ByVal Parameters): Dim P: ' Parameters: Title, Path, Filter, ExtFilter
    Dim tempDir, tempFile, powershellFile, powershellOutputFile
    Dim textFile, appCmd, psScript, A: A = A0: P = Parameters
    tempDir =              WshShell.ExpandEnvironmentStrings("%TEMP%")
    tempFile =             tempDir  & "\" & fso.GetTempName
    powershellFile =       tempFile & ".ps1" ' temporary powershell script file to be invoked
    powershellOutputFile = tempFile & ".txt" ' temporary file to store standard output from command
    PUSH A, "[System.Reflection.Assembly]::LoadWithPartialName(""System.windows.forms"") | Out-Null"
    PUSH A, "$dlg = New-Object System.Windows.Forms.OpenFileDialog"
    PUSH A, "$dlg.initialDirectory = " & qo(P( 1))
    PUSH A, "$dlg.filter = " & qo(P( 3))
    PUSH A, "$dlg.FilterIndex = 1"
    PUSH A, "$dlg.Title = " & qo("Select " & P( 0)) ' Title
    PUSH A, "$dlg.ShowHelp = $False"
    PUSH A, "$dlg.ShowDialog() | Out-Null"
    PUSH A, "Set-Content " & qo(powershellOutputFile) & " $dlg.FileName"
    psScript = Join(A, vbCrLf) & vbCrLf
    Set textFile = fso.CreateTextFile(powershellFile, True)
    textFile.WriteLine(psScript): textFile.Close: Set textFile = Nothing
    appCmd = "powershell -ExecutionPolicy unrestricted &'" & powershellFile & "'"
    WshShell.Run appCmd, 0, TRUE
    Set textFile = fso.OpenTextFile(powershellOutputFile, 1, 0, - 2)
    BrowseFile = textFile.ReadLine: textFile.Close: Set textFile = Nothing
    FiD(powershellFile): FiD(powershellOutputFile)
    WshShell.SendKeys "% x" ' should maximise succeeding windows
End Function
' ============ End of For BrowseFile ====================
' ============== End of Procedures ======================