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 & hta
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 Basic- oder Hta-Quellcode in einen farbigen HTML-Text. Head- and Body-TAGs sind weg gelassen.

HTML (Hyper Text Markup Language) ist eine Seitenbeschreibungs-sprache und Hta (HTML Application) ist ein HTML-text, nicht zum Hinaufladen zu einem Provider für den weltweiten Zugriff, sondern für den alleinigen Gebrauch auf dem Computer des Benutzers, in welchem ein riesiges Programm in vbScript implementiert sein kann mit demselben Code wie ohne Hta. Aber Hta erzeugt eine Listbox auf dem Bildschirm zur Auswahl von verschiedenen Programmfunktionen.

Die Schlüsselwörter für die blaue Farbe sind in einer Liste einzutippen unter dem Dateinamen: "Keywords-PB-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.

     The program converts a Basic- or Hta- Source-Code, beeing on hand as a monocolor text, into colored HTML-text, appropriate to be displayed on screen as colored program-code by recognition of words in the text. Head- and Body-TAGs are ommitted.

HTML (Hyper Text Markup Language) is a page-description-language and Hta (HTML Application) is a HTML-text, not for upload to a provider for worldwide access, but for use on the user's computer only, which can have implemented a huge program in vbScript, with the same code as without Hta. But Hta generates a listbox on the screen to select between different program functions.

The keywords for the blue and other colors are to type-in in a list under the filename: "Keywords-PB-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.

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
22. Okt. 2014 Oct 22nd 2014

This language-selection-window is generated by the program



After conversion the result is exported without header and footer
into the file: "SourceCode.htm" in the same directory
as the program and displayed on the screen

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

<html>
<head>
<title>Convert Source Code to HTML</title>
<HTA:APPLICATION 
    APPLICATIONNAME="ConvertSourceCodeToHTML" 
    ID="ConvertSourceCodeToHTML">
</head>

<SCRIPT Language="VBScript">

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

Option Explicit ' Guarantees, that all variables are explicitly declared

' Declarations

Const ForReading = 1, ForWriting = 2, Up = 1, Down = -1 ' Constants
Dim ListKeywordsPBstm, ListKeywordsPBops, ListKeywordsVbsStm ' Arrays
Dim ScriptText, HTMLText, LanguageList, ScriptMarkers, SM
Dim MenuItems, ColReg, ReadTmp, Protocol, A0: A0 = Array(): Protocol = A0
Dim CurrentPath, Language, FontTAG, TAG2 ' Strings
Dim FileSpecKeywords_PBstm, FileSpecKeywords_PBops, FileSpecKeywords_VbsStm
Dim FileSpecTextIn, FileSpecTextOut, FileSpecTextOutCopy, FileSpecProtocol
Dim HtaFlag ' Booleans
Dim LineNr ' Numerics

' Instantiations of Objects

Dim WshShell, fso, col, ColSet

Set WshShell = CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
Set ColSet = CreateObject("Scripting.Dictionary")
Set col = CreateObject("Scripting.Dictionary")

' Program-Parameter-Definitions

MenuItems = "Hta,vbScript,Power Basic"
LanguageList = "hta,vbs,PB"

CurrentPath = WshShell.CurrentDirectory & "\"
FileSpecProtocol = CurrentPath & "Protocol.txt"

FontTAG = "<font face=""Courier New"" SIZE=""2"">" : TAG2 = "</font>"
ScriptMarkers = "HTML,SCRIPT Language=""VBScript"",/SCRIPT,/HTML"
ColSet.Add "ColTyps", "Txt,Key,Rem,Qum,Nrs,Ops,Fms,Att,Tag"
Read "000000,0000FF,007F00,408080,A52A2A,,,FF0000,A52A2A" ' hta
Read "000000,0000FF,007F00,808080,A52A2A,,,FF0000,A52A2A" ' vbs
Read "000000,0000C0,007F00,C020C0,000000,8000FF,C06400,," ' PB
ColReg = Read("")

' Assignment of Parameters to Variables

