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 Umbenennung von eml-Dateien in einem Verzeichnisbaum zur besseren Archivierung nach Datum geordnet for renaming of eml-files in a directory-tree for better archiving ordered by date

Das Programm dient der Archivierung von eml-Dateien, indem es solche in einem Verzeichnisbaum umbenennt, sodass sie dann nach Datum und Uhrzeit geordnet sind und leichter wieder aufgefunden werden können.

Das Programm sucht Datum und Uhrzeit aus den Datei-Inhalten heraus sodass sie als Dateinamen verwendet werden können. Kann Datum und Uhrzeit nicht gefunden werden, wird der alte Dateiname verwendet und eine Eintragung in eine Fehlerliste vorgenommen, deren Inhalt am Ende des Programms angezeigt wird.

Die umbenannten Dateien werden in ein Nachbarverzeichnis kopiert. Sollte bei 2 oder mehreren E-Mails Datum und Uhrzeit bis auf die Sekunde gleich sein, dann werden die Dateien automatisch umbenannt durch Anhängen einer laufenden Ziffer.

Da bei mehreren 1000 E-Mails die Laufzeit einige Minuten betragen kann, so ist eine Fortschrittsanzeige eingebaut, die im vb-Script eine Spezialität darstellt.

Wenn man wegen Tests von Änderungen am Code einen Testmodus einstellt, werden die langwierigen Pfadeingaben vermieden.

Hier wird zur Datum-Uhrzeit-Erkennung die Maskierungs-Technik verwendet. In der zu untersuchenden Zeile werden alle Ziffern in #-Zeichen und alle Buchstaben in @-Zeichen umgewandelt. Dann wird eine ebensolche Maske aus einem Maskensatz mit der maskierten Zeile in Übereinstimmung gebracht. Die Erkennung ist auch an verschiedener Stelle im Zeilentext und bei verschiedener Datum-Uhrzeit-Schreibweise eindeutig.

Hierbei liegt keine Kenntnis von Normen für den E-Mail-Kopf vor, doch das Programm kann als Hilfe dienen und entsprechend verbessert werden. Die E-Mail-Inhalte bleiben völlig unverändert.

The program serves for archiving of eml-files, by renaming of such in a directory-tree, so that date and clock-time is ordered and can be found easier.

The program seeks date and clock-time out of the file-contents, so that they can be used as filenames. Can date and clock-time not be found, the old filename is used and the matter listed up in an error-list, which content is indicated at the end of program.

The renamed files are copied into a neighboring directory. Should by 2 or more E-Mails be date-and-clock-time equal up to the second, then the files are automaticly renamed by attaching a current number.

Because by several 1000 E-Mails the runtime can be some minutes, so is built-in a progress display, which constitutes in vbScript a speciality.

If one adjusts a test-mode, due to test changes at the code, long-lasting path-inputs are avoided.

Here is used, for the date-and-time-recognition, the masking technique. In the line to investigate, all numbers are replace by a #-sign and all characters by a @-sign. Then a likewise mask out of a mask-set is brought in accordance with the masked line. The recognition is also at different location in the line-text and by different writing-styles of date-and-clocktime nonambiguous.

Hereby there is no knowledge of norms for the e-mail-head on hand, but the program can serve as aid and can be improved on desire. The e-mail-contents stay entirely unchanged.

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

The program produces these windows

' Rename eml- and nws-Files in a Foldertree by taking out Date and Clocktime 
' from the text for use as new filenames for the purpose of long-time-archiving

Option Explicit

' Constants, Variables + Objects

Dim A0: A0 = Array() ' Empty Array
Const RD = 1, WR = 2 ' Constants
Const Numerics = "0123456789"
Const Alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
Const Months = "Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec"
Const ExtFilter = "eml,_eml,nws,_nws"
Const TAG_font1 = "<font size=""+1""><b>"   
Const TAG_font2 = "</b></font>"

