1

Тема: VBScript: Как создать окно ввода с заданным временем ожидания.

Добрый вечер!


intext=inputbox("")

Возможно ли сделать ограничение по времени этому окошку запроса данных, или может есть другие способы осуществить подобный ввод данных с таймером, по окончании которого окошко бы просто исчезало?

Стремление - залог успеха

2 (изменено: wisgest, 2013-01-08 19:14:04)

Re: VBScript: Как создать окно ввода с заданным временем ожидания.

Мне представляется что без создания дополнительного процесса задачу не решить.
Т.к. предполагается обмениваться только текстовыми данными, то проще всего его запускать с помощью WshShell.Exec().

Вспомогательный файл InputBox.vbs:

Input = InputBox("")
WScript.StdOut.Write Input
WScript.Quit IsEmpty(Input)

(Можно будет добавить передачу дополнительных аргументов для InputBox() через аргументы командной строки, стандартный поток ввода или, даже, переменные окружения.)
(Вместо отдельного файла можно использовать задание в WSF-файле.)

Основной скрипт:

Set WshShell = CreateObject("WScript.Shell")

Input = InputBoxWithTimeout(15)
If Not IsEmpty(Input) Then
  MsgBox "Введено [" & Input & "]"
Else
  MsgBox "Ничего не введено"
End If

Function InputBoxWithTimeout(SecondsToWait)
  With WshShell.Exec("WScript.exe InputBox.vbs")
    For I = 1 To SecondsToWait * 10
      WScript.Sleep 100
      If .Status = 1 Then
        If .ExitCode = 0 Then InputBoxWithTimeout = .StdOut.ReadAll()
        Exit Function
      End If
    Next
    .Terminate
  End With
End Function

Я лишь не пойму: почему при SecondsToWait = 0, если отсчёт в цикле вести от 0, то окно закрывается сразу, а от 1 — нет, хотя должно быть наоборот?

3

Re: VBScript: Как создать окно ввода с заданным временем ожидания.

Если нужно просто выйти из скрипта, то достаточно перед функцией прописать WScript.Timeout = <Seconds>.

4

Re: VBScript: Как создать окно ввода с заданным временем ожидания.

Хм, я тут подумал, если же и использовать вспомогательный файл, то может сделать просто с аргументами и Timeout.

Вот основной скрипт:

'Какой-нибудь код

Timeout = 5 'Количество секунд, через которое должен отключиться InputBox

Set a = CreateObject("WScript.Shell")
Set b = a.Exec("Wscript InputBox.vbs " & Timeout)

Do

If b.ExitCode = 0 Then TimeoutInputBox = b.StdOut.ReadAll

WScript.Sleep 100

Loop Until b.Status = 1 


If TimeoutInputBox <> "" Then MsgBox TimeoutInputBox Else MsgBox "Ничего не ввели"

'Продолжение кода

А вот вспомогательный:

WScript.Timeout = WScript.Arguments.Item(0)

WScript.StdOut.Write InputBox ("Введи что-нибудь")

Ну а если делать временный, то можно одним скриптом...
Только все как-то сложно получится:

Timeout = 5 'Количество секунд, через которое должен отключиться InputBox

Set FSO = CreateObject("Scripting.FileSystemObject")

With FSO.OpenTextFile("InputBox.vbs", 2, True)
.WriteLine "WScript.Timeout = WScript.Arguments.Item(0)"
.Write "WScript.StdOut.Write InputBox (""Введи что-нибудь"")"
.Close
End With

Set a = CreateObject("WScript.Shell")
Set b = a.Exec("Wscript InputBox.vbs " & Timeout)

Do

If b.ExitCode = 0 Then TimeoutInputBox = b.StdOut.ReadAll

WScript.Sleep 100

Loop Until b.Status = 1 

FSO.DeleteFile "InputBox.vbs"

If TimeoutInputBox <> "" Then MsgBox TimeoutInputBox Else MsgBox "Ничего не ввели"

Set a = Nothing
Set b = Nothing
Set FSO = Nothing
Программист - это не профессия, а смысл жизни (с)

5 (изменено: wisgest, 2013-01-11 16:46:30)

Re: VBScript: Как создать окно ввода с заданным временем ожидания.

Wscript.Timeout — напрочь вылетело из головы (из-за того, что никогда там прочно и не сидело). Ну, в таком случае, чуть проще будет передавать задержку не вспомогательному скрипту, а самому WScript.exe как ключ //T:<секунды>.