MenuItems = Split(MenuItems,",")
LanguageList = Split(LanguageList,",")
For Each Language In LanguageList
    ColSet.Add Language, DEQUEUE(ColReg)
Next
SM = Split("<" & Replace(UCase(ScriptMarkers),",",">,<") & ">",",")

' Procedures

Sub Window_OnLoad
    Dim strComputer, objWMIService, colItems, objItem, objOption, item, i
    Dim ScreenWidth, ScreenHeight, WindowWidth, WindowHeight
    WindowWidth = 300: WindowHeight = 350: strComputer = "." 
    Set objWMIService = GetObject("winmgmts:" _
    & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
    Set colItems = objWMIService.ExecQuery("Select * from Win32_DesktopMonitor")
    For Each objItem In colItems
        ScreenWidth = objItem.ScreenWidth
        ScreenHeight = objItem.ScreenHeight
    Next: i = 0
    window.resizeTo WindowWidth, WindowHeight
    window.moveTo (ScreenWidth-WindowWidth)/2,(ScreenHeight-WindowHeight)/2
    For Each item In MenuItems
        Set objOption = Document.createElement("OPTION")
        objOption.Value = INC(i)
        objOption.Text = item: mylistbox.Add(objOption)
    Next
End Sub

Sub OnClickDisplaySelected()
    Dim j, OneSelected: OneSelected = False
    For j = 0 To mylistbox.length-1
        If mylistbox(j).selected Then _
        GetJobDone(mylistbox(j).Text): OneSelected = True
    Next: If OneSelected = True Then window.close
End Sub

Sub GetJobDone(ChosenTask) 
    ' GetJobDone is called from SUB OnClickDisplaySelected
    ' ChosenTask is what comes out of the menu
    ' Hta,vbScript,Power Basic
    Dim fSpc, ErrMsg: ErrMsg = "": htaFlag = True
    Language = LanguageList(Find(MenuItems, ChosenTask, 1))
    fSpc = CurrentPath & "SourceCode." & Language
    FileSpecTextOut = fSpc & ".htm"
    FileSpecTextOutCopy = fSpc & ".copy.htm"
    Do: Select Case Language 'ChosenTask
        Case "hta", "vbs" ' hta br,rd ; vbs bl
            fSpc = CurrentPath & "Keywords-" & "vbs"
            ListKeywordsVbsStm = LoadFromDisk(fSpc & "-stm.dat")
            If UBound(ListKeywordsVbsStm) = -1 Then Exit Do
            FileSpecTextIn = CurrentPath & "SourceCode." & Language
        Case "PB"
            Language = "PB": fSpc = CurrentPath & "Keywords-" & Language
            ListKeywordsPBstm = LoadFromDisk(fSpc & "-stm.dat")
            If UBound(ListKeywordsPBstm) = -1 Then Exit Do
            ListKeywordsPBops = LoadFromDisk(fSpc & "-ops.dat")
            If UBound(ListKeywordsPBops) = -1 Then Exit Do
            FileSpecTextIn = CurrentPath & "SourceCode." & "bas"
        End Select
        If Not(fso.FileExists(FileSpecTextIn)) Then _
        ErrMsg = FileSpecTextIn: Exit Do
        ReadWriteListFile ForReading, ScriptText, FileSpecTextIn
        RemoveLeadingEmptyLines ScriptText
        If UBound(ScriptText) = -1 Then ErrMsg = FileSpecTextIn: Exit Do
        ConvertTextFromSourceCodeToHTML '                     Conversion-Program-Call
        ReadWriteListFile ForWriting, HTMLText, FileSpecTextOut
        ReadWriteListFile ForWriting, HTMLText, FileSpecTextOutCopy
        ' ReadWriteListFile ForWriting, Protocol, FileSpecProtocol
        WshShell.Run "iexplore " & FileSpecTextOut, 1, True ' Display Result on Screen
        WshShell.Run "notepad " & FileSpecTextOut, 1, True
        'WshShell.Run "notepad " & FileSpecProtocol, 1, true
    Loop Until True: If ErrMsg <> "" Then MsgBox Msg(ErrMsg),,"Error"
End Sub

Function LoadFromDisk(AnyFileSpec)
    Dim A, ErrMsg: ErrMsg = "": A = A0: LoadFromDisk = A
    Do: If Not(fso.FileExists(AnyFileSpec)) Then ErrMsg = AnyFileSpec: Exit Do
        ReadWriteListFile ForReading, A, AnyFileSpec
        If UBound(A) = -1 Then ErrMsg = AnyFileSpec: Exit Do
        ReadWriteListFile ForWriting, A, AnyFileSpec & ".bak" 
        A = Sort(A, Up): A = RemoveDoubleItems(A)
        ReadWriteListFile ForWriting, A, AnyFileSpec
        A = SortForWordLenght(A): LoadFromDisk = A
    Loop Until True: If ErrMsg <> "" Then MsgBox Msg(ErrMsg),,"Error"
End Function

Sub ConvertTextFromSourceCodeToHTML
    Dim htaBuffer, BRbuffer, Lg, prevFlag: htaFlag = False
    If UBound(ScriptText) < 0 Then Exit Sub
    htaBuffer = A0: HTMLText = A0: BRbuffer = ""
    Lg = Language: If InStr("hta,vbs",Lg) Then Lg = "hta,vbs"
    PUSH HTMLText, FontTAG ' "<font face=""Courier New"" SIZE=""2"">"
    For LineNr = 0 To UBound(ScriptText)
        If Lg = "hta,vbs" Then SetHTAflag
        If LineNr = 0 Or prevFlag <> htaFlag Then _
        prevFlag = AssignColors(Lg, htaFlag)
        If Lg = "hta,vbs" Then
            If htaFlag Then PUSH htaBuffer, CLine Else _
            PUSH HTMLText, ConvertHTAcode(htaBuffer): htaBuffer = A0
        End If
        If Not htaFlag Or Lg = "PB" Then
            If Trim(CLine) = "" Then
                BRbuffer = BRbuffer & "<BR>" 
            Else
                If LineNr > 0 Then BRbuffer = BRbuffer & "<BR>"
                PUSH HTMLText, BRbuffer & ConvertCodeLine(CLine): BRbuffer = ""
            End If
        End If: If Lg = "hta,vbs" Then ResetHTAflag
    Next: PUSH HTMLText, BRbuffer & "<BR>"
    If Lg = "hta,vbs" Then PUSH HTMLText, ConvertHTAcode(htaBuffer)
    PUSH HTMLText, TAG2: RemoveConsecutiveSameColTAGs HTMLText
End Sub

Function ConvertCodeLine(AnyLine)
    Dim OldLine, NewLine, PrevChar, Color, sTmp, sTmp2, i, j
    OldLine = ReplaceTabsByBlanks(AnyLine): NewLine = ""
    If UCase(Left(Trim(OldLine),4)) = "REM " Then ' RemarkCodeLine
        NewLine = enTAG(col.Item("Rem"), OldLine)
    Else
        ' Word-Recognition
        If Language = "PB" Then
            For Each sTmp In Split("#PBFORMS ",",")
                If InStr(LTrim(OldLine),sTmp) = 1 Then
                    PrevChar = Left(OldLine,1)
                    NewLine = enTAG(col.Item("Fms"), OldLine)
                    OldLine = ""
                    ConvertCodeLine = NewLine: Exit Function
                End If
            Next
        End If: PrevChar = ""
        Do While Len(OldLine)
            ' Char- and Word-Recognition, Bytewise detect
            Select Case Left(OldLine, 1) 
            Case """"
                ' 1234567i   1i
                ' "......"   ""
                i = InStr(2, OldLine, """")
                If i = 0 Then i = Len(OldLine)
                sTmp = Left(OldLine,i): sTmp2 = ""
                If i > 1 Then sTmp2 = Mid(sTmp,2,i-2)
                sTmp = """" & ReplaceSpecChars(sTmp2) & """"
                PrevChar = Mid(OldLine,i,1)
                NewLine = NewLine & enTAG(col.Item("Qum"), sTmp)
                OldLine = Mid(OldLine,i+1)
            Case "'"
                PrevChar = Left(OldLine,1)
                NewLine = NewLine & enTAG(col.Item("Rem"), _
                            ReplaceSpecChars(OldLine))
                OldLine = ""
            Case Else
                If Not(InStrOnly(PrevChar, "A-z,.")) Then
                    ' KeyWord detect allowed
                    sTmp = DyeIfKeyWordFound(OldLine)
                    If sTmp <> "" Then
                        Color = Left(sTmp,6): sTmp = Mid(sTmp,7)
                        PrevChar = Right(sTmp,1)    
                        NewLine = NewLine & enTAG(Color, sTmp)
                        OldLine = Mid(OldLine,Len(sTmp)+1)
                    Else
                        ' Number detect
                        ' vbTab & " .;+-*\/()=<>"
                        sTmp = IsNr(PrevChar, OldLine)
                        If sTmp <> "" Then ' nr found in OldLineCopy
                            PrevChar = Right(sTmp,1)    
                            NewLine = NewLine & enTAG(col.Item("Nrs"), sTmp)
                            OldLine = Mid(OldLine,Len(sTmp)+1)
                        Else ' no nr found
                            PrevChar = Left(OldLine,1)
                            NewLine = NewLine & ReplaceSpecChars(PrevChar)
                            OldLine = Mid(OldLine,2)
                        End If
                    End If
                Else
                    PrevChar = Left(OldLine,1)
                    NewLine = NewLine & PrevChar
                    OldLine = Mid(OldLine,2)
                End If
            End Select
        Loop: ConvertCodeLine = NewLine
    End If
End Function

Function ReplaceTabsByBlanks(AnyLine)
    Dim i, d: i = 0
    Do: INC i: If i > Len(AnyLine) Then Exit Do
        If Mid(AnyLine,i,1) = vbTab Then
            d = 5+4*((i-1)\4)-i
            AnyLine = Left(AnyLine,i-1) & Space(d) & Mid(AnyLine,i+1)
            i = i + d - 1
        End If
    Loop: ReplaceTabsByBlanks = AnyLine
End Function

Function AssignColors(AnyLanguage, AnyFlag) ' Result in the public array col.Items
    Dim ColTyp, i, a1, a2, Lg: Lg = AnyLanguage
    a1 = Split(ColSet.Item("ColTyps"),",")
    If col.Count = 0 Then For Each ColTyp In a1: col.Add ColTyp, "": Next
    Select Case Language
        Case "PB": Lg = "PB"
        Case "hta","vbs": If AnyFlag Then Lg = "hta" Else Lg = "vbs"
    End Select: a2 = Split(ColSet.Item(Lg),","): i = -1
    For Each ColTyp In a1: col.Item(ColTyp) = a2(INC(i)): Next
    AssignColors = AnyFlag
End Function

Function DyeIfKeyWordFound(AnyString)
    ' Returns Color = Left(DyeIfKeyWordFound,6): Keyword = Mid(DyeIfKeyWordFound,7)
    ' Converts keyword from black-white to color
    ' If KeyWord found, it returns Keyword with col-TAGs
    ' and returns AnyString displaced
    ' If KeyWord not found, it returns "" and
    ' leaves AnyString unchanged
    Dim KeyWord: KeyWord = "" 
    Select Case Language
    Case "PB":          KeyWord = DetectKeyWord(AnyString, "PBstm", ListKeywordsPBstm)
                        If KeyWord = "" Then _
                        KeyWord = DetectKeyWord(AnyString, "PBops", ListKeywordsPBops)
    Case "hta","vbs":   KeyWord = DetectKeyWord(AnyString, "VbsStm", ListKeywordsVbsStm)
    End Select: DyeIfKeyWordFound = KeyWord
End Function

Function DetectKeyWord(AnyString, Which, AnyArray)
    Dim Color, Keyword, K, L, Ls, item, Found, NextChar: DetectKeyWord = "": Found = False
    Select Case Which
        Case "PBstm","VbsStm":  K = "Key"
        Case "PBops":           K = "Ops"
    End Select: Color = col.Item("Txt"): Ls = Len(AnyString)
    For Each KeyWord In AnyArray: L = Len(KeyWord) 
        Do: If L > Ls Then Exit Do
            If UCase(KeyWord) <> UCase(Left(AnyString,L)) Then Exit Do
            ' Mid(AnyString, L+1,1) = NextChar
            If L < Ls Then If InStrOnly(Mid(AnyString, L+1,1), "A-z") Then Exit Do
            Color = col.Item(K) 
            If Which = "PBstm" 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 Function
    NextChar = Mid(AnyString, L+1,1) 
    If NextChar <> "" Then If InStr("0123456789", NextChar) > 0 Then Exit Function
    If Len(Color) <> 6 Then Color = "000000"
    If Not(InStrOnly(Color, "0-9,A-f")) Then Color = "000000"
    DetectKeyWord = Color & KeyWord
End Function

Function IsNr(AnyPrevChar, AnyString)
    Dim sTmp, Chrs, C0, C, C1, i, Number
    C0 = AnyPrevChar: Number = True: IsNr = ""
    Chrs = vbTab & " .;:+-*\/()=<>"
    If Not(InStrOnly(C0, Chrs) Or C0 = "" Or C0 = ",") Then Exit Function
    For i = 1 To Len(AnyString): sTmp = Mid(AnyString,i,2): C = Left(sTmp,1)
        If Not(InStrOnly(C, "0-9,.")) Then Number = False: Exit For
    Next: DEC i: If Number Then i = Len(AnyString)
    C1 = Mid(AnyString,i+1,1)
    If Not(InStrOnly(C1, Chrs) Or C1 = "" Or C1 = ",") Then Exit Function
    IsNr = Left(AnyString,i)
End Function

Function ConvertHTAcode(AnyArray) ' List of multiple lines
    Dim Code, TAGdyed, j, k: ConvertHTAcode = A0
    If UBound(AnyArray) < 0 Then Exit Function
    Code = Join(AnyArray, vbCrLf): TAGdyed = ""
    Code = Replace(Code, vbTab, "&nbsp;&nbsp;&nbsp;&nbsp;")
    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))