Dim SourcePath, DestPath, DestFolder, BoxMsg, Title, Version    ' Strings 
Dim ProgressBarTitle 
Dim ProgressBarWidth, ProgressBarHeight, NrOfMails              ' Numerics
Dim MaskSet, ErrMsg: ErrMsg = A0                                ' Arrays

Dim WshShell:       Set WshShell =      CreateObject("WScript.Shell")
Dim fso:            Set fso =           CreateObject("Scripting.FileSystemObject")
Dim objShell:       Set objShell =      CreateObject( "Shell.Application" )
Dim oExplr:         Set oExplr =        WScript.CreateObject("InternetExplorer.Application")
Dim OWN:            Set OWN =           New OwnSysSpecs ' Classes


DestFolder = "MailsExportUmbenanntInDatum" ' DefaultValue

Version = "" ' Version = "Test" skips user input-procedures
SourcePath = "d:\MailsFolder" ' DefaultPath for Version = "Test"

ProgressBarTitle = "Progress-Bar"
ProgressBarWidth = 800
ProgressBarHeight = 170

' Program

Program
DisplayResult

Sub Program: Dim ParentPath, SourcePathList, FileSubSpecList: BoxMsg = "": Title = ""
    ProgressDisplay "Open",""
        If Version <> "Test" Then
            SourcePath = BrowseSourcePath:  If BoxMsg <> "" Then Exit Sub
            GetDestinationFolder:           If BoxMsg <> "" Then Exit Sub
        End If
        ParentPath = FoP(SourcePath)
        DestPath = BPth(ParentPath,DestFolder)
        If Version <> "Test" Then If Not GetOK Then Exit Sub ' BreakOff by the user
        DeleteFulPath(DestPath)
        SourcePathList = CreatePathList(SourcePath, 1)
        FileSubSpecList = CreateFileSubSpecList(SourcePath)
        RenameAllFiles(FileSubSpecList)
End Sub

Sub RenameAllFiles(fSubSpecList): NrOfMails = 0
    Dim fSubSpec, fSpec_Old, fSpec_New, Ext, NewPath ' Strings
    Dim EMailText ' Arrays
    CreateMaskSet 
    For Each fSubSpec In fSubSpecList
        fSpec_Old =     BPth(SourcePath, fSubSpec)
        Ext =           fso.GetExtensionName(fSpec_Old)
        EMailText =     GetContentFromFile(fSpec_Old)
        If Not GetDateAndTimeFromText(fSpec_New, EMailText) Then _ 
            fSpec_New = FiB(fSpec_Old): _
            PUSH ErrMsg, "no date-time found " & Mid(fSpec_Old, Len(SourcePath)+1)
            ' fSpec_Old = message-1-24959.* fSpec_New = 20121229-042232.*
        ADD fSpec_New, "." & Ext
        ProgressDisplay "Display", _
            ProgressMessage("Renames:", SourcePath & " -> " & _
            DestPath, fSubSpec, " -> " & fSpec_New)
        NewPath =       FoP(BPth(DestPath, fSubSpec))
        fSpec_New =     BPth(NewPath, fSpec_New)
        fSpec_New =     GetUnusedFileNameForSaving(fSpec_New)
        CreatePath(NewPath) ' automatic detected if not exists
        fso.CopyFile fSpec_Old, fSpec_New: INC NrOfMails
    Next 
End Sub

Sub DisplayResult
        If aON(ErrMsg) Then DisplayMessage(vbCrLf & "Errors " & vbCrLf & Join(ErrMsg, vbCrLf))
        BoxMsg = CStr(NrOfMails) & " Mails renamed": Title = "Procedure done"
        If NrOfMails = 0 Then ADD BoxMsg, vbCrLf & "No Mails found"
    ProgressDisplay "Close","": MsgBox BoxMsg,,Title 
End Sub

' End of Program

' Procedures