Так же в #2 я различал, с одной стороны, случай ввода пустой строки и, с другой, нажатие «Отмена» или окончание врмени (последние два случая тоже можно было бы различить между собой).
Теперь же (используя //T) надо при нажатии «OK» наоборот возвращать ненулевой код завершения (или истечение времени будет рассматриваться как ввод пустой строки, а не «Отмена»). (И что-то я не представляю, как различить при необходимости истечение времени и «Отмену». Добавлено: На самом деле всё просто — при нажатии «OK» или «Отмена» возвращать разные ненулевые коды завершения, ну или передавать доп.сведения отдельной строкой в выходном потоке. )

Но, в целом, это всё равно неправильный подход, т.к. при начале ввода отсчёт времени должен прекращаться, а здесь это невозможно осуществить.

6

Re: VBScript: Как создать окно ввода с заданным временем ожидания.

html

Я конечно далек от мысли... (с)

7

Re: VBScript: Как создать окно ввода с заданным временем ожидания.

Okey, спасибо за идейки, буду размышлять над ними и эксперементировать по возможности...
Понравилась фишка с wscript.timeout, но увы она не подходит в данном случае по своей безУсловности... А насчёт запуска другого vbs-ника, хотелось бы обойтись без него, но пока как показывают обстоятельства никак.

wisgest пишет:

(И что-то я не представляю, как различить при необходимости истечение времени и «Отмену».)

В этом как раз нет необходимости, есть необходимость лишь получать то, что вводят в окошке...
Кстати, вспомнилась изумительная для меня ExecuteGlobal, может что-нибудь в этом направлении слепим, да бы избежать по возможности запуска доп.скрипта... Первая попытка:

ExecuteGlobal "Wscript.Timeout=5 : intext=inputbox("""")"
msgbox "текст после таймера"

увенчалась провалом...

Стремление - залог успеха

8 (изменено: smaharbA, 2013-01-17 15:04:09)

Re: VBScript: Как создать окно ввода с заданным временем ожидания.

ExecuteGlobal "Wscript.Timeout=2"
msgbox Eval("inputbox("""")")
Я конечно далек от мысли... (с)

9

Re: VBScript: Как создать окно ввода с заданным временем ожидания.

smaharbA пишет:

ExecuteGlobal "Wscript.Timeout=2"
msgbox Eval("inputbox("""")")

Так-то сценарий весь закрывается, без возможности продолжаться...

Программист - это не профессия, а смысл жизни (с)

10 (изменено: wisgest, 2013-01-11 21:40:43)

Re: VBScript: Как создать окно ввода с заданным временем ожидания.

Только сейчас обратил внимание, что, как при использовании WScript.Timeout, так и WSCRIPT.EXE//T, если время вышло, то возвращается набранная в InputBox в тот миг строка без необходимости подтверждения. Интересное, хотя и непонятное мне поведение!
Также не очень понимаю, как влияет ExecuteGlobal() в примере smaharbA (Eval() во второй строке, по-моему, никак не влияет и без него можно обойтись). Но в том примере, если в InputBox нажать OK, то действие .Timeout распространяется и на MsgBox; и, по-любому, после MsgBox ничего уже не работает.

11

Re: VBScript: Как создать окно ввода с заданным временем ожидания.

В общем остановился я на решении запускать другой файл, всем спасибо за помошь!
Ради спортивного интереса выкладываю непонятный для меня момент, с которым столкнулся во время одного из экспериментов:
Основной скрипт


Set E = CreateObject("WScript.Shell").Exec("wscript 1.vbs")
keytime=3000
wscript.sleep keytime
E.terminate
msgbox E.StdOut.ReadAll
wscript.quit

Вспомогательный


intext=InputBox("1")
'...
intext=InputBox("2")
'...
WScript.StdOut.Write "outtext"

Так вот, когда запускаем сценарий и просто ждём, всё хорошо начинается, открывается первый inputbox, но при выполнении terminate у меня начинаются чудеса: вполне логично закрывается первый inputbox, но тут же продолжается выполнение вспомогательного скрипта, т.е. открывается уже второй inputbox, закрывается и он, и только потом вспомогательный скрипт прекращает своё выполнение; а основной скрипт в процентах 90% случаев вылетает с ошибкой


---------------------------
Windows Script Host
---------------------------
Сценарий:    основной скрипт.vbs
Ошибка:    Недопустимый дескриптор окна. 
Код:    80070578
Источник:     (null)
---------------------------
ОК   
---------------------------

а в остальных уж 10% доходит до конца и выдаёт пустой StdOut. Насчёт пустого StdOut понятно, но почему возобновляется выполнение вспомогательного скрипта вплоть до второго inputbox, при попытке убивании его terminate-ом?

Стремление - залог успеха

12 (изменено: smaharbA, 2013-01-17 15:04:29)

Re: VBScript: Как создать окно ввода с заданным временем ожидания.

Обернуть ?

var s=new ActiveXObject("MSScriptControl.ScriptControl");
s.language="vbscript";
WScript.Timeout=5;
s.AddObject("WScript",WScript);
s.executestatement('\
x=inputbox(""):\
msgbox x:\
')
Я конечно далек от мысли... (с)

13

Re: VBScript: Как создать окно ввода с заданным временем ожидания.

smaharbA, гениально, жаль что это js-скрипт; может как-нить удастся это переделать под vbs? Т.к. скрипт у меня длинный, и уж так повелось, что js это не моё, не умею я там работать как ни пытался...

P.S: Я тут подумал, раз уж из под js можно юзать vbs-сценарий, нельзя ли сделать наоборот - из vbs js-возможности?

Стремление - залог успеха

14 (изменено: smaharbA, 2013-01-17 15:04:55)

Re: VBScript: Как создать окно ввода с заданным временем ожидания.

set s=CreateObject("MSScriptControl.ScriptControl")
s.language="vbscript"
s.AddObject "WScript",WScript
set fso=CreateObject("Scripting.FileSystemObject")
set f=fso.OpenTextFile(WScript.ScriptFullName)
for x=1 to 8: f.SkipLine: next
s.executestatement(f.ReadAll())
WScript.Quit()
WScript.Timeout=3
x=inputbox("")
msgbox x
msgbox 123
Я конечно далек от мысли... (с)

15 (изменено: smaharbA, 2013-01-17 15:05:49)

Re: VBScript: Как создать окно ввода с заданным временем ожидания.

set s=CreateObject("MSScriptControl.ScriptControl")
s.language="vbscript"
s.AddObject "WScript",WScript
set fso=CreateObject("Scripting.FileSystemObject")
set f=fso.OpenTextFile(WScript.ScriptFullName)
do while f.ReadLine()<>"WScript.Quit():rem Start":loop
s.executestatement(f.ReadAll())
WScript.Quit():rem Start
WScript.Timeout=3
x=inputbox("")
msgbox x
msgbox 123

Но наверное будет проблема с асинхронным вызовом процедур


офф: как с этим - http://forum.script-coding.com/help.php ?

Я конечно далек от мысли... (с)

16

Re: VBScript: Как создать окно ввода с заданным временем ожидания.

smaharbA, приведи свои посты в соответствие Правилам.

Разработка AHK-скриптов:
e-mail dfiveg@mail.ru
Skype dmitry_fiveg

17

Re: VBScript: Как создать окно ввода с заданным временем ожидания.

smaharbA, интересное решение однако , раньше нигде не сталкивался с объектом MSScriptControl. Но не без трудностей при видоизменении скрипта. Как я понял самосчитывание тела скрипта необходимо, т.к. после запуска s.executestatement() и истечения времени timeout, команды, стоящие после s.executestatement() попросту не выполняются. Хотел похитрить, чтоб как-то выйти из него, после выполнения мне нужных там комманд (inputbox), но увы пока безуспешны. Вот одна из моих попыток, чтоб была понятна суть моих стараний:


set s=CreateObject("MSScriptControl.ScriptControl")
s.language="vbscript"
s.AddObject "WScript",WScript
do
s.executestatement("WScript.Timeout=3 : x=inputbox("""") : Exit do")
loop
msgbox x
msgbox 123

