Серый форум — VBScript: конструирование и выдача диалогов с помощью HTA

Re: VBScript: конструирование и выдача диалогов с помощью HTA

2008-07-11T09:35:27Z

Предыдущий пример с функцией. Добавлено закрытие диалога по Escape и возможность вызова модального окна выбора папок. Чтобы получить хэндл окна для его передачи функции BrowseForFolder (чтобы сделать окно выбора папок модальным), на форму вставляется объект MSScriptControl.

Option Explicit
Dim ExitDo, oHTA, oDict, oBody, oElem, oText
Dim val_1, val_2, val_3, ok, strHTML
'==================================================================================================
Function GetHTADialog(ByRef Params)
    Dim oFSO, oWshShell, oWindows, oTextStream, oWnd, oWindow
    Dim sHTAFileName, ID, N
    
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oWshShell = CreateObject("WScript.Shell")
    Set oWindows = CreateObject("Shell.Application").Windows
    
    ' формирование имени будущего файла HTA
    sHTAFileName = oWshShell.ExpandEnvironmentStrings("%TEMP%") & "\" & oFSO.GetTempName() & ".hta"
    ' создание файла HTA
    Set oTextStream = oFSO.CreateTextFile(sHTAFileName, True)
    ' заполнение файла HTA
    With oTextStream
        .WriteLine ""
        .WriteLine ""
        .WriteLine ""
        .WriteLine "    "
        .WriteLine ""
        .WriteLine ""
        .WriteLine ""
        .WriteLine ""
        .Close
    End With
    Randomize
    ID = Clng(Rnd * 100000)
    oWshShell.Run sHTAFileName & " " & ID
    ' поиск окна HTA
    Set oWnd = Nothing
    For N = 1 to 5000
        For Each oWindow in oWindows
            If oWindow.GetProperty("ID") = ID Then
                Set oWnd = oWindow
                Exit For
            End If
        Next
        If Not oWnd Is Nothing Then Exit For
        WScript.Sleep 100
    Next
    ' удаление файла HTA
    oFSO.DeleteFile sHTAFileName, True
    ' возвращаем ссылку на окно HTA
    Set GetHTADialog = oWnd
End Function
'==================================================================================================
Sub HTA_OnUnload
    ExitDo = True
End Sub
Sub CloseHTA
    oHTA.document.parentWindow.close
End Sub
Sub OK_HTA
    val_1 = oHTA.document.parentWindow.input_1.value
    val_2 = oHTA.document.parentWindow.input_2.value
    val_3 = oHTA.document.parentWindow.input_3.value
    oHTA.document.parentWindow.close
    ok = True
End Sub
Sub BrowseFolder
    Dim oFolder, oShellApp, oFSO
    Set oShellApp = CreateObject("Shell.Application")
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oShellApp.BrowseForFolder(oHTA.GetProperty("HWND"), "Выбор папки", 81, "")
    If Not oFolder Is Nothing Then
        If oFSO.FolderExists(oFolder.Self.Path) Then
            oHTA.document.parentWindow.input_3.value = oFolder.Self.Path
        End If
    End If
End Sub
'==================================================================================================
Set oDict = CreateObject("Scripting.Dictionary")
oDict.Add "CONTEXTMENU", "no"
oDict.Add "INNERBORDER", "no"
oDict.Add "SCROLL", "no"
oDict.Add "BORDER", "dialog"
oDict.Add "BORDERSTYLE", "raised"
oDict.Add "MAXIMIZEBUTTON", "no"
oDict.Add "MINIMIZEBUTTON", "no"
ok = False
Set oHTA = GetHTADialog(oDict)
If oHTA Is Nothing Then
    WScript.Echo "Не удалось получить связь с окном HTA."
    WScript.Quit
