Foltyn Presentation - Menu-Display in vbScript



	Ein Programm in der Programmiersprache		A program in the programming language
	vbScript & hta
	für die Darstellung des Menü-Dialogs in vbScript (man sieht, dass es nicht jeder hat, weil viel Code notwendig ist)		for the display of the menu-dialog in vbScript (one sees, that not everybody has it, because much code is necessary)
	In vbScript kann man kein Menü darstellen, aber in Hta und hier ist eine Methode gezeigt, wie man mit einem Script eine Menü-Funktion aufruft, welche in Hta geschrieben ist und wie man damit ein perfektes Ergebnis bekommt. Mit einem vbScript kann man andere Programme aufrufen. Die Werteübergabe in beide Richtungen erfolgt über eine temporäre Datei auf der Festplatte. Man könnte in einer Richtung auch vielleicht bis zu 5000 Zeichen per Kommandozeile übergeben, doch darauf wurde hier verzichtet, weil man ohnehin den Code für die Werteübergabe per Festplatte für beide Richtungen braucht. "Menu.vbs", "Menu.hta" und "tmp.txt" sind alle in einem gemeinsamen Verzeichnis. "Menu.vbs" übergibt die Menü-Eintragungen und das Verzeichnis der temporären Datei an "Menu.hat " für die Rückübertragung der gewählten Menüposition. Wenn "Menu.hta" ohne vbScript verwendet wird, dann erzeugt vbScript keine temporäre Datei und dann wählt "Menu.hta" seine eigenen Menüeinträge aus und liefert keine Werte zurück. In Hta kann ebenfalls jedes beliebige Script hinein geschrieben werden.		In vbScript one cannot create a menu, but in Hta and here is shown a method, how one calls a menu-function by a script, which is written in Hta and how one can get a perfect result with it. With a vbScript one can call other programs. The handing-over of values in both directions is carried out over a temporary file on harddisk. One could perhaps hand-over 5000 characters in one direction by command-line, but it was waived on this, because the code for the values-hand-over per harddisk is needed anyway. "Menu.vbs", "Menu.hta" and "tmp.txt" are all in a common directory. "Menu.vbs" hands over the menu-entries and the directory of the temporary file to "Menu.hat " for the the return-handing-over of the selected menu-position. If "Menu.hta" is used without vbScript, then vbScript generates no temporary file and then "Menu.hta" selects its own menu-entries and delivers no values back. In Hta can also be inserted any script.
	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

	18. Okt. 2014		Oct 18th 2014

This language-selection-window is generated by the program
(by Hta called by vbScript or Hta alone)

This is the program with name "Menu.vbs"

Option Explicit

Dim ScriptPath, TmpFileSpec, MenuMsg
Dim A0: A0 = Array()
Dim objShell, fso, WshShell
Const ForReading = 1, ForWriting = 2, RD = 1, WR = 2 ' Constants

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

ScriptPath = fso.GetParentFolderName(WScript.ScriptFullName)
TmpFileSpec = fso.BuildPath(ScriptPath, "tmp.txt")

' Program

MenuMsg = GetMenuMsg("VB,vbs,hta,PB,Gambas", "Menu.hta") ' Menu-items
MsgBox MenuMsg,,"back in Script"

' Procedures

Function GetMenuMsg(Items, FileName)
    Dim A: A = A0: PUSH A, Split(Items,","): PUSH A, TmpFileSpec
    A = CallExternFunctionRespons(A, fso.BuildPath(ScriptPath, FileName))
    PUSH A, "": GetMenuMsg = A(0)
End Function

Function CallExternFunctionRespons(TmpMsg, FileSpec)
    ' Write Msg on Disk
    RDWRtmpMsg WR, TmpMsg
    ' Call Extern Function
    objShell.Run FileSpec, 3, True
    ' Read Msg from Disk
    WshShell.SendKeys "% x" ' Remaximises subsequent windows
    TmpMsg = A0: If fso.FileExists(TmpFileSpec) Then _
        RDWRtmpMsg RD, TmpMsg: fso.DeleteFile(TmpFileSpec)
    CallExternFunctionRespons = TmpMsg
End Function

Sub RDWRtmpMsg(Dir, ByRef Msg): ReadWriteListFile Dir, Msg, TmpFileSpec: End Sub

' General Used Procedures

Sub PUSH(ByRef AnyArr, byVal AnyVar)
    ' AnyVar can be a String, Numeric or 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

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

This is the program with name "Menu.hta"

<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

Dim OwnPath, OwnFileName, OwnFileSpec, TmpFileSpec, TmpMsg ' Strings
Dim MenuTable, A0: A0 = Array() ' Arrays
Dim Called ' Boolean
Dim fso ' Objects
Const ForReading = 1, ForWriting = 2, RD = 1, WR = 2 ' Constants

Set fso = CreateObject("Scripting.FileSystemObject")
GetOwnFileSpec Menu.commandline

GetTmpMsg

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

Sub GetTmpMsg
    TmpFileSpec = fso.BuildPath(OwnPath, "tmp.txt")
    RDWRtmpMsg RD, MenuTable
    If UBound(MenuTable) < 0 Then
        MenuTable = Split("Pos1,Pos2,Pos3",",")
        Called = False
    Else
        TmpFileSpec = MenuTable(UBound(MenuTable))
        ReDim Preserve MenuTable(UBound(MenuTable)-1)
        fso.DeleteFile(TmpFileSpec)
        Called = True
    End If
End Sub

Sub Job(MenuPos) ' MenuPos is what comes out of the menu
    If Called Then RDWRtmpMsg WR, Array(MenuTable(MenuPos)): Exit Sub
    If fso.FileExists(TmpFileSpec) Then fso.DeleteFile(TmpFileSpec)
    ' more program for hat not called
    MsgBox MenuTable(MenuPos)
End Sub

Function GetOwnFileSpec(HTA_ID_CmdLine) ' HTA_ID_CmdLine = Menu.commandline
    ' HTA_ID_CmdLine comes from <HTA:APPLICATION ID = "Menu"
    GetOwnFileSpec = False: OwnFileSpec = ""
    If UBound(Split(HTA_ID_CmdLine,"""")) <> 2 Then Exit Function
    OwnFileSpec = Replace(HTA_ID_CmdLine,"""","")
    If Mid(OwnFileSpec,2,2) <> ":\" Then Exit Function
    OwnPath = fso.GetParentFolderName(OwnFileSpec)
    OwnFileName = fso.GetBaseName(fso.GetFileName(OwnFileSpec))
    GetOwnFileSpec = True
End Function

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

Sub OnClickDisplaySelected()
    Dim j:  For j = 0 To mylistbox.length-1
                If mylistbox(j).selected Then _
                    Job mylistbox(j).Value: window.close: Exit Sub
            Next
End Sub

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 INC(ByRef AnyNr): AnyNr = AnyNr + 1: INC = AnyNr: End Function
Sub RDWRtmpMsg(Dir, ByRef Msg): ReadWriteListFile Dir, Msg, TmpFileSpec: 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

</SCRIPT>

<body bgcolor="buttonface">
<p align="center">
Here is a text<BR>
line 2<BR>
line 3<BR><BR>
<select name="mylistbox" ondblclick="OnClickDisplaySelected"></select><BR><BR>
<table border="0" cellpadding="0" cellspacing="0">
    <colgroup><col width="60"><col width="124"><col width="60"></colgroup>
    <tr><td></td><td>
<input type="button" name="DisplaySelected" id="DisplaySelected"
        value="Select a Task" onclick="OnClickDisplaySelected">
    </td><td></td>
</table>
</p>
</body>
</html>