Как я понял s.executestatement() запускает независимый скрипт в скрипте? (Хорошей русскоязычной литературы, не считая машинного перевода по MSScriptControl не нашёл). Может есть какие-то доп. опции, чтоб взять под контроль это дело?

P.S. Кстати, объект "MSScriptControl.ScriptControl" на Windows 7 Home Basic не создаётся, пришлось на старом добром XP тестить.

Стремление - залог успеха

18

Re: VBScript: Как создать окно ввода с заданным временем ожидания.

по поводу "не создается"
\Windows\SysWOW64\wscript.exe c:\d.vbs

по поводу выхода из цикла - наверное только флаг типа

set s=CreateObject("MSScriptControl.ScriptControl")
s.language="vbscript"
s.AddObject "WScript",WScript
do while not [флаг]
s.executestatement("WScript.Timeout=3 : x=inputbox("""") : [флаг]=true")
[флаг]=s.eval("[флаг]")
loop
WScript.Timeout=0
msgbox x
msgbox 123
Я конечно далек от мысли... (с)

19

Re: VBScript: Как создать окно ввода с заданным временем ожидания.

smaharbA пишет:

[флаг]=true

Не силён. На примере.

Стремление - залог успеха

20

Re: VBScript: Как создать окно ввода с заданным временем ожидания.

это просто пример применения имен переменных в национальных символах ))
могло быть и flag=true

Я конечно далек от мысли... (с)

21

Re: VBScript: Как создать окно ввода с заданным временем ожидания.

А, понял. Ну а вы сами пробовали запускать его? Дело в том, что после истечения timeout, если не ответили на окно запроса inputbox, окошко закрывается и скрипт довыполняет только то, что внутри s.executestatement(""), и далее скрипт закрывается, не доходя уже даже до loop или что бы там ни было. Целью моего введенного цикла была то, что я хотел как-нибудь вытащить фокус выполнения сценария из s.executestatement("") с помощью Exit do, а не наличие самого цикла.

А еще, если всё же успеть ввести текст и нажать ОК (ну или просто Отмену) до истечения timeout, скрипт продолжает выполняться нормально, доходит до msgbox, но вот введённый текст опять таки не выходит за пределы s.executestatement(""), т.е. выходит пустое окно msgbox.

Стремление - залог успеха

22

Re: VBScript: Как создать окно ввода с заданным временем ожидания.

set s=CreateObject("MSScriptControl.ScriptControl")
s.language="vbscript"
s.AddObject "WScript",WScript
do while not [флаг]
s.executestatement("WScript.Timeout=3 : x=inputbox("""") : [флаг]=true")
[флаг]=s.eval("[флаг]")
x=s.eval("x")
loop
WScript.Timeout=0
msgbox x
msgbox 123