End If
' назначаем обработчик события выгрузки (закрытия) формы
oHTA.document.body.onunload = GetRef("HTA_OnUnload")
' задаём размеры формы
oHTA.document.parentWindow.resizeTo 350, 320
' задаём заголовок окна
oHTA.document.title = "Заголовок диалога"
' получаем объет тела HTML-документа
Set oBody = oHTA.document.getElementsByTagName("body")(0)
' задаём цвет фона
oBody.bgcolor = "#E0E0E0"
' формируем строку HTML-кода
strHTML = ""
strHTML = strHTML & "Введите текстовое значение:"
strHTML = strHTML & ""
strHTML = strHTML & "Выберите файл:"
strHTML = strHTML & ""
strHTML = strHTML & "Выберите папку:"
strHTML = strHTML & ""
strHTML = strHTML & ""
strHTML = strHTML & "

"
strHTML = strHTML & ""
strHTML = strHTML & "          "
strHTML = strHTML & "     "
strHTML = strHTML & ""
' записываем HTML-код в тело документа
oBody.innerHTML = strHTML
' назначение событий кнопкам
oHTA.document.parentWindow.bOK.onclick = GetRef("OK_HTA")
oHTA.document.parentWindow.bCancel.onclick = GetRef("CloseHTA")
oHTA.document.parentWindow.bBrowse.onclick = GetRef("BrowseFolder")
Do ' ожидание закрытия окна HTA
    WScript.Sleep 100
Loop Until ExitDo
If ok Then
    WScript.Echo "Введено текстовое значение: " & val_1
    WScript.Echo "Выбран файл: " & val_2
    WScript.Echo "Выбрана папка: " & val_3
Else
    WScript.Echo "Окно HTA было закрыто кнопкой ""Отменить""."
End If

Автор идеи - alexii.

Re: VBScript: конструирование и выдача диалогов с помощью HTA

2008-07-09T19:31:54Z

Функция, которая возвращает ссылку на объект окна HTA. В качестве аргумента принимает словарь с параметрами тега HTA. Получаем ссылку на объект окна HTA и формируем диалоговую форму с двумя полями ввода с помощью объектной модели DOM:

Option Explicit
Dim ExitDo, oHTA, oDict, oBody, oElem, oText
Dim val_1, val_2, ok
'==================================================================================================
Function GetHTADialog(ByRef Params)
    Dim oFSO, oWshShell, oWindows, oTextStream, oWnd, oWindow
    Dim sHTAFileName, ID, N
    
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oWshShell = CreateObject("WScript.Shell")
    Set oWindows = CreateObject("Shell.Application").Windows
    
    ' формирование имени будущего файла HTA
    sHTAFileName = oWshShell.ExpandEnvironmentStrings("%TEMP%") & "\" & oFSO.GetTempName() & ".hta"
    ' создание файла HTA
    Set oTextStream = oFSO.CreateTextFile(sHTAFileName, True)
    ' заполнение файла HTA
    With oTextStream
        .WriteLine ""
        .WriteLine ""
        .WriteLine ""
        .WriteLine ""
        .WriteLine ""
        .WriteLine ""
        .Close
    End With
    Randomize
    ID = Clng(Rnd * 100000)
    oWshShell.Run sHTAFileName & " " & ID
    ' поиск окна HTA
    Set oWnd = Nothing
    For N = 1 to 1000
        For Each oWindow in oWindows
            If oWindow.GetProperty("ID") = ID Then
                Set oWnd = oWindow
                Exit For
            End If
        Next
        If Not oWnd Is Nothing Then Exit For
    Next
    ' удаление файла HTA
    oFSO.DeleteFile sHTAFileName, True
    ' возвращаем ссылку на окно HTA
    Set GetHTADialog = oWnd
End Function
'==================================================================================================
Sub HTA_OnUnload
    ExitDo = True
End Sub
Sub CloseHTA
    oHTA.document.parentWindow.close
End Sub
Sub OK_HTA
    val_1 = oHTA.document.parentWindow.input_1.value
    val_2 = oHTA.document.parentWindow.input_2.value
    oHTA.document.parentWindow.close
    ok = True
End Sub
'==================================================================================================
Set oDict = CreateObject("Scripting.Dictionary")
oDict.Add "CONTEXTMENU", "no"
oDict.Add "INNERBORDER", "no"
oDict.Add "SCROLL", "no"
oDict.Add "BORDER", "dialog"
oDict.Add "BORDERSTYLE", "raised"
oDict.Add "MAXIMIZEBUTTON", "no"
oDict.Add "MINIMIZEBUTTON", "no"
ok = False
Set oHTA = GetHTADialog(oDict)
If oHTA Is Nothing Then
    WScript.Echo "Не удалось получить связь с окном HTA."
    WScript.Quit
