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.

Щт Уккщк Куыгьу Туче

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
Щт Уккщк Куыгьу Туче