а то, что после таймаута не выполняется, наверное так и должно быть (

Я конечно далек от мысли... (с)

23 (изменено: smaharbA, 2013-01-18 22:32:32)

Re: VBScript: Как создать окно ввода с заданным временем ожидания.

скорее всего само выполнение внутри объекта это уже "багофича" (

по тому и выше был предложен вариант "самочтения" и выполнения нужного тела

наверное всеж таки проще исполюзовать showModalDialog от хтмл, как нибудь встроив его в скрипт

Я конечно далек от мысли... (с)

24

Re: VBScript: Как создать окно ввода с заданным временем ожидания.

Наверно. smaharbA, спасибо! будем пробовать что проще...

Кстати, хороша и идея

wisgest пишет:

Вместо отдельного файла ... использовать задание в WSF-файле.

Стремление - залог успеха

25

Re: VBScript: Как создать окно ввода с заданным временем ожидания.

Lucky пишет:

intext=inputbox("")

может есть другие способы осуществить подобный ввод данных с таймером

Вот здесь http://gallery.technet.microsoft.com/sc … t-36122f57 есть нечто подобное. Если допилить, вполне сгодится для решения вопроса.

Щт Уккщк Куыгьу Туче
’ҐЄгй п Є®¤®ў п бва Ёж : 1251

26

Re: VBScript: Как создать окно ввода с заданным временем ожидания.

omegastripes пишет:
Lucky пишет:

intext=inputbox("")

может есть другие способы осуществить подобный ввод данных с таймером

Вот здесь http://gallery.technet.microsoft.com/sc … t-36122f57 есть нечто подобное. Если допилить, вполне сгодится для решения вопроса.

OFFTOP: Дожили! ))) Наш c JSman-ом код уже на микрософте публикуют ! )))))

Передумал переделывать мир. Пашет и так, ну и ладно. Сделаю лучше свой !

27

Re: VBScript: Как создать окно ввода с заданным временем ожидания.

Решил ради интереса тоже попробовать свои силы.


Option Explicit

Dim returnValue
returnValue = createInput("У вас есть 10 секунд на ввод нужного значения или сообщение закроется само собой. B)","Заголовок сообщения",10000)

MsgBox returnValue,vbInformation,"Введённое значение"

'Функция создания окна похожего на inputBox с таймаутом в миллисекундах
Function createInput(prompt,title,timeout)
    Dim content, wnd, status
    'Задаём HTML код окна
    content =  "<html>" &_
                    "<head>" &_
                        "<style>" &_
                            "*{font-family:Tahoma;font-size:13px;}" &_
                            "button,input,span{position:absolute;}" &_
                            "button{width:80px;}" &_
                            "#lblPrompt{left:10px;top:10px;overflow:hidden;width:250px;height:80px;}" &_
                            "#btnOk{left:265px;top:10px;}" &_
                            "#btnCancel{left:265px;top:40px;}" &_
                            "#inpText{top:98px;width:330px;}" &_
                        "</style>" &_
                    "</head>" &_
                    "<body bgcolor=#F0F0F0>" &_
                        "<span id='lblPrompt'></span>" &_
                        "<button id='btnOk' onclick='window.returnValue=inpText.value;window.status=1'>OK</button>" &_
                        "<button id='btnCancel' onclick='window.status=1;'>Отмена</button>" &_
                        "<input id='inpText'>" &_
                    "</body>" &_
                "</html>"

    'Создаём нужное нам окошко (без скролов, без меню и т.п)
    Set wnd = createWindow(content,"border=dialog " &_
                                "minimizeButton=no " &_
                                "maximizeButton=no " &_
                                "scroll=no " &_
                                "showIntaskbar=yes " &_
                                "contextMenu=no " &_
                                "selection=no " &_
                                "innerBorder=no")

    
    'Устанавливаем таймер таймаута
    wnd.execScript "window.setTimeout('window.close()'," & Clng(timeout) & ");window.returnValue=''"

    'Заполняем нужные нам объекты текстом
    With wnd
        'По умолчанию выставляем статус 0 (потом будем проверять его в цикле)
        .status = 0
        'Ставим фокус на кнопку OK
        .btnOk.focus
        'Задаём заголовок окна
        .document.title = title
        'Заполняем поле запроса в окне
        .lblPrompt.innerText = prompt
        'Двигаем окошко на нужные нам координаты (при желании можно отцентрировать по wnd.screenWidth / wnd.screenHeight)
        .moveTo 100, 100
        'Задаём ширину и высоту окошка
        .resizeTo 370, 170
    End With
    
    
    Do
        'Проверяем статус окна
        On Error Resume Next
        status = wnd.status
        'Если окошко закрыли кнопкой [X], то произойдёт ошибка обращения к нему
        If Err.number <> 0 Then 
            On Error Goto 0
            'В этом случае выходим из цикла
            Exit Do
        Else
            'Если же статус равен "1", то возвращаем из функции заполненное свойство и выходим из цикла
            if status = 1 Then 
                createInput = wnd.returnValue
                Exit Do
            End if
        End if
        WScript.Sleep 100
    Loop
    'По концу функции закрываем окно
    wnd.close
