Foltyn Presentation - vbs-PB-File-Select



	Ein Programm in der Programmiersprache		A program in the programming language
	vbScript + Power BASIC combined to one program
	ein vbScript-Programm ruft 2 Dateiauswahlfenster auf, die in Power-Basic geschrieben sind		a vbScript-Program calls 2 File-Select-Windows, written in Power-Basic
	Es ist schwierig, in vbScript einen Code für perfekte Datei-Auswahlfenster zu finden, aber in Power-Basic sind sie perfekt und einfach zu schreiben. So kann man einen Power-Basic-Code per vbScript aufrufen. Dazu ist wohl ein Mehrfaches an Code notwendig für die Übergabe von Informationen in beiden Richtungen über die Festplatte, aber ein Teil davon sind allgemein verwendete Prozeduren, die dann vom anderen Programm mit verwendet werden können. Und man kann danach die Methode verwenden, um Code auszulagern, wenn die Funktionen von grossen Programmen zu unübersichtlich werden. Das Script merkt sich die Pfade, die bei der Datei-Auswahl eingestellt wurden in einer INI-Datei, und beim nächsten Aufruf werden diese als Startpfade verwendet. Beim erstmaligen Programmlauf werden vorgegebene Pfade verwendet. Power-BASIC ist eine Compiler-Sprache und läuft als exe-Datei, kann aber auch ohne den Aufruf durch das Script verwendet werden. Es erkennt dann, dass keine entsprechende INI erzeugt wurde und erlaubt ein Dateiauswahl mit voreingestellten Werten für den Start. Dann ruft es seinerseits ein Script auf unter einem fixen Namen, das vom Benutzer frei gestaltet werden kann.		It is difficult to find a code in vbSript for perfect file-select-windows, but in Power-Basic they are perfekt and simple to write. So one can call a Power-Basic-Code per vbScript. For this there is certainly nessesary a multiple of code for the tranfer of informations in both directions over the harddisk, but a part of it are generally used procedures, which can be used too by the other program. And one can use the method for outsourcing of code, if the large-program-functions get too confusing. The script remembers the pathes, which are selected by the file-select in an INI-file and by a next call they were used as start-pathes. By the first-time program-run default-pathes are used. Power-BASIC is a compiler language and runs as exe-file, but can also be used without a call by the script. Then it recognises, that no appropriate INI has been generated and admits a file-select with default-values for start. Thereafter it calls itsself a script under a fix name, which can be shaped free by the user.
	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

	1. Nov. 2014		Nov 1^st 2014

vbScript - Code
calls Power-BASIC-Code
twice for getting the values of the file-select-windows

Option Explicit

' Variable- and Object-declarations

Dim ScriptSpec, ScriptPath, ScriptName ' Strings
Dim INIfileSpec, SourceFileSpec, DestFileSpec, ErrMsg
Dim DialogNr ' Numerics
Dim PrevResults, INImsg, CallMsg, A0: A0 = Array() ' Arrays
Dim fso, WshShell ' Objects
Const RD = 1, WR = 2 ' Constants

' Instantiation of Objects

Set fso = CreateObject("Scripting.FileSystemObject")
Set WshShell = WScript.CreateObject("Wscript.Shell")

GetScriptSpec

' Program

' CallExternalData = True if no ErrorMsg was made
' data are in global variables

If CallExternalData Then Program

Sub Program
    MsgBox SourceFileSpec ' to show what comes out
    MsgBox DestFileSpec
    ' Program to insert here
End Sub

' Procedures

Function CallExternalData
    Do: ErrMsg = "break off by the user"
        SourceFileSpec = CallFileSpecFromOutside("Select SourceFile")
        If SourceFileSpec = "" Then Exit Do
        DestFileSpec = CallFileSpecFromOutside("Select DestinationFile")
        If DestFileSpec = "" Then Exit Do
        ErrMsg = ""
    Loop Until True: WshShell.SendKeys "% x" ' should maximise succeeding windows
    CallExternalData = Not DisplayMsg(ErrMsg)
End Function