End Function

Function RemoveBlanksAfterBreaks(AnyText)
    Dim A1, A2, Line, NewLine, item, x, found: RemoveBlanksAfterBreaks = A0
    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 ReplaceSpecChars(Line)
    ReplaceSpecChars = SpecChar(Line, "äÄöÖüÜß ""<>&§")
End Function

Function SpecChar(Line, CharMask) ' z.B. CharMask = """ "
    Dim CharSet, SpecChars, i, k, Char: SpecChar = ""
    ' insert HTML-code for special characters
    ' &&amp must be on first place
    ' at the end ";" must be missing
    CharSet = "äÄöÖüÜß ""<>&§"
    SpecChars = "&auml;&Auml;&ouml;&Ouml;&uuml;&Uuml;&szlig;" & _
                "&nbsp;&quot;&lt;&gt;&amp;&sect;"
    SpecChars = Split(SpecChars,";")
    For i = 1 To Len(Line): Char = Mid(Line, i, 1)
        If InStr(CharMask, Char) > 0 Then _
            k = InStr(CharSet, Char): Char = SpecChars(k-1) & ";"
        SpecChar = SpecChar & Char
    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(AnyColor) ' Creates StartTAG with color Attribute
    TAG1 = "": If AnyColor = "" Then Exit Function
    If Len(AnyColor) <> 6 Then AnyColor = "000000"
    If Not(InStrOnly(AnyColor, "0-9,A-f")) Then AnyColor = "000000"
    TAG1 = "<font color=""#" & AnyColor & """>" ' "<font color=""#007F00"">"
End Function

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

Function Sort(AnyArray, SortDirection) ' Sortdirection Up = 1, Down = -1
    Dim A, Ubd, ItemPos, Pointer, PointerToPeakValue, CmpOp, SD
    SD = SortDirection: A = AnyArray: Ubd = UBound(A): Sort = A
    If Ubd < 0 Or Abs(SD) <> 1 Then Exit Function
    For ItemPos = 0 To Ubd: PointerToPeakValue = ItemPos
        For Pointer = ItemPos + 1 To Ubd: 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, sTmp, Flag: Flag = True
    While Flag = True: Flag = False
        For i = 0 To UBound(AnyArray)-1
            If Len(AnyArray(i)) < Len(AnyArray(i+1)) Then
                sTmp = AnyArray(i): AnyArray(i) = AnyArray(i+1)
                AnyArray(i+1) = sTmp: Flag = True
            End If
        Next
    Wend: SortForWordLenght = AnyArray
End Function

Function RemoveLeadingEmptyLines(ByRef AnyArray)
    Dim item, Ctr, i: Ctr = 0: RemoveLeadingEmptyLines = AnyArray
    If UBound(AnyArray) < 0 Then Exit Function
    For Each item In AnyArray: If Trim(item) <> "" Then Exit For
        INC Ctr
    Next: If Ctr = 0 Then Exit Function
    For i = Ctr To UBound(AnyArray): AnyArray(i-Ctr) = AnyArray(i): Next
    ReDim Preserve AnyArray(UBound(AnyArray)-Ctr): RemoveLeadingEmptyLines = AnyArray
End Function

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

Function InStrOnly(AnyString, Subset)
    ' InStrOnly(AnyString, "a-z,A-Z,A-z,0-9, _[]ßäöüÄÖÜ€|")
    ' InStrOnly(AnyString, "Chr(32-127),ßäöüÄÖÜ€")
    Dim Char, C1, C2, UC1, UC2, LC1, LC2, Size1, Size2
    Dim item, i, arrSubset, OK, strOK: OK = False
    arrSubset = Split(Subset,","): strOK = True
    If AnyString = "" Then strOK = False
    For i = 1 To Len(AnyString)
        Char = Mid(AnyString,i,1): OK = False
        For Each item In arrSubset
            If Len(item) = 3 And Mid(item,2,1) = "-" Then
                ' UCase = True, LCase = False, Nrs treated as UCase
                C1 = Left(item,1): C2 = Right(item,1)
                UC1 = UCase(C1): UC2 = UCase(C2)
                LC1 = LCase(C1): LC2 = LCase(C2) 
                Size1 = (UC1 = C1): Size2 = (UC2 = C2)
                If Size1 And Size2 Then ' A-Z
                    If Char >= UC1 And Char <= UC2 Then OK = True
                    If Char >= "0" And Char <= "9" Then OK = True
                ElseIf Not(Size1) And Not(Size2) Then ' a-z
                    If Char >= "a" And Char <= "z" Then OK = True
                ElseIf (Size1 And Not(Size2)) Or _
                (Not(Size1) And Size2) Then ' A-z
                    If Char >= UC1 And Char <= UC2 Then OK = True
                    If Char >= LC1 And Char <= LC2 Then OK = True
                End If
            ElseIf item = "Chr(32-127)" Then
                If Char >= Chr(32) And Char <= Chr(127) Then OK = True
            Else
                If InStr(item, Char) <> 0 Then OK = True
            End If
        Next: If Not(OK) Then strOK = False
        If Not(strOK) Then Exit For
    Next: InStrOnly = strOK
End Function

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

Sub RemoveSameColTAGsInLine(ByRef AnyLine)
    Dim i, i1, i2, i3, i4, i5, i6, i7, i8, s, c, Line, ULine: i = 1
    Line = AnyLine
    Do: ULine = UCase(Line)
        i1 = InStr(i, ULine, UCase("<font color=")): If i1 = 0 Then Exit Do
        i2 = InStr(i1, ULine,""""): If i2 = 0 Then Exit Do
        i3 = InStr(i2, ULine,""""): If i3 = 0 Then Exit Do
        i4 = InStr(i3, ULine,">"): If i4 = 0 Then Exit Do
        i5 = InStr(i4, ULine, UCase("</font>")): If i5 = 0 Then Exit Do
        i6 = i5 + Len("</font>")-1
        i7 = InStr(i6, ULine, Mid(ULine, i1, i4 - i1 + 1))
        Do: If i7 = 0 Then i = i6 + 1: Exit Do
            s = Mid(Line, i6 + 1, i7 - i6 - 1)
            c = Trim(Replace(s, "&nbsp;", " "))
            If c <> "" Then i = i7: Exit Do
            i8 = InStr(i7, ULine,">")
            Line = Left(Line, i5 - 1) & LCase(s) & Mid(Line, i8 + 1): i = i1
        Loop Until True
    Loop: AnyLine = Line
End Sub

Sub ReadWriteListFile(ByVal Direction, ByRef AnyList, ByVal AnyFileSpec)
    Dim f, CodeLine, LastCodeLine
    If Direction = ForReading Then 'returns CodeLines in an array
        AnyList = A0: If Not fso.FileExists(AnyFileSpec) Then Exit Sub
        Set f = fso.OpenTextFile(AnyFileSpec, ForReading)
        AnyList = Split(f.ReadAll,vbCrLf): f.Close
    ElseIf Direction = ForWriting Then
        If UBound(AnyList) < 0 Then fso.DeleteFile(AnyFileSpec): Exit Sub
        If fso.FileExists (AnyFileSpec) Then fso.DeleteFile(AnyFileSpec)
        Set f = fso.OpenTextFile(AnyFileSpec, ForWriting, True)
        f.Write Join(AnyList,vbCrLf): f.Close
    End If
End Sub

Function Read (AnyLine) 
    If Not IsArray(ReadTmp) Then ReadTmp = A0
    If AnyLine = "" Then Read = ReadTmp: ReadTmp = A0: Exit Function
    PUSH ReadTmp, AnyLine: Read = A0
End Function

Function Find(AnyArray, AnyString, AnyComp)
    Dim item: Find = -1: item = "wrong parameter in Find"
    If AnyComp <> 0 And AnyComp <> 1 Then Exit Function
    If UBound(AnyArray) = -1 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 INC(ByRef AnyNr): AnyNr = AnyNr + 1: INC = AnyNr: End Function
Function DEC(ByRef AnyNr): AnyNr = AnyNr - 1: DEC = AnyNr: End Function
Function CLine: CLine = ScriptText(LineNr): End Function

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

Function DEQUEUE(ByRef AnyArr)
    Dim i: If UBound(AnyArr) = -1 Then Exit Function
    DEQUEUE = AnyArr(0)
    For i = 1 To UBound(AnyArr): AnyArr(i-1) = AnyArr(i): Next
    ReDim Preserve AnyArr(UBound(AnyArr)-1)
End Function

Sub SWAP(byRef aString, byRef bString)
    Dim sTmp: sTmp = aString: aString = bString: bString = sTmp
End Sub

Sub SetHTAflag
    ' SM = "HTML, SCRIPT Language=""VBScript"", /SCRIPT, /HTML"
    Dim Line: Line = UCase(CLine)
    If InStr(Line,SM(0)) Or InStr(Line,SM(2)) Then htaFlag = True
End Sub

Sub ResetHTAflag
    Dim Line: Line = UCase(CLine)
    If InStr(Line,SM(1)) Or InStr(Line,SM(3)) Then htaFlag = False
End Sub

Function Msg(AnyFileSpec)
    Msg = Left(AnyFileSpec,10) & " ..."
    If Mid(AnyFileSpec,2,2) = ":\" Then Msg = fso.GetFileName(AnyFileSpec)
    Msg = "correct file """ & Msg & """ missing"
End Function

' End of Procedures

</SCRIPT>

<body bgcolor="buttonface">
<p align="center">
Select programming language<BR>of the source-code<BR>
for correct text-recognition<BR><BR>
<select size="3" name="mylistbox" style="width:140px" 
    ondblclick="OnClickDisplaySelected"></select><BR><BR>
Program Loads Code from file "SourceCode" (Type .hta, .vbs or .bas)<BR>
but hta and vbs recognise automaticly the type of each other<BR><BR>
<input type="button" name="DisplaySelected" id="DisplaySelected" 
    value="    Start    " onclick="OnClickDisplaySelected">
</p>
</body>
</html>