End Function

'Функция создания HTA окна
Function createWindow(content,features)
    Dim wid, we, sw, id, i, doc
    Randomize:wid = Clng(Rnd*100000)
    Set we = CreateObject("WScript.Shell").Exec("mshta about:""" & _
    "<script>moveTo(-1000,-1000);resizeTo(0,0);</script>" & _
    "<hta:application id=app " & features & " />" & _
    "<object id=" & wid & " style='display:none' classid='clsid:8856F961-340A-11D0-A96B-00C04FD705A2'>" & _
    "<param name=RegisterAsBrowser value=1>" & _
    "</object>""")
    With CreateObject("Shell.Application")
        For i=1 to 1000
            For Each sw in .Windows
                On Error Resume Next
                id = Clng(sw.id)
                On Error Goto 0
                if id = wid Then
                    Set doc = sw.container
                    doc.write CStr(content)
                    Set createWindow = doc.parentWindow
                    Exit Function
                End if
            Next
        Next
    End With
    we.Terminate
    Err.Raise vbObjectError,"createWindow","Can't connect with created window !"
End Function
Передумал переделывать мир. Пашет и так, ну и ладно. Сделаю лучше свой !

28

Re: VBScript: Как создать окно ввода с заданным временем ожидания.

2Xameleon
Отличный образчик (а в частности хак с 8856F961-340A-11D0-A96B-00C04FD705A2)! Визуальный аппеаранс окна лучше по сравнению с вышеупомянутым способом.

Думаю вполне актуальным будет класс, использующий данную технику создания окон, и позволяющий "обернуть" в удобные методы создание пользовательского окна, размещение на нем базовых контролов и доступ к их свойствам и событиям. По крайней мере для тех, кто решает определенные задачи в среде WSH c административными ограничениями - решение получится портабельным, без необходимости регистрации в системе компонентов.
PS: Кстати, вопрос о создании пользовательских окон можно найти на любом форуме, затрагивающем WSH.

Щт Уккщк Куыгьу Туче
’ҐЄгй п Є®¤®ў п бва Ёж : 1251

29

Re: VBScript: Как создать окно ввода с заданным временем ожидания.

Для облегчения создания окна и обработки событий элементов, добавлены классы-обертки:

  • clsSmallWrapperForm, включающий все основные параметры и методы, необходимые для создания окна HTA, установки его размеров, свойств и аттрибутов.

  • clsSmallWrapperHandlers, имитирующий в своих методах общепринятую структуру VB обработчиков, события элементов пробрасываются в методы этого класса.

По сути - ничего нового, основная идея - дать возможность создания простого GUI для VBS WSH написанием минимального количества строк кода c применением предлагаемых оберток. Код создания формы и элементов управления, обработчиков их событий пишется в общепринятом VB стиле, пользователю не нужно заморачиваться с HTML и DOM. Ну только если самую малость - минимальные знания об элементах HTML, их главных аттрибутах и стилях все же нужны. Можно добавить в clsSmallWrapperForm обертки для определенного ряда типичных элементов управления и метод для их создания, это окончательно скрыло бы от глаз пользователя названия тэгов и аттрибутов.

Option Explicit