End If
' назначаем обработчик события выгрузки (закрытия) формы
oHTA.document.body.onunload = GetRef("HTA_OnUnload")
' задаём размеры формы
oHTA.document.parentWindow.resizeTo 350, 250
' получаем объет тела HTML-документа
Set oBody = oHTA.document.getElementsByTagName("body")(0)
' задаём цвет фона
oBody.bgcolor = "#E0E0E0"
' создаём текстовый элемент
oHTA.document.title = "Ввод значений"
Set oElem = oHTA.Document.createElement("p")
Set oText = oHTA.Document.createTextNode("Введите текстовое значение:")
oElem.appendChild oText
oBody.appendChild oElem
' создаём текстовое поле ввода
Set oElem = oHTA.Document.createElement("input")
oElem.setAttribute "width", "320"
oElem.setAttribute "id", "input_1"
oBody.appendChild oElem
' создаём текстовый элемент
Set oElem = oHTA.Document.createElement("p")
Set oText = oHTA.Document.createTextNode("Выберите файл:")
oElem.appendChild oText
oBody.appendChild oElem
' создаём поле выбора файла
Set oElem = oHTA.Document.createElement("input")
oElem.setAttribute "type", "file"
oElem.setAttribute "width", "320"
oElem.setAttribute "id", "input_2"
oBody.appendChild oElem
' создаём разделители
Set oElem = oHTA.Document.createElement("br")
oBody.appendChild oElem
Set oElem = oHTA.Document.createElement("br")
oBody.appendChild oElem
' создаём кнопку
Set oElem = oHTA.Document.createElement("button")
oElem.setAttribute "value", "    О'кей     "
oElem.onclick = GetRef("OK_HTA")
oBody.appendChild oElem
' создаём текстовый элемент
Set oText = oHTA.Document.createTextNode("             ")
oBody.appendChild oText
' создаём кнопку
Set oElem = oHTA.Document.createElement("button")
oElem.setAttribute "value", "Отменить"
oElem.onclick = GetRef("CloseHTA")
oBody.appendChild oElem
Do ' ожидание закрытия окна HTA
    WScript.Sleep 100
Loop Until ExitDo
If ok Then
    WScript.Echo "Введено текстовое значение: " & val_1
    WScript.Echo "Выбран файл: " & val_2
Else
    WScript.Echo "Окно HTA было закрыто кнопкой ""Отменить""."
End If

Другой вариант предыдущего примера. Делаем ту же диалоговую форму, но с помощью передачи строки HTML-кода:

Option Explicit
Dim ExitDo, oHTA, oDict, oBody, oElem, oText
Dim val_1, val_2, ok, strHTML
'==================================================================================================
Function GetHTADialog(ByRef Params)
    Dim oFSO, oWshShell, oWindows, oTextStream, oWnd, oWindow
    Dim sHTAFileName, ID, N
    
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oWshShell = CreateObject("WScript.Shell")
    Set oWindows = CreateObject("Shell.Application").Windows
    
    ' формирование имени будущего файла HTA
    sHTAFileName = oWshShell.ExpandEnvironmentStrings("%TEMP%") & "\" & oFSO.GetTempName() & ".hta"
    ' создание файла HTA
    Set oTextStream = oFSO.CreateTextFile(sHTAFileName, True)
    ' заполнение файла HTA
    With oTextStream
        .WriteLine ""
        .WriteLine ""
        .WriteLine ""
        .WriteLine ""
        .WriteLine ""
        .WriteLine ""
        .Close
    End With
    Randomize
    ID = Clng(Rnd * 100000)
    oWshShell.Run sHTAFileName & " " & ID
    ' поиск окна HTA
    Set oWnd = Nothing
    For N = 1 to 1000
        For Each oWindow in oWindows
            If oWindow.GetProperty("ID") = ID Then
                Set oWnd = oWindow
                Exit For
            End If
        Next
        If Not oWnd Is Nothing Then Exit For
    Next
    ' удаление файла HTA
    oFSO.DeleteFile sHTAFileName, True
    ' возвращаем ссылку на окно HTA
    Set GetHTADialog = oWnd
