WSH VBS 的某种 GUI 可以通过动态创建的 HTA 窗口来实现。下面的代码包括两个包装类,它们有助于 HTA 窗口创建和元素事件处理,并演示如何在表单上放置列表框和按钮并获取所选项目:
Option Explicit
' Base64-encoded background image
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
' Array containing items for ListBox
aItems = Array("Item A", "Item B", "Item C", "Item D", "Item E")
' Create HTA window wrapper
With New clsSmallWrapperForm
' Setup window
.ShowInTaskbar = "yes"
.Title = "Test HTA UserForm"
.BackgroundImage = BGI
.Width = 354
.Height = 118
.Visible = False
' Create window
.Create
' Assign handlers
Set .Handlers = New clsSmallWrapperHandlers
' Add ListBox
With .AddElement("ListBox1", "SELECT")
.size = 6
.multiple = True
.style.left = "15px"
.style.top = "10px"
.style.width = "250px"
End With
.AppendTo "Form"
' Add ListBox items
For i = 0 To UBound(aItems)
.AddElement , "OPTION"
.AddText aItems(i)
.AppendTo "ListBox1"
Next
' Add OK Button
With .AddElement("Button1", "INPUT")
.type = "button"
.value = "OK"
.style.left = "285px"
.style.top = "10px"
.style.width = "50px"
.style.height = "20px"
End With
.AppendTo "Form"
' Add Cancel Button
With .AddElement("Button2", "INPUT")
.type = "button"
.value = "Cancel"
.style.left = "285px"
.style.top = "40px"
.style.width = "50px"
.style.height = "20px"
End With
.AppendTo "Form"
' Add Label
With .AddElement("Label1", "SPAN")
.style.left = "15px"
.style.top = "98px"
.style.width = "350px"
End With
.AddText "Choose items"
.AppendTo "Form"
' Show window
.Visible = True
' Wait window closing or user choise
Do While .ChkDoc And Not .Handlers.Selected
WScript.Sleep 100
Loop
' Read results from array .Handlers.SelectedItems
If .Handlers.Selected Then
MsgBox "Selected " & (UBound(.Handlers.SelectedItems) + 1) & " Item(s)" & vbCrLf & Join(.Handlers.SelectedItems, vbCrLf)
Else
MsgBox "Window closed"
End If
' The rest part of code ...
End With
Class clsSmallWrapperHandlers
' Handlers class implements events processing
' Edit code to provide the necessary behavior
' Keep conventional VB handlers names: Public Sub <ElementID>_<EventName>()
Public oswForm ' mandatory property
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) & " selected"
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 = "Choose at least 1 item"
End If
End Sub
Public Sub Button2_Click()
oswForm.Window.close
End Sub
End Class
Class clsSmallWrapperForm
' Utility class for HTA window functionality
' Do not modify
' HTA tag properties
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
' Form properties
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()
' source http://forum.script-coding.com/viewtopic.php?pid=75356#p75356
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
事实上,这只是一个草案,一些操作(例如泛型类型元素创建)可以通过添加具有此类功能的包装器和方法来简化clsSmallWrapperForm
.