Class OwnSysSpecs: Public ScreenWidth, ScreenHeight, ScriptPath, ScriptName, INIfSpec 
    Private Sub Class_Initialize
        GetMonitorProperties
        GetOwnFileSpecs
    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 GetOwnFileSpecs: Dim ScriptSpec
        ScriptSpec = WScript.ScriptFullName
        ScriptPath = FoP(ScriptSpec)
        ScriptName = FiB(ScriptSpec)
        INIfSpec = BPth(ScriptPath, ScriptName & ".INI")
    End Sub
End Class

Sub GetDestinationFolder: Dim Msg: Msg = A0
    PUSH Msg, "Enter Destination Folder"
    PUSH Msg, "Breakoff or no Destination Folder Chosen"
    PUSH Msg, "Error"
    Do: DestFolder = InputBox(Msg(0),,DestFolder)
        If DestFolder = "" Then BoxMsg = Msg(1): Title = Msg(2): Exit Do
    Loop Until DestFolder <> ""
End Sub

Function BrowseSourcePath: Dim PF, SourcePath, StartPath, A, KeepPath
    StartPath = "MY COMPUTER": ReadWriteListFile RD, A, OWN.INIfSpec
    If aON(A) Then If FoE(A(0)) Then StartPath = A(0)
    Do: If StartPath <> "MY COMPUTER" Then 
            KeepPath = MsgBox(Left(StartPath, 3) & _
                Replace(StartPath, "\","\" & vbCrLf,4), vbYesNo, "Use last StartPath ?")
            SourcePath = "": If KeepPath = vbCancel Then Exit Do
            If KeepPath = vbNo Then StartPath = "MY COMPUTER"
        End If: SourcePath = StartPath
        If StartPath = "MY COMPUTER" Then _
            SourcePath = BrowseFolder(StartPath, False): If SourcePath = "" Then Exit Do
        PF = FoP(SourcePath): If PF = "" Then MsgBox "root must be a folder, not the drive",,"Error"
    Loop Until PF <> "": If SourcePath = "" Then BoxMsg = "BreakOff by the User" Else _
                            ReadWriteListFile WR, Array(SourcePath), OWN.INIfSpec
    BrowseSourcePath = SourcePath
End Function

Function BrowseFolder( myStartLocation, blnSimpleDialog )
    Const MY_COMPUTER = &H11&, WINDOW_HANDLE = 0 ' Must ALWAYS be 0
    Dim strPrompt, numOptions, strPath, objFolder, objFolderItem, objPath 
    strPrompt = "Select root folder:": numOptions = 0 ' Simple dialog
    strPath = myStartLocation
    If Not blnSimpleDialog Then numOptions = &H010& Or &H200& 
    ' &H010& Or &H200& = Additional text field to type folder path 
    ' and ommit new folder button
    If UCase( myStartLocation ) = "MY COMPUTER" Then
        Set objFolder = objShell.Namespace( MY_COMPUTER )
        Set objFolderItem = objFolder.Self
        strPath = objFolderItem.Path
    End If: Set objFolder = objShell.BrowseForFolder( WINDOW_HANDLE, _
        strPrompt, numOptions, strPath )
    If objFolder Is Nothing Then BrowseFolder = "": Exit Function
    Set objFolderItem = objFolder.Self: BrowseFolder = objFolderItem.Path
End Function

Function GetOK: Dim DelTree: GetOK = True: If Not FoE(DestPath) Then Exit Function
    DelTree = MsgBox("Old Destination-Tree will be deleted",vbOKCancel,"Warning")
    If DelTree = vbCancel Then BoxMsg = "BreakOff by the User":  GetOK = False: Exit Function
    ProgressDisplay "Display", "Former DestTree will be deleted"
End Function

Function CreatePathList(AnyBasePath, SortDirection): Dim Path: CreatePathList = A0
    For Each Path In CreateSubPathList(AnyBasePath, SortDirection)
        PUSH CreatePathList, BPth(AnyBasePath, Path): Next: End Function

Function CreateSubPathList(AnyPath, Sortdirection) 
    ' in SPL no leading and no trailing backslash
    Dim SD, SPL, Path, ListPos, FolderGroup, ChosenFolder, SubFldr, f, item, IllicitFldrs
    IllicitFldrs = WRAP("System Volume Information,$RECYCLE.BIN") 
    SPL = A0: CreateSubPathList = SPL: SD = SortDirection: Listpos = -2: item = ""
    If SD <> 0 And Abs(SD) <> 1 Then Exit Function
    Path = AnyPath: If Mid(Path,2,1) <> ":" Then Exit Function
    Path = BkSl(Path, -1): If Len(Path) = 2 Then Path = BkSl(Path, 1)
    Do: INC ListPos: If ListPos > -1 Then item = SPL(ListPos)
        Set FolderGroup = fso.GetFolder(BPth(Path, item)).SubFolders
        On Error Resume Next ' skip too long pathes
        For Each ChosenFolder In FolderGroup
            If Err.Number = 0 Then
                SubFldr = Mid(ChosenFolder, Len(Path)+1+(1 And Len(Path)>3))
                If InStr(IllicitFldrs, WRAP(SubFldr)) = 0 Then PUSH SPL, SubFldr
            End If
        Next
    Loop Until ListPos >= UBound(SPL): CreateSubPathList = SORT(SPL, SD)
End Function

Function CreateFileSubSpecList(AnyBasePath)
    Dim SubPath, fSpec, A: A = A0: CreateFileSubSpecList = A0
    For Each SubPath In CreateSubPathList(AnyBasePath, 1): SubPath = BPth(SourcePath,SubPath)
        If FoE(SubPath) Then PUSH A, CreateFileList(SubPath, 1): End If: Next
    For Each fSpec In A
        If InstrWRAP(ExtFilter, fso.GetExtensionName(fSpec)) > 0 Then _
            PUSH CreateFileSubSpecList, Mid(fSpec,Len(SourcePath) + 2)
    Next
End Function

Function GetContentFromFile(xfSpec): ReadWriteListFile RD, GetContentFromFile, xfSpec: End Function

' --------------- GetDateAndTimeFromText ----------------------

Function GetDateAndTimeFromText(ByRef DT, ByVal AnyText): Dim TxtD, Line 
    GetDateAndTimeFromText = False: DT = "": TxtD = "Date:"
    'Date: 12 Mar 2013 01:27:02 +0100
    'Date: Tue, 12 Mar 2013 01:27:02 +0100
    '   Tue, 12 Mar 2013 01:27:02 +0100 (CET)
    'X-MailStore-Date: 20110530233234
    Do: For Each Line In AnyText
            If Left(Line, Len(TxtD)) = TxtD Then _
                If ExtractDateAndTime(DT, Line) Then Exit Do
        Next:   For Each Line In AnyText
                    If ExtractDateAndTime(DT, Trim(Line)) Then Exit Do
                Next: TxtD = "X-MailStore-Date:"
        For Each Line In AnyText: DT = ""
            If Left(Line, Len(TxtD)) = TxtD Then _
                If GetOtherDateFormat(DT, Mid(Line, Len(TxtD)+2)) Then _
                    GetDateAndTimeFromText = True: Exit Function
        Next: Exit Function
    Loop Until True: DT = GetDateAndTime(DT): GetDateAndTimeFromText = True
End Function

Function GetDateAndTime(ByVal xLine): GetDateAndTime = "": If xLine = "" Then Exit Function
    ' Returns: "20140312-130317" or ""
    xLine = Replace(xLine,"-"," "): xLine = Replace(xLine, ":", " ") 
    Dim A, i: A = Split(xLine," "): A(1) = InStrWRAP(Months, A(1)): If A(1) = 0 Then Exit Function
    A(1) = (A(1) - 1) \ 4 + 1: For i = 0 To 5: A(i) = Use(A(i),2): Next: SWAP A(0), A(2)
    A(2) = A(2) & "-": GetDateAndTime = Join(A,"")
End Function

Function ExtractDateAndTime(ByRef DT, ByVal xLine): ExtractDateAndTime = False: DT = ""
    If xLine = "" Then Exit Function
    Dim Mask, MaskedLine, Pos, L, LWD: LWD = Len (" @@@,"): MaskedLine = ENBL(MaskLine(xLine))
    For Each Mask In MaskSet: Mask = ENBL(Mask): Pos = InStr(MaskedLine, Mask): L = Len(Mask)-1
        If Pos > 0 Then
            If Left(MaskedLine, LWD) = " @@@," Then Pos = Pos + LWD: L = L - LWD
            DT = Trim(Mid(xLine, Pos, L)): ExtractDateAndTime = True: Exit Function
        End If
    Next
End Function

Function MaskLine(AnyLine): Dim i, Char, L, Mask: MaskLine = "" 
    ' vbTab is replaced by blank, Date: is removed, all is trimmed
    While InStr(AnyLine, "  "): AnyLine = Replace(AnyLine, "  ", " "): Wend
    AnyLine = Trim(Replace(AnyLine, vbTab, " ")): L = Len("Date:")
    If Left(AnyLine, L) = "Date:" Then AnyLine = Trim(Mid(AnyLine, L+1))
    For i = 1 To Len(AnyLine): Char = Mid(AnyLine, i, 1)
        Do: If InStr(Alphabet, UCase(Char)) > 0 Then Char = "@": Exit Do
            If num(Char) Then Char = "#": Exit Do
            If InStr(",-+: ", Char) = 0 Then Char = "~": Exit Do
        Loop Until True: MaskLine = MaskLine & Char
    Next
End Function

Sub CreateMaskSet: Dim A: A = A0
    PUSH  A, "@@@, ## @@@ #### ##:##:##"
    PUSH  A, "@@@, # @@@ #### ##:##:##"
    PUSH  A, "@@@, ##-@@@-#### ##:##:##"
    PUSH  A, "@@@, #-@@@-#### ##:##:##"
    PUSH  A, "## @@@ #### ##:##:##"
    PUSH  A, "# @@@ #### ##:##:##"
    PUSH  A, "##-@@@-#### ##:##:##"
    PUSH  A, "#-@@@-#### ##:##:##"
    MaskSet = A
End Sub

Function GetOtherDateFormat(ByRef ODF, xStrg): GetOtherDateFormat = False: ODF = ""
    If Len(xStrg) <> 14 Then Exit Function
    Dim i, Char 'Date-Format = "20110530233234"
    For i = 1 To Len(xStrg): Char = Mid(xStrg, i, 1): If Not num(Char) Then Exit Function
    Next: ODF = Left(xStrg,8) & "-" & Mid(xStrg,9): GetOtherDateFormat = True
End Function

' ------------------------------------

Sub DeleteFulPath(AnyPath): Dim f, fc, File, Path: If Not FoE(AnyPath) Then Exit Sub
    For Each Path In CreatePathList(AnyPath, 1)
        If FoE(Path) Then
            For Each File In CreateFileList(Path, 1)
                If FiE(File) Then 
                    ProgressDisplay "Display", ProgressMessage("Deletes:", _
                        DestPath, Mid(File, Len(DestPath) + 2), "") 
                    FiD(File) ' Detects automaticly if exist
                End If
            Next
        End If
    Next: FoD(AnyPath) ' Detects automaticly if exist
End Sub

Function CreateFileList(xPath, SortDir): CreateFileList = A0: If Not FoE(xPath) Then Exit Function
    Dim f1: On Error Resume Next ' skip too long pathes
    For Each f1 In fso.GetFolder(xPath).Files
        If Err.Number = 0 Then If f1 <> "" Then PUSH CreateFileList, f1
        If Err.Number > 0 Then On Error GoTo 0: On Error Resume Next
    Next: CreateFileList = Sort(CreateFileList, SortDir)
End Function

Function CreatePath(AnyPath) ' Returns False if drive not exists or faulty Anypath
    Dim Path, drv, Fldr, FldrChain : CreatePath = False
    Path = PathValid(AnyPath): If Path = "" Then Exit Function
    drv = UCase(Left(Path,1)): If Not DrE(drv) Then Exit Function
    If Not FoE(Path) Then FldrChain = drv & ":\" Else CreatePath = True: Exit Function
    For Each Fldr In Split(Mid(Path,4),"\"): FldrChain = BPth(FldrChain, Fldr)  
        If Not(FoE(FldrChain)) Then fso.CreateFolder(FldrChain)
    Next: If FoE(FldrChain) Then CreatePath = True
End Function

Function PathValid(AnyPath): Dim Pth, drv: Pth = AnyPath: drv = UCase(Left(Pth,1)): PathValid = ""
    If InStr(Mid(Alphabet, 3), drv) = 0 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): End If: PathValid = Pth
End Function

Function GetUnusedFileNameForSaving(AnyFileSpec)
    Dim fSpec, Path, FulName, FileName, Ext, fName, Vary, nr, f
    Dim i, i1, i2, Numeric: fSpec = AnyFileSpec
    Do: GetUnusedFileNameForSaving = fSpec
        If fSpec = "" Then Exit Do
        If Not(FiE(fSpec)) Then Exit Do
        Path = FoP(fSpec): FulName = fso.GetFileName(fSpec)
        FileName = FiB(FulName): Ext = "." & fso.GetExtensionName(FulName)
        Do: fName = RTrim(FileName): Numeric = False
            If Right(fName, 2) = "()" Then CUT fName, 2: Exit Do
            fName = FileName: i1 = InStrRev(FileName, "("): i2 = InStrRev(FileName, ")")
            If i1 = 0 Or i2 = 0 Or i1 > (i2 - 2) Then Exit Do
            fName = Left(FileName, i1 - 1): If i2 < Len(FileName) Then Exit Do
            For i = i1 + 1 To i2 - 1: If Not num(Mid(FileName, i, 1)) Then Exit Do
            Next: If Len(fName) - Len(RTrim(fName)) <> 1 Then Exit Do
            Numeric = True: nr = Mid(FileName,i1+1,i2-i1-1)
            Vary = CStr(Eval(nr)): If Vary = nr Then Vary = CStr(Eval(nr) + 1)
        Loop Until True: f = RTrim(fName)
        If Right(f, 2) = "()" Then CUT f, 2
        If RTrim(fName) <> f Then fName = f: Vary = "1" 
        If Not Numeric Then Vary = "1"
        fSpec = BPth(Path, RTrim(fName) & " (" & Vary & ")" & Ext)
    Loop 
End Function

Function SORT(AnyArray, SortDirection): Dim A, SD, ItemPos, Ptr, PtrToPeak, CmpOp
    ' Sortdirection Ascend = 1, Descend = -1
    A = AnyArray: SD = SortDirection 
    SORT = A: If Not aON(A) Or Abs(SD) <> 1 Then Exit Function
    For ItemPos = 0 To Ubd(A): PtrToPeak = ItemPos
        For Ptr = ItemPos + 1 To Ubd(A): CmpOp = 0
            If A(Ptr) < A(PtrToPeak) Then CmpOp = -1
            If A(Ptr) > A(PtrToPeak) Then CmpOp = 1
            If CmpOp <> SD Then PtrToPeak = Ptr
        Next: SWAP A(PtrToPeak), A(ItemPos)
    Next: SORT = A
End Function

Function INC(ByRef AnyNr): AnyNr = AnyNr + 1: INC = AnyNr: End Function
Function Ubd(xA): Ubd = UBound(xA): End Function
Function aON(xA): aON = Ubd(xA) > -1: End Function
Function BPth(aString, bString): BPth = fso.BuildPath(aString, bString): End Function
Function FiE(FiSpec): FiE = fso.FileExists(FiSpec): End Function
Function FiB(FiSpec): FiB = fso.GetBaseName(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
Sub FoD(FoSpec): If FoE(FoSpec) Then fso.DeleteFolder(FoSpec): End If: End Sub
Function FoP(FiSpec): FoP = fso.GetParentFolderName(FiSpec): End Function
Function DrE(drv): DrE = fso.DriveExists(drv): End Function
Function num(xChar): num = (InStr(Numerics, xChar) > 0): End Function
Function InstrWRAP(aStr, bStr): InstrWRAP = InStr(WRAP(aStr), WRAP(bStr)): End Function
Function WRAP(aString): WRAP = "," & aString & ",": End Function
Function ENBL(aStr): ENBL = " " & aStr & " ": End Function
Sub SWAP(byRef aVar, byRef bVar): Dim vTmp: vTmp = aVar: aVar = bVar: bVar = vTmp: End Sub
Sub ADD(ByRef aStr, ByVal bStr): aStr = aStr & bStr: End Sub

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 CUT(ByRef AnyString, ByVal AnyNr): Dim i
    i = Len(AnyString) - AnyNr: If i < 0 Then i = 0
    AnyString = Left(AnyString, i): CUT = AnyString: End Function

Function BkSl(ByRef AnyPath, Mode): Dim slON: slON = Right(AnyPath,1) = "\"
    ' Backslash, Mode = 1 / -1
    If Mode = 1 And Not slON Then ADD AnyPath, "\"
    If Mode = -1 And slON Then AnyPath = Left(AnyPath, Len(AnyPath)-1)
    BkSl = AnyPath
End Function

Function Use(AnyNr, NrOfDigits): Use = CStr(AnyNr)
    While Len(Use) < NrOfDigits: Use = "0" & Use: Wend: End Function

Sub DisplayMessage(AnyMsg): Dim fSpec, A: If IsArray(AnyMsg) Then A = AnyMsg
    If Not IsArray(AnyMsg) Then If AnyMsg = "" Then A = A0 Else A = Array(AnyMsg)
    If Not aON(A) Then Exit Sub
    fSpec = BPth(OWN.ScriptPath, "tmp.txt")
    ReadWriteListFile WR, A, fSpec
    WshShell.Run "notepad " & fSpec, 1, True ' 3, True = Fulscreen
    FiD(fSpec) ' Detects automaticly if exist
End Sub 

Sub ProgressDisplay (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

Function ProgressMessage(AnyTitle, AnyPath, AnyFileSpec, AnyMore)
    Dim A, A2, Line, MaxLenght, L, s: A = A0: A2 = A0
    MaxLenght = (ProgressBarWidth - 20)\8: L = MaxLenght\2-6: s = " ....->.... "
    PUSH A, TAG_font1 & AnyTitle & TAG_font2       
    PUSH A, AnyPath
    PUSH A, FoP(AnyFileSpec)
    PUSH A, fso.GetFileName(AnyFileSpec) & AnyMore
    For Each Line In A: If Len(Line)- MaxLenght > 0 Then _
        Line = Left(Line, L) & s & Right(Line, L)
        PUSH A2, Line
    Next: ProgressMessage = Join(A2, "<BR>")
End Function

Sub ReadWriteListFile(ByVal Direction, ByRef AnyList, ByVal AnyFileSpec)
    Dim f, LastLine, Line, format, A: format = False ' False = ASCII
    If Direction = RD Then 'returns lines in an array
        AnyList = A0: If Not FiE(AnyFileSpec) Then Exit Sub
        Set f = fso.OpenTextFile(AnyFileSpec, RD,, format)
        While Not f.AtEndOfStream: PUSH AnyList, f.ReadLine: Wend: f.Close
    ElseIf Direction = WR Then
        FiD(AnyFileSpec) ' Detects automaticly if exist
        A = AnyList: If Not aON(A) Then Exit Sub
        Set f = fso.OpenTextFile(AnyFileSpec, 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
        End If: f.Write LastLine: f.Close
    End If
End Sub
'  End of Procedures