End Function
'==================================================================================================
Sub HTA_OnUnload
    ExitDo = True
End Sub
Sub CloseHTA
    oHTA.document.parentWindow.close
End Sub
Sub OK_HTA
    val_1 = oHTA.document.parentWindow.input_1.value
    val_2 = oHTA.document.parentWindow.input_2.value
    oHTA.document.parentWindow.close
    ok = True
End Sub
'==================================================================================================
Set oDict = CreateObject("Scripting.Dictionary")
oDict.Add "CONTEXTMENU", "no"
oDict.Add "INNERBORDER", "no"
oDict.Add "SCROLL", "no"
oDict.Add "BORDER", "dialog"
oDict.Add "BORDERSTYLE", "raised"
oDict.Add "MAXIMIZEBUTTON", "no"
oDict.Add "MINIMIZEBUTTON", "no"
ok = False
Set oHTA = GetHTADialog(oDict)
If oHTA Is Nothing Then
    WScript.Echo "Не удалось получить связь с окном HTA."
    WScript.Quit
End If
' назначаем обработчик события выгрузки (закрытия) формы
oHTA.document.body.onunload = GetRef("HTA_OnUnload")
' задаём размеры формы
oHTA.document.parentWindow.resizeTo 350, 250
' получаем объет тела HTML-документа
Set oBody = oHTA.document.getElementsByTagName("body")(0)
' задаём цвет фона
oBody.bgcolor = "#E0E0E0"
' формируем строку HTML-кода
strHTML = ""
strHTML = strHTML & "Введите текстовое значение:"
strHTML = strHTML & ""
strHTML = strHTML & "Выберите файл:"
strHTML = strHTML & ""
strHTML = strHTML & "

"
strHTML = strHTML & ""
strHTML = strHTML & "          "
strHTML = strHTML & "     "
strHTML = strHTML & ""
' записываем HTML-код в тело документа
oBody.innerHTML = strHTML
' назначение событий кнопкам
oHTA.document.parentWindow.bOK.onclick = GetRef("OK_HTA")
oHTA.document.parentWindow.bCancel.onclick = GetRef("CloseHTA")
Do ' ожидание закрытия окна HTA
    WScript.Sleep 100
Loop Until ExitDo
If ok Then
    WScript.Echo "Введено текстовое значение: " & val_1
    WScript.Echo "Выбран файл: " & val_2
Else
    WScript.Echo "Окно HTA было закрыто кнопкой ""Отменить""."
End If

Re: VBScript: конструирование и выдача диалогов с помощью HTA

2008-07-07T12:10:07Z

Улучшенный вариант предыдущего.
1) В панели задач больше не появляется пустой заголовок. Создание объекта WebBrowser сделано через Document.write.
2) Оптимизирована работа с коллекцией ShellApplication.Windows.
3) Заблокировано нажатие F5 на форме HTA, приводящее к обновлению формы (обрабатывается событие Document.onkeydown).
start.vbs

Option Explicit

Dim WebBrowser,Window,Document,ExitDo

Set WebBrowser = Run("form.hta")

Set Document = WebBrowser.Document
Set Window = Document.ParentWindow
Document.title = "Form1"
Document.body.onunload = GetRef("window_onunload")
Window.CommandButton1.onclick=GetRef("GetVars")

Sub GetVars
    MsgBox Window.InputBox1.value & vbCrlf & Window.InputBox2.value
    window.close
End Sub

Sub Window_onunload
    ExitDo = True
End Sub

'// Цикл ожидания события
Do
    WScript.Sleep 100
Loop Until ExitDo


'// Функция запуска HTA
Function Run(filename)
    Set Run = Nothing
        
    Dim WshShell
    Set WshShell = CreateObject("Wscript.Shell")
    
    Dim ID
    
    Randomize
    '// Создаём уникальный ID и передаём в 
    ID = Clng(Rnd * 100000)
    
    WshShell.Run filename & " " & ID
    Dim Windows,Counter
    Set Windows = CreateObject("Shell.Application").Windows

    For Counter = 1 to 1000
        For Each Window in Windows
            if Window.GetProperty("ID") = ID Then
                Set Run = Window
                Exit Function
            End if
        Next
    Next
    Err.Raise vbObjectError + 1,"Run","Не удалось получить связь с окном HTA"