' Base64-кодированный фоновый рисунок
Const BGI = "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAWIAAAB2CAYAAADybJlDAAAACXBIWXMAAC4jAAAuIwF4pT92AAAAIGNIUk0AAHolAACAgwAA+f8AAIDpAAB1MAAA6mAAADqYAAAXb5JfxUYAAAUjSURBVHja7N05ztxGEIBRjqHciZ34Bn3/w9QNnPsE49QwtPwc9lLd9V4kAdKwyQE+Fjnb6/1+XwCs85tDACDEAEIMgBADCDEAQgwgxAAIMYAQAyDEAEIMgBADCDEAQgwgxACM980hgD28Xq/Td7Hd/PdxzHPri+FBiBPH9hPbBVqIQYh3D+/2YRZiEOIT47tVmIUYhLhCfFMHWYhBiKsFOF2UhRiEuHKAUwRZiEGIBXhxkIUYhFiAFwdZiEGIBXhxjIUYhDhLhCP5OocFWYhBiGeHLaxdiEGI54YsNljj0n0SYhDiEYGLhGtKG2MhBiHOFuCdXiDsEmMhhtoh7hW9SLKOLWMsxFA3xD3iVznA3Y6FEEPNED8NoAB3PC5CDPVCvDLCFT4gcvv4CDHUCvGTEFYKcMw8Vn48FOpYEeG28RQ87cRjIoYaE/GnMdxpCo7O2336eH9f1/WPEIMQr4jwyo8Zt4HbaqOOoRCDEGePcCzc9pQYCzGcHeJZER45ia6ewmP0MfViHZxrxwjHle9XltvoYyTEIMIZIvwkwDNvvfT6/0IMpInw0wn4SYTj4Xa63T4RYjANr4hwj1sQKybhIc+NEIMIz4xwr3vAvSI8eyo2EQNLAphhGo1Ej92EGESyW0AWhbD3fkaHbT86lkIMNc2KcO+3ox3500lCDPWm4ZkRXjnx31lDTDgeP3wcIYZaEZ712Bk+lBG7bFOIoZbYdBsz3g0SC/a/CTGw6lZAlok/xZqEGGrFsg163FW3AnqvY8lULMQg3pkj3JKsYyghhjrT8KhL66oRbr3WI8Qg5OUm0Gz7JMQgxhmDdcoJ4UvrEmKoF9AfPVbbdN+2n8qFGNg5fkfcGhFiIFP82mb72Ho8lhDD+dOrqdxEDCyc6mLAY54+lQsxkDrspvwBx06IQUDtj4kYGDA5xnf+Hpvv07GEGEzHd4LZO5qVXqALIQZ6xaxtuu602xNiYNV03A46FkIM7BuhpNPwVEIM50VvxddBjvqC+hKEGAQ9++PG6U+IEAOzp+M7wS7xHmghBnaajk3EgEA+nI4rT8NCDNy+hO4VQtPxL3xzCIAvTKWz3zOcYRr+a9ZaTcSA2wTf9/usDQkxcCfGMWk7pQgx1PGHUAoxsNafHUM7ajouGXkhBjKFc8RXbQoxUCLGgizEgCB33+60KwIhBgR5ceB9oAPYNWTHvLBnIoa9Js2el9UnRPmIfRViYNol+CZBnh53tyaAE+O/1ScAhRgQ5cWEGBgZwa9OlW3SeqLj2rsdF/eIQQxXif/9OSYdlx73lLuuVYhhL9kvs3sELiau9b9RXnbyEmIg6wln5kln6U84CTGcK/Ptibjx72ZHefpz4cU6YJfwx6Tt3NnPLicIIYY9L9vb5us/Icg/W8OtfRRiOH9KPfXL1mPiND706kCIgenhKRblX/JiHdS5vM/wpUGzPnq81Qt8Qgym1dNPWOmjLMRQayquHPq0URZiMBVXO3GYiIEtYnjy7Yxs+xZCDDXCOipAuwW7fXB8h0/y3r4GZDthZIrwz9bfeh0XIYYzIvfVKNyJx0kfBmmDjnuXbbk1AZzukwjHhG2FEINL/4xTZpUIm4hBjKfGdtXtjZZ4WyHEwOk+jfCSk4YQg6k402S5Y4Tb0+0IMTAyPpF0XWkiLMRgKj5lKn7yy8yx+pgIMYhxlel8dYRDiEGMT5uK23VAhIUYqDgFp4rwdV3X6/1+e0phA6/Xa7dJ9rT3NQ+7B/0vAAAA//8DAERsQ7O6796eAAAAAElFTkSuQmCC"

Dim aItems, i

' Массив, содержащий пункты для списка
aItems = Array("Пункт A", "Пункт B", "Пункт C", "Пункт D", "Пункт E")

