This may be useful. It's a custom msgbox made from
an HTA that will work on XP/Vista/7
http://www.jsware.net/jsware/scrfiles.php5#msgb
What you want is a slightly different version that
you can write to. The following code presents a
basic sample that writes the time to an HTA window
every 2 seconds, 4 times. You can customize it as
much as you like.
'-- begin code - watch out for wordwrap ---------------------
Dim Box, Ret, Pt1, sPar, sPath
Set Box = New Msg
Box.Init '-- initialize to deal with IE8 bug.
sPath = WScript.ScriptFullName '-- get path of this script to get icon
path.
Pt1 = InStrRev(sPath, "\")
If Pt1 > 0 Then sPar = Left(sPath, Pt1)
Box.Title = "simple sample"
Ret = Box.ShowMsg()
Dim Doc2
Set Doc2 = Box.DocObject
For i = 0 to 3
WScript.sleep 2000
Doc2.all("TBox").innerText = Doc2.all("TBox").innerText & vbCrLf & Now
Next
Set Box = Nothing
'-- ========================= Class Msg - custom message Box Class - UPDATED
11/2012 ========================
Class Msg
Private SHCls
Private BackColor, TextColor, ButtonTextColor, Q2C
Private sTitleC, sCaptionC, sIconC, IcoWidth, sFontC, sLB, sID
Private BooListC, CHR1, sListC, sDataC, ListRetC, ListDatC, ListiC, LSize
'-- list box variables.
Private BooTextBoxC, BooPasswordC, sTextC, TextColumns, sPasswordC
Private AButs(), iButs
Private Doc1
Public Property Get DocObject()
Set DocObject = Doc1
End Property
Public Sub Init() '-- This sub is a brief version of the main ShowMsg
function. It's only here to initialize.
'-- See help for explanation. This deals with a
bug in IE8. For explanation of how the code works see comments in ShowMsg
function.
Dim Cls_IE, Cls_HTA, Cls_SHAp, Cls_iCount
On Error Resume Next
sID = "ID1"
Set Cls_SHAp = CreateObject("Shell.Application")
SHCls.Run "MSHTA.EXE ""javascript:new
ActiveXObject('InternetExplorer.Application').PutProperty('" & sID & "',
window);""", 0, False
Cls_iCount = 1
Do Until Cls_iCount = 10
For Each Cls_IE In Cls_SHAp.Windows
If IsObject(Cls_IE.GetProperty(sID)) Then
Set Cls_HTA = Cls_IE.GetProperty(sID)
Cls_HTA.moveTo 2900, 2900
Exit For
End If
Next
WScript.sleep 100
Cls_iCount = Cls_iCount + 1
If IsObject(Cls_HTA) = True Then Exit Do
Loop
Set Cls_SHAp = Nothing
If IsObject(Cls_HTA) Then Cls_HTA.close
Set Cls_HTA = Nothing
Cls_IE.Quit
Set Cls_IE = Nothing
End Sub
Public Function ShowMsg()
Dim s1C, i2C, Ret, Cls_IE, Cls_HTA, Cls_SHAp, sSpc, Cls_iCount
Dim APage(8)
' On Error Resume Next
ShowMessage = -1 '--failed to work.
'-- New version that uses an HTA to work on Vista/7/8.
sID = "ID" & CStr(minute(Now)) & CStr(Second(Now))
Set Cls_SHAp = CreateObject("Shell.Application") '-- different things were
tried to prevent a full-size IE window from flashing by before msgbox
' window. Oddly, this
seems to help: Just creating Shell.App before creating the IE window.
Apparently the time
' required to initialize
Shell.App is much greater than the time required to write the IE doc and
size/position the IE window.
SHCls.Run "MSHTA.EXE ""javascript:new
ActiveXObject('InternetExplorer.Application').PutProperty('" & sID & "',
window);""", 0, False
'-- Next step: go through open windows and retrieve the window object
for just-created HTA.
Cls_iCount = 1
Do Until Cls_iCount = 10
For Each Cls_IE In Cls_SHAp.Windows
If IsObject(Cls_IE.GetProperty(sID)) Then
Set Cls_HTA = Cls_IE.GetProperty(sID)
Cls_HTA.moveTo 2900, 2900 '-- second part of method to
stop IE window flashing by. Move window offscreen before doing anything
else.
Exit For
End If
Next
WScript.sleep 100
Cls_iCount = Cls_iCount + 1
If IsObject(Cls_HTA) = True Then Exit Do
Loop
Set Cls_SHAp = Nothing '-- done with Shell.Application.
If Not IsObject(Cls_HTA) Then Exit Function
Set Doc1 = Cls_HTA.document
sSpc = "<TD>     </TD>"
APage(0) = "<HTML><HEAD><HTA:Application scroll=no contextmenu=no
border=thin minimizebutton=no maximizebutton=no sysmenu=yes></HTA>"
APage(1) = vbCrLf & "<STYLE TYPE=" & Q2C & "text/css" & Q2C & ">" &
vbCrLf
APage(2) = "BODY {padding: 4px; font-family: " & sFontC & ";
border-style: outset; border-Width: 1px;}" & vbCrLf & "LABEL {font-size:
12px; color: " & TextColor & "; background: " & BackColor & ";}" & vbCrLf
APage(3) = "#TDBut {padding: 4px 10px 4px 10px; color: " &
ButtonTextColor & "; background: " & BackColor & "; border-style: solid;
border-width: 2px; border-color: #FFFFFF #666666 #666666 #FFFFFF; font-size:
12px;}" & vbCrLf
APage(4) = "#TCap {font-size: 12px; color: " & TextColor & "; background:
" & BackColor & ";}" & vbCrLf & "#ButBox {padding-bottom: 30px;}" & vbCrLf &
"#TBox {font-size: 12px;}" & vbCrLf
APage(5) = "#PBox {font-size: 12px;}" & vbCrLf & "#IM {padding: 15px;}" &
vbCrLf & "</STYLE>" & vbCrLf & "</HEAD>" & vbCrLf
APage(6) = "<BODY BGCOLOR=" & Q2C & BackColor & Q2C & " SCROLL=" & Q2C &
"no" & Q2C & ">"
APage(7) = "<TABLE Width=100% ID=" & Q2C & "TCap" & Q2C & "><TR><TD>" &
sCaptionC & "</TD></TR></TABLE><BR>"
APage(8) = "<DIV ALIGN=" & Q2C & "center" & Q2C & "><BR><TEXTAREA
ID=" & Q2C & "TBox" & Q2C & " SIZE=50
ROWS=5></TEXTAREA></DIV><BR></BODY></HTML>"
s1C = Join(APage, "")
Cls_HTA.document.write s1C
Dim WidBox, HtBox, CapOffset
With Cls_HTA
.document.title = sTitleC
.document.all("TBox").style.fontfamily = "verdana"
.document.all("TBox").style.fontsize = 12
WidBox = .document.all("TBox").offsetWidth + 80
.document.all("TCap").Style.pixelWidth = WidBox - 40
HtBox = .document.all("TBox").offsetTop +
.document.all("TBox").offsetHeight + 40
.document.body.Style.pixelWidth = WidBox
.document.body.Style.pixelHeight = HtBox
.resizeTo WidBox + 12, HtBox + 40
.moveTo (.document.parentWindow.screen.Width - WidBox) \ 2,
(.document.parentWindow.screen.Height - HtBox) \ 2
End With
End Function
Public Property Let Title(sTitleText)
sTitleC = sTitleText
End Property
Public Sub Clear()
On Error Resume Next
Dim i2C
sTitleC = ""
sCaptionC = ""
sIconC = ""
sListC = "" '-- list of select element list box items.
sDataC = "" '-- list of hidden data.
ListRetC = "" '-- stored selection text. Clear before each call.
ListDatC = "" '-- stored selection hidden data.
ListiC = 0 '-- index of dropdown selection.
sTextC = "" '-- textbox variable.
sPasswordC = "" '-- password entered into password input.
IcoWidth = 0
LSize = 1
sFontC = "MS Sans Serif"
ReDim AButs(0)
iButs = 0
BooListC = False
BooTextBoxC = False
BooPasswordC = False
Set Doc1 = Nothing
End Sub
Private Sub Class_Initialize()
On Error Resume Next
Q2C = Chr(34)
CHR1 = chr(149)
Clear
Set SHCls = CreateObject("WScript.Shell")
BackColor = GetColor("ButtonFace") '--also use this for background
color.
If Len(BackColor) = 0 Then BackColor = "#DDDDDD"
ButtonTextColor = GetColor("ButtonText")
If Len(ButtonTextColor) = 0 Then ButtonTextColor = "#000000"
TextColor = GetColor("WindowText")
If Len(TextColor) = 0 Then TextColor = "#000000"
End Sub
Private Sub Class_Terminate()
On Error Resume Next
Set SHCls = Nothing
Set Doc1 = Nothing
End Sub
Private Function GetColor(sColName)
Dim sRegCol, sColCls, AColCls
Err.Clear
On Error Resume Next
GetColor = ""
sRegCol = "HKCU\Control Panel\Colors\" & sColName
sColCls = SHCls.RegRead(sRegCol)
If (Err.number <> 0) Then Exit Function
AColCls = Split(sColCls, " ")
If UBound(AColCls) = 2 Then
GetColor = "#" & Right(("00" & Hex(AColCls(0))), 2) & Right(("00" &
Hex(AColCls(1))), 2) & Right(("00" & Hex(AColCls(2))), 2)
End If
End Function
End Class