End Function

connector.vbs

if IsObject(Window) Then
    Document.write ""
    Document.attachevent "onkeydown",GetRef("Document_onkeydown_event")
    window.attachevent "onload",GetRef("onload_event")
End if

Sub onload_event
    CommandLine = Document.all.tags("APPLICATION")(0).CommandLine
    Pos = InstrRev(CommandLine," ")
    CommandLine = mid(CommandLine,Pos + 1,Len(CommandLine)-Pos)
    if CommandLine = "" Then Exit Sub
    WebBrowser.RegisterAsBrowser = True
    WebBrowser.style.display = "none"
    WebBrowser.RegisterAsDropTarget = False
    WebBrowser.Visible = False
    WebBrowser.PutProperty "ID",Clng(CommandLine)
End Sub

Function Document_onkeydown_event
    if window.event.keycode = 116 Then Document_onkeydown_event = false
End Function

form.hta












    
        Param1 
        Param2

Автор примеров - Xameleon.

VBScript: конструирование и выдача диалогов с помощью HTA

2008-07-06T09:44:17Z

Порядок работы примера:
1) Запускается основной скрипт.
2) Процедура Run генерирует случайное число и запускает HTA файл, передавая это число параметром.
3) В HTA файле создаётся компонент WebBrowser, отсекает переданное число от хвоста commandline и выставляет WebBrowser-у свойство ID с этим числом.
4) Основной скрипт в это время ждёт появления WebBrowser-а с таким ID.
start.vbs

Dim WebBrowser,Window,Document

Set WebBrowser = Run("form.hta")

Set Document = WebBrowser.Document
Set Window = Document.ParentWindow
Document.body.onunload = GetRef("window_onunload")
Window.CommandButton1.onclick=GetRef("GetVars")

Sub GetVars
    MsgBox Window.InputBox1.value & vbCrlf & Window.InputBox2.value
    window.close
End Sub

Sub Window_onunload
    ExitDo = True
End Sub

'// Цикл ожидания события
Do
    WScript.Sleep 100
Loop Until ExitDo


'// Функция запуска HTA
Function Run(filename)
    Set Run = Nothing
    
    
    Dim WshShell
    Set WshShell = CreateObject("Wscript.Shell")
    
    Dim ID
    
    Randomize
    '// Создаём уникальный ID и передаём в 
    ID = Clng(Rnd * 100000)
    
    WshShell.Run filename & " " & ID

    Set ShellApplication = CreateObject("Shell.Application")

    For N=1 to 1000
        For Each Window in ShellApplication.Windows
            if Window.GetProperty("ID") = ID Then
                Set Run = Window
                Exit Function
            End if
        Next
    Next
    Err.Raise vbObjectError + 1,"Run","Не удалось получить связь с окном HTA"
End Function

connector.vbs

if IsObject(window) Then window.attachevent "onload",GetRef("Main")
Sub Main
    Dim CommandLine,Pos
    CommandLine = Document.all.tags("APPLICATION")(0).CommandLine
    Pos = InstrRev(CommandLine," ")
    CommandLine = mid(CommandLine,Pos + 1,Len(CommandLine)-Pos)
    if CommandLine = "" Then Exit Sub
    Set WebBrowser = Document.createElement("OBJECT")
    WebBrowser.classid = "clsid:8856F961-340A-11D0-A96B-00C04FD705A2"
    WebBrowser.RegisterAsBrowser = True
    Document.appendchild WebBrowser
    WebBrowser.PutProperty "ID",Clng(CommandLine)
End Sub

form.hta












    
        Param1 
        Param2

Примечание: connector.vbs не обязательно должен находиться в отдельном файле, его можно вставить и в саму форму (в код HTA). Вынос этого скрипта имеет смысл, если HTA-форм много.
Автор примеров - Xameleon.