' Создание обертки HTA окна
With New clsSmallWrapperForm
	' Настройка окна
	.ShowInTaskbar = "yes"
	.Title = "Тест формы HTA"
	.BackgroundImage = BGI
	.Width = 354
	.Height = 118
	.Visible = False
	' Создание окна
	.Create
	' Назанчение обработчиков
	Set .Handlers = New clsSmallWrapperHandlers
	' Добавление списка
	With .AddElement("ListBox1", "SELECT")
		.size = 6
		.multiple = True
		.style.left = "15px"
		.style.top = "10px"
		.style.width = "250px"
	End With
	.AppendTo "Form"
	' Добавление пунктов в список
	For i = 0 To UBound(aItems)
		.AddElement , "OPTION"
		.AddText aItems(i)
		.AppendTo "ListBox1"
	Next
	' Добавление кнопки OK
	With .AddElement("Button1", "INPUT")
		.type = "button"
		.value = "OK"
		.style.left = "285px"
		.style.top = "10px"
		.style.width = "50px"
		.style.height = "20px"
	End With
	.AppendTo "Form"
	' Добавление кнопки Отмена
	With .AddElement("Button2", "INPUT")
		.type = "button"
		.value = "Отмена"
		.style.left = "285px"
		.style.top = "40px"
		.style.width = "50px"
		.style.height = "20px"
	End With
	.AppendTo "Form"
	' Добавление надписи
	With .AddElement("Label1", "SPAN")
		.style.left = "15px"
		.style.top = "98px"
		.style.width = "350px"
	End With
	.AddText "Выберите пункты"
	.AppendTo "Form"
	' Показать окно
	.Visible = True
	' Ожидание закрытия окна или выбора пунктов пользователем
	Do While .ChkDoc And Not .Handlers.Selected
		WScript.Sleep 100
	Loop
	' Получение результатов из массива .Handlers.SelectedItems
	If .Handlers.Selected Then
		MsgBox "Выбрано " & (UBound(.Handlers.SelectedItems) + 1) & " пункт(ов)" & vbCrLf & Join(.Handlers.SelectedItems, vbCrLf)
	Else
		MsgBox "Окно закрыто"
	End If
	' Остальная часть кода ...
	
End With

Class clsSmallWrapperHandlers
	
	' Класс обработчиков реализует обработку событий
	' Отредактируйте код для обеспечения требуемого поведения
	' Сохраняйте общепринятые для VB имена обработчиков: Public Sub <ID элемента>_<Название события>()
	
	Public oswForm ' обязательное свойство
	
	Public Selected
	Public SelectedItems
	
	Private Sub Class_Initialize()
		Selected = False
		SelectedItems = Array()
	End Sub
	
	Public Sub ListBox1_Click()
		Dim vItem
		With CreateObject("Scripting.Dictionary")
			For Each vItem In oswForm.Window.ListBox1.childNodes
				If vItem.Selected Then .Item(vItem.innerText) = ""
			Next
			SelectedItems = .Keys()
		End With
		oswForm.Window.Label1.style.color = "buttontext"
		oswForm.Window.Label1.innerText = (UBound(SelectedItems) + 1) & " выбрано"
	End Sub
	
	Public Sub Button1_Click()
		Selected = UBound(SelectedItems) >= 0
		If Selected Then
			oswForm.Window.close
		Else
			oswForm.Window.Label1.style.color = "darkred"
			oswForm.Window.Label1.innerText = "Выберите хотя бы 1 пункт"
		End If
	End Sub
	
	Public Sub Button2_Click()
		oswForm.Window.close
	End Sub
	
End Class