Function CallFileSpecFromOutside(Title)
    ReadWriteListFile RD, INImsg, INIfileSpec
    If UBound(INImsg) < 0 Or UBound(INImsg) <> 1 Then _
        INImsg = DefaultPathes: ReadWriteListFile WR, INImsg, INIfileSpec
    PrevResults = INImsg: CallMsg = GetCallMsg( Title, INImsg)
    ReadWriteListFile WR, CallMsg, INIfileSpec
    RunCmdLine BPth(ScriptPath, ScriptName & ".EXE"), ""
    ' --------- Called External Pgm is running here ---------
    ReadWriteListFile RD, INImsg, INIfileSpec
    If UBound(INImsg) < 0 Then PUSH INImsg, ""
    If INImsg(0) <> "" Then
        PrevResults(DialogNr) = fso.GetParentFolderName(INImsg(0))
    End If: ReadWriteListFile WR, PrevResults, INIfileSpec
    CallFileSpecFromOutside = INImsg(0)
End Function

Function DefaultPathes
    Dim A: A = A0
    PUSH A, "d:\..... your source-file-path ....."
    PUSH A, "d:\..... your destination-file-path ....."""
    DefaultPathes = A
End Function

Function GetCallMsg(Title, Pathes)
    Dim AllTitles, A: A = A0: DialogNr = -1
    AllTitles = Split("Select SourceFile,Select DestinationFile",",")
    Select Case Title
        Case AllTitles(0)
            PUSH A, Array(Title, "300", "200")
            PUSH A, Pathes(0)
            PUSH A, Array("BASIC", "*.vbs;*.hta;*.bas","")
            DialogNr = 0
        Case AllTitles(1)
            PUSH A, Array(Title, "300", "200")
            PUSH A, Pathes(1)
            PUSH A, Array("HTML", "*.htm;*.html","")
            DialogNr = 1
    End Select: GetCallMsg = A
End Function

' General Used Procedures

Sub GetScriptSpec
    ScriptSpec = WScript.ScriptFullName
    ScriptPath = fso.GetParentFolderName(ScriptSpec)
    ScriptName = fso.GetBaseName(ScriptSpec)
    INIfileSpec = BPth(ScriptPath, ScriptName & ".INI")
End Sub

Function RunCmdLine(AnyFileSpec, AnyParam)
    ' Returns False if AnyFileSpec not exists
    Dim CmdLine: RunCmdLine = False
    If Not fso.FileExists(AnyFileSpec) Then Exit Function
    CmdLine = qo(AnyFileSpec)
    If AnyParam <> "" Then CmdLine = Join(Array(CmdLine,qo(AnyParam))," ")
    WshShell.Run CmdLine, 1, True
    RunCmdLine = True
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 qo(AnyString): qo = """" & AnyString & """": End Function
Function BPth(aStr, bStr): BPth = fso.BuildPath(aStr, bStr): End Function

Function DisplayMsg(AnyMsg)
    If AnyMsg = "" Then DisplayMsg = False Else DisplayMsg = True
    If DisplayMsg Then MsgBox AnyMsg,,"Error"
End Function

Sub ReadWriteListFile(ByVal Direction, ByRef AnyList, ByVal AnyFileSpec)
    Dim f, Line, LastLine, Ubd, A
    If Direction = RD Then 'returns CodeLines in an array
        AnyList = A0: If Not fso.FileExists(AnyFileSpec) Then Exit Sub
        Set f = fso.OpenTextFile(AnyFileSpec, RD)
        While Not f.AtEndOfStream: PUSH AnyList, f.ReadLine: Wend: f.Close
    ElseIf Direction = WR Then
        A = AnyList: Ubd = UBound(A)
        If Ubd < 0 Then fso.DeleteFile(AnyFileSpec): Exit Sub
        If fso.FileExists (AnyFileSpec) Then fso.DeleteFile(AnyFileSpec)
        LastLine = A(Ubd): ReDim Preserve A(Ubd-1)
        Set f = fso.OpenTextFile(AnyFileSpec, WR, True)
        If Ubd > 0 Then For Each Line In A: f.WriteLine Line: Next
        f.Write LastLine: f.Close
    End If
End Sub

' End of Procedures