Class clsSmallWrapperForm
	
	' Служебный класс для функциональности HTA окна
	' Не подлежит изменению
	
	' Аттрибуты тэга HTA
	Public Border ' thick | dialog | none | thin
	Public BorderStyle ' normal | complex | raised | static | sunken
	Public Caption ' yes | no
	Public ContextMenu ' yes | no
	Public Icon ' path
	Public InnerBorder ' yes | no
	Public MinimizeButton ' yes | no
	Public MaximizeButton ' yes | no
	Public Scroll ' yes | no | auto
	Public Selection ' yes | no
	Public ShowInTaskbar ' yes | no
	Public SysMenu ' yes | no
	Public WindowState ' normal | minimize | maximize
	
	' Свойства формы
	Public Title
	Public BackgroundImage
	Public Width
	Public Height
	Public Left
	Public Top
	Public Self
	
	Dim oWnd
	Dim oDoc
	Dim bVisible
	Dim oswHandlers
	Dim oLastCreated
	
	Private Sub Class_Initialize()
		Set Self = Me
		Set oswHandlers = Nothing
		Border = "thin"
		ContextMenu = "no"
		InnerBorder = "no"
		MaximizeButton = "no"
		Scroll = "no"
		Selection = "no"
	End Sub
	
	Private Sub Class_Terminate()
		On Error Resume Next
		oWnd.Close
	End Sub
	
	Public Sub Create()
		Dim sName, sAttrs, sSignature, oShellWnd, oProc
		sAttrs = ""
		For Each sName In Array("Border", "Caption", "ContextMenu", "MaximizeButton", "Scroll", "Selection", "ShowInTaskbar", "Icon", "InnerBorder", "BorderStyle", "SysMenu", "WindowState", "MinimizeButton")
			If Eval(sName) <> "" Then sAttrs = sAttrs & " " & sName & "=" & Eval(sName)
		Next
		If Len(sAttrs) >= 240 Then Err.Raise 450, "<HTA:APPLICATION" & sAttrs & " />"
		sSignature = Mid(Replace(CreateObject("Scriptlet.TypeLib").Guid, "-", ""), 2, 16)
		Set oProc = CreateObject("WScript.Shell").Exec("mshta ""about:<script>moveTo(-32000,-32000);document.title='*'</script><hta:application" & sAttrs & " /><object id='s' classid='clsid:8856F961-340A-11D0-A96B-00C04FD705A2'><param name=RegisterAsBrowser value=1></object><script>s.putProperty('" & sSignature & "',document.parentWindow);</script>""")
		Do
			If oProc.Status > 0 Then Err.Raise 507, "mshta.exe"
			For Each oShellWnd In CreateObject("Shell.Application").Windows
				On Error Resume Next
				Set oWnd = oShellWnd.GetProperty(sSignature)
				If Err.Number = 0 Then
					On Error Goto 0
					With oWnd
						Set oDoc = .document
						With .document
							.open
							.close
							.title = Title
							.getElementsByTagName("head")(0).appendChild .createElement("style")
							.styleSheets(0).cssText = "* {font:8pt tahoma;position:absolute;}"
							.getElementsByTagName("body")(0).id = "Form"
						End With
						.Form.style.background = "buttonface"
						If BackgroundImage <> "" Then
							.Form.style.backgroundRepeat = "no-repeat"
							.Form.style.backgroundImage = "url(" & BackgroundImage & ")"
						End If
						If IsEmpty(Width) Then Width = .Form.offsetWidth
						If IsEmpty(Height) Then Height = .Form.offsetHeight
						.resizeTo .screen.availWidth, .screen.availHeight
						.resizeTo Width + .screen.availWidth - .Form.offsetWidth, Height + .screen.availHeight - .Form.offsetHeight
						If IsEmpty(Left) Then Left = CInt((.screen.availWidth - Width) / 2)
						If IsEmpty(Top) Then Top = CInt((.screen.availHeight - Height) / 2)
						bVisible = IsEmpty(bVisible) Or bVisible
						Visible = bVisible
						.execScript "var smallWrapperThunks = (function(){" &_
							"var thunks,elements={};return {" &_
								"parseHandlers:function(h){" &_
									"thunks=h;for(var key in thunks){var p=key.toLowerCase().split('_');if(p.length==2){elements[p[0]]=elements[p[0]]||{};elements[p[0]][p[1]]=key;}}}," &_
								"forwardEvents:function(e){" &_
									"if(elements[e.id.toLowerCase()]){for(var key in e){if(key.search('on')==0){var q=elements[e.id.toLowerCase()][key.slice(2)];if(q){eval(e.id+'.'+key+'=function(){thunks.'+q+'()}')}}}}}}})()"
						If Not oswHandlers Is Nothing Then
							.smallWrapperThunks.parseHandlers oswHandlers
							.smallWrapperThunks.forwardEvents .Form
						End If
					End With
					Exit Sub
				End If
				On Error Goto 0
			Next
			WScript.Sleep 100
		Loop
	End Sub
	
	Public Property Get Handlers()
		Set Handlers = oswHandlers
	End Property
	
	Public Property Set Handlers(oHandlers)
		Dim oElement
		If Not oswHandlers Is Nothing Then Set oswHandlers.oswForm = Nothing
		Set oswHandlers = oHandlers
		Set oswHandlers.oswForm = Me
		If ChkDoc Then
			oWnd.smallWrapperThunks.parseHandlers oswHandlers
			For Each oElement In oDoc.all
				If oElement.id <> "" Then oWnd.smallWrapperThunks.forwardEvents oElement
			Next
		End If
	End Property
	
	Public Sub ForwardEvents(oElement)
		If ChkDoc Then oWnd.smallWrapperThunks.forwardEvents oElement
	End Sub
	
	Public Function AddElement(sId, sTagName)
		Set oLastCreated = oDoc.createElement(sTagName)
		If VarType(sId) <> vbError Then
			If Not(IsNull(sId) Or IsEmpty(sId)) Then oLastCreated.id = sId
		End If
		oLastCreated.style.position = "absolute"
		Set AddElement = oLastCreated
	End Function
	
	Public Function AppendTo(vNode)
		If Not IsObject(vNode) Then Set vNode = oDoc.getElementById(vNode)
		vNode.appendChild oLastCreated
		ForwardEvents oLastCreated
		Set AppendTo = oLastCreated
	End Function
	
	Public Function AddText(sText)
		oLastCreated.appendChild oDoc.createTextNode(sText)
	End Function
	
	Public Property Get Window()
		Set Window = oWnd
	End Property
	
	Public Property Get Document()
		Set Document = oDoc
	End Property
	
	Public Property Get Visible()
		Visible = bVisible
	End Property
	
	Public Property Let Visible(bWindowVisible)
		bVisible = bWindowVisible
		If ChkDoc Then
			If bVisible Then
				oWnd.moveTo Left, Top
			Else
				oWnd.moveTo -32000, -32000
			End If
		End If
	End Property
	
	Public Function ChkDoc()
		On Error Resume Next
		ChkDoc = CBool(TypeName(oDoc) = "HTMLDocument")
	End Function
	
End Class
Щт Уккщк Куыгьу Туче
’ҐЄгй п Є®¤®ў п бва Ёж : 1251