Power BASIC - Code
called by vbScript-Code
displays every time one window by every call from Script with different parameters

#COMPILE EXE
#DIM ALL

%TRUE = -1
%FALSE = 0
GLOBAL INIfileName AS STRING

FUNCTION PBMAIN () AS LONG
    DIM FileSpec AS STRING, CommandLine AS STRING
    DIM INImsg() AS STRING, INIexist AS INTEGER
    ' initialise variables
    INIexist = %TRUE: INIfileName = EXE.NAME$ & ".INI"
    ' read-in parameters
    ReadArrayFromFile(INImsg(), EXE.PATH$ & INIfileName) ' EXE.PATH$ with \
    ' correct parameters if needed to default values
    IF NOT(ARRAYATTR(INImsg(), 0)) THEN
        CALL GetDefault(INImsg())
        INIexist = %FALSE ' detected program call from vbs
    ELSEIF (UBOUND(INImsg)) <> 6 THEN ' coarse check if INI right
        CALL GetDefault(INImsg())
    END IF
    ' ========== FileOpenSelectCall ===========
    FileSpec = FileOpenSelect(INImsg())
    ' =========================================
    CALL WriteTextToFile(FileSpec, EXE.PATH$ & INIfileName)
    IF INIexist = %True THEN EXIT FUNCTION
    ' for use of the program without call from vbs
    CommandLine = EXE.PATH$ & EXE.NAME$ & ".vbs"
    IF ISFILE(CommandLine) THEN SHELL "WScript.exe " & CommandLine
END FUNCTION

' Procedures

SUB GetDefault(BYREF AnyArr() AS STRING)
    DIM i%
    DATA "Select a File", "300", "200"
    DATA "c:\Users\Public\Documents"
    DATA "All Files", "*.*",""
    REDIM AnyArr(0 TO DATACOUNT-1) ' DIM instead of REDIM does not work
    FOR i% = 0 TO DATACOUNT-1: AnyArr(i%) = READ$(i%+1): NEXT
END SUB

FUNCTION FileOpenSelect(Parameters$()) AS STRING
    ' DISPLAY OPENFILE [hParent], [xpos&], [ypos&], title$, folder$, filter$, _
    ' start$, defextn$, flags& TO filevar$ [,countvar&]
    ' Parameter = title, xpos, ypos, startpath, filetype, filter, startfilename
    DIM countvar&, filevar$
    DIM A(0 TO UBOUND(Parameters$)) AS STRING
    CALL ArrayCopy(A(), Parameters$())
    DISPLAY OPENFILE %HWND_DESKTOP, _
        VAL(A(1)), VAL(A(2)), A(0), A(3), _
        CHR$(A(4), 0, A(5), 0), A(6), "", _
        %OFN_ALLOWMULTISELECT + %OFN_ENABLESIZING + _
        %OFN_FILEMUSTEXIST + %OFN_NOVALIDATE + _
        %OFN_PATHMUSTEXIST TO filevar$, countvar&
    FUNCTION = filevar$
END FUNCTION

' General Used Procedures

SUB ArrayCopy(ArrCopy() AS STRING, BYREF AnyArr() AS STRING)
    DIM i&: REDIM ArrCopy(0 TO UBOUND(AnyArr))
    FOR i& = 0 TO UBOUND(AnyArr): ArrCopy(i&) = AnyArr(i&): NEXT
END SUB

SUB ReadArrayFromFile(BYREF AnyArray() AS STRING, BYVAL AnyFilSpec AS STRING)
    DIM count&: REDIM AnyArray(0 TO -1)
    IF ISFILE(AnyFilSpec) THEN
        OPEN AnyFilSpec FOR INPUT AS #1
            FILESCAN #1, RECORDS TO count&
            IF count& > 0 THEN
                REDIM AnyArray(0 TO count&)
                LINE INPUT #1, AnyArray() TO count&
            END IF
        CLOSE #1
    END IF
END SUB

SUB WriteTextToFile(AnyText AS STRING, BYVAL AnyFileSpec AS STRING)
    OPEN AnyFileSpec FOR OUTPUT AS #1: PRINT #1, AnyText;: CLOSE #1
END SUB

' End of procedures