I am calling java code from VB script using WShell.Run. It returns a code 143. What does it mean? Where can i get the list of error codes that run method can return?
Here is the reference to System Error Codes.
ERROR_SAME_DRIVE 143 (0x8F) The system cannot join or substitute a
drive to or for a directory on the same drive.
P.S. I think that the next notes are out of the question, but just in case...
Just to note that Err object has "dummy" Description (Unknown runtime error) for most codes. If you like to get filtered list with all sensible descriptions, you can do something like this:
With CreateObject("InternetExplorer.Application")
Const DUMMY = "Unknown runtime error"
ReDim aryLines(15999)
Dim cnt, i, w, h
cnt = -1
.Navigate "about:blank"
.Document.Title = "Error Codes " & String(100, Chr(1))
.ToolBar = False
.Resizable = True
.StatusBar = False
.Width = 420
.Height = 380
With .Document.ParentWindow.Screen
w = .AvailWidth
h = .AvailHeight
End With
.Left = (w - .Width ) \ 2
.Top = (h - .Height) \ 2
Do While .Busy : WScript.Sleep 200 : Loop
On Error Resume Next
With Err
For i = 1 To 15999
.Raise i
If .Description <> DUMMY Then
cnt = cnt + 1
aryLines(cnt) = AddZero(i) & .Description
End If
.Clear
Next
End With
On Error GoTo 0
ReDim Preserve aryLines(cnt)
.Document.Body.InnerHTML = "<pre id=x>" & Join(aryLines, vbNewLine)
.Document.Body.Style.overflow = "auto"
.Document.All.X.Style.fontFamily = "Verdana, sans-serif"
.Visible = True
End With
Function AddZero(nVar)
AddZero = "<b>" & Right("00000" & nVar, 5) & "</b> "
End Function
this code returned by your java application. From MSDN
The following VBScript code does the same thing, except it specifies the window type, waits for Notepad to be shut down by the user, and saves the error code returned from Notepad when it is shut down.
Set WshShell = WScript.CreateObject("WScript.Shell")
Return = WshShell.Run("notepad " & WScript.ScriptFullName, 1, true)
Related
Ok gurus,
I am in no way a vbscript guy... and so need some serious hand-holding here!
I have a third-party program that allows custom actions via vbscript. I have this set up to open a web page as a pop-up like so (Just the piece that isn't working- code is much longer):
Set objShell = WScript.CreateObject("WScript.Shell")
Set objExplorer = CreateObject("InternetExplorer.Application")
Do
crt.Sleep 100
Loop While objExplorer.Busy
szHTMLBody = _
"<font color='red'><b>Specify tech and truck:</b></font>" & _
"<hr>" & _
"<b><u>T</u>ech:</b>" & _
"<input type="text" name='tech' size='40' maxlength='512'>" & _
"<br>" & _
"<b><u>T</u>ruck:</b>" & _
"<input type=text name='truck' size='40' maxlength='512'>" & _
"<hr>" & _
"<button name='OK' AccessKey='O'><u>O</u>K</button>" & _
" " & _
"<button name='Cancel' AccessKey='C'><u>C</u>ancel</button>"
objExplorer.ToolBar = 0
objExplorer.StatusBar = 0
objExplorer.Width = 200
objExplorer.Height = 500
objExplorer.Navigate "file://D:\test\Option.htm"
objExplorer.Document.Body.innerHTML = szHTMLBody
s = objExplorer.Document.Body.innerhtml
objExplorer.Visible = 1
objShell.AppActivate objExplorer
intMessage = Msgbox(s,4096+4, "Schedule")
This works just fine if I run the code from an elevated command prompt, changing the innerHTML. If I launch this by way of the third party app it runs ok but will not change the inner HTML. I added the 's' variable to try and catch the current innerhtml and that msgbox displays blank when run from the app but shows the correct text when run from that elevated prompt.
MORE DETAILS:
The vbs file being called resides on a server with the 3rd party app. The app itself is run from a Remote Desktop Server. The html file exists on the Remote Desktop server - and I have tried moving it to the server with the vbs file with no change.
I also tried creating a "launcher" script to run this script using Shellexecute runas; if I enter the Admin user/password it works as expected. So I then found and added a script to the "launcher" script that showed the user that launched the program. This (at least in my head) verified this permission issue.
I have no idea where to even begin with this; ideally this will be "headless" so any user can click the button calling the vbs script and it will run, modifying the html accordingly before the user sees the popup.
I have a similar popup, but I've used True and False for my objects instead of 1 and 0.
Function Main()
'Create blank Internet Explorer window
Set objIE = CreateObject("InternetExplorer.Application")
objIE.Navigate "about:blank"
'Create list that will display specific details within the window
GrpType = Left(strPA, 5)
If GrpType <> "TTTT," And GrpType <> "3AYE," And InStr(GrpType, "NO,") = 0 Then
New_Type = GrpType
MyArray = Split(strPA, ",")
GrpType = MyArray(1)
n = 20
objIE.document.body.innerHTML = "<title>TIN NOT FOUND</title><p class='msg'>TIN Not found: <span>" & _
TIN & "</span></p><p class='not'>" & GrpType & _
"</p><p class='ctrl'><input type='hidden' id='Submit' name='Submit' value='0'><input type='submit' value='OK' id='SubmitButton' onclick='document.all.Submit.value=1' autofocus></p>"
Else
strPA = Replace(strPA, GrpType, "")
MyArray = Split(strPA, ",")
End If
o = 1
z = 1
'This sets up the list data to resemble an Excel spreadsheet
If GrpType = "TTTT," Or GrpType = "3AYE," Or InStr(GrpType, "NO,") <> 0 Then
For n = 0 To UBound(MyArray)
If Disp_Type = "simple" Then
If o = 6 And n <> UBound(MyArray) Then
FormRow = MyArray(n) & "</td></tr><tr><td>" & ""
o = 0
ElseIf n = UBound(MyArray) Then
FormRow = MyArray(n) & "</td></tr><table>"
Else
If o = 1 Then
FormRow = z & "</td><td>" & ""
z = z + 1
n = n - 1
Else
FormRow = MyArray(n) & "</td><td>" & ""
End If
End If
Else
If o = 10 And n <> UBound(MyArray) Then
FormRow = MyArray(n) & "</td></tr><tr><td>" & ""
o = 0
ElseIf n = UBound(MyArray) Then
FormRow = MyArray(n) & "</td></tr><table>"
Else
If o = 1 Then
FormRow = z & "</td><td>" & ""
z = z + 1
n = n - 1
Else
FormRow = MyArray(n) & "</td><td>" & ""
End If
End If
End If
o = o + 1
List = List & FormRow
Next
End If
'Set up the window metrics
objIE.Toolbar = False
objIE.StatusBar = False
objIE.Width = 1200
objIE.Height = 1800
objIE.Top = 50
objIE.Left = 50
'Set up the innerHTML code to display the list within the window
objIE.document.body.innerHTML = "<title>GROUP TYPE " & MyArray(2) & " FOUND</title><p class='msg'>Group Type " & MyArray(2) & " Returned for TIN: <span>" & _
TIN & "</span></p><table border=0><tr><th>Seq#</th><th>Group Name</th><th>MPIN</th><th>Group Type</th><th>Group Start Date</th><th>Group Term Date</th></tr><tr><td>" & List & _
"<p class='ctrl'><input type='hidden' id='Submit' name='Submit' value='0'><input type='submit' value='OK' id='SubmitButton' onclick='document.all.Submit.value=1' autofocus></p>"
'Allow the window to be viewed at this point
objIE.Visible = True
'Do this procedure until the user has clicked the OK/Submit button
Do Until FormExit = "GO"
If objIE.document.all.Submit.Value = 1 Then
objIE.Quit
SetEverythingToNothing
Exit Function
End If
Loop
End Function
What you get is a popup like this:
This can be ran from pretty much any application. I do my debugging in Excel VBA, but I've used Macro Express Pro to run it as well as running it as a stand alone script.
Well,
turns out after much head-banging that AppActivate and Visible were competing with one another somehow. Changing the order in the vb script has solved the problem.
Hello I'm trying to debug this script that I inherited below. The error is on line 71 char 6. Object required 'oFile'
I don't have any vbs experience so please be gentle. This script takes a scan and uploads it to a doc archive server, gives it unique filename etc. I haven't figured out what 'ofile' is yet :/
'Feb 18, 2005
Dim oFSO
Set oFSO = CreateObject("Scripting.FileSystemObject")
hiddenCount = 0
'Wscript.Echo Wscript.Arguments(0)
If Wscript.Arguments.Count = 1 And oFSO.FolderExists(Wscript.Arguments(0)) Then
Set scanFiles = oFSO.GetFolder(Wscript.Arguments(0)).Files
For Each oFile In scanFiles
If oFile.Attributes and 2 Then
hiddenCount = hiddenCount + 1
End If
Next
Else
Set scanFiles = WScript.Arguments
End If
fileCount = scanFiles.Count - hiddenCount
'Wscript.Echo hiddenCount
'WScript.Echo fileCount
'WScript.Quit()
Set oIE = WScript.CreateObject("InternetExplorer.Application")
oIE.left=50 ' window position
oIE.top = 100 ' and other properties
oIE.height = 300
oIE.width = 350
oIE.menubar = 0 ' no menu
oIE.toolbar = 0
oIE.statusbar = 1
oIE.navigate "http://gisweb/apps/doc_archive/scan_login.php?file_count="&fileCount
'WScript.Echo fileCount
oIE.visible = 1
' Important: wait till MSIE is ready
Do While (oIE.Busy)
Loop
' Wait till the user clicks the OK button
' Use the CheckVal function
' Attention: Thanks to a note from M. Harris, we can make
' the script a bit more fool proof. We need to catch the case
' that the user closes the form without clicking the OK button.
On Error Resume Next
Do ' Wait till OK button is clicked
WScript.Sleep 400
Loop While (oIE.document.script.CheckVal()=0)
' If an error occur, because the form is closed, quit the
' script
If err <> 0 Then
WScript.Echo "Sorry, a run-time error occured during checking" & _
" the OK button " & vbCRLF & _
"Error: " & err.number & " " & _
"I guess the form was getting closed..."
WScript.Quit ' end script
End if
On Error Goto 0 ' switch error handling off
' User has clicked the OK button, retrieve the values
docList = oIE.Document.ValidForm.doc_id_list.Value
'MsgBox doc_id
For i = 0 To 100000
x = 1
Next
oIE.Quit() ' close Internet Explorer
Set oIE = Nothing ' reset object variable
docArray = Split(docList,",")
i = 0
For Each oFile In scanFiles
If Not oFile.Attributes And 2 Then **ERROR HERE**
ext = oFSO.GetExtensionName(oFile)
filename = "p"&right("000000"&docArray(i),6)&"."&ext
base = Int(docArray(i) / 500) * 500
subdir = "d"&right("000000"&base,6)
oFSO.CopyFile oFile, "\\ditgis02\Enterprise_GIS\doc_archive\raw\"&subdir&"\"&filename, True
i = i + 1
End If
Next
If Wscript.Arguments.Count = 1 And oFSO.FolderExists(Wscript.Arguments(0)) Then
Set WshShell = WScript.CreateObject("WScript.Shell")
intButton = WshShell.Popup (fileCount&" file(s) logged and copied! Do you want to delete temporary scan files?",0,"Done!",4)
If intButton = 6 Then
For Each oFile In scanFiles
oFile.Delete
Next
End If
Else
WScript.Echo(fileCount&" file(s) logged and copied!")
End If
WScript.Quit() ' Ready
' End
It looks the problem may arise if your initial test fails:
If Wscript.Arguments.Count = 1 And oFSO.FolderExists(Wscript.Arguments(0)) Then
...
Else
Set scanFiles = WScript.Arguments
End If
You're setting the scanFiles variable to a collection of arguments, not files. Later on, near line 71 (where your error occurs), you're treating scanFiles as if it's a Files collection and attempting to access the Attributes property of one of its File objects:
For Each oFile In scanFiles
If Not oFile.Attributes And 2 Then **ERROR HERE**
...
Next
This won't be possible since scanFiles is an Arguments collection instead. So I think you need to fix your initial Else clause to either terminate your script or provide some kind of "default" Files collection.
So I have the script below in Execl VB that goes through the rows and deletes the ones that don't contain a certain keyword.
Sub Main()
RowsDeleted = 0
Keyword = "COLA"
For i = 2 to ActiveSheet.UsedRange.Rows.Count
If InStr(Cells(i, 1).Value, Keyword) = 0 Then
Rows(i).Delete
RowsDeleted = RowsDeleted + 1
i = i - 1
End If
Next i
MsgBox("Rows Deleted: " & RowsDeleted)
End Sub
The problem is that this script takes a very long time to execute (around 8 minutes for ~73000 entries). Why is that and how would I go about improving it?
no offense to other answer, but this will only help with troubleshooting.
what you need to do is remove the the line of code
Rows(i).Delete
inside the (potentially) long running For loop is what is causing the slow down.
you need to re-write it like this...
Sub Main()
RowsDeleted = 0
Keyword = "COLA"
Dim rng As Excel.Range
Dim arr() As Variant
Dim str As String
arr = ActiveSheet.UsedRange
Dim R As Long
For R = 1 To UBound(arr, 1) ' First array dimension is rows.
If InStr(arr(R, 1), Keyword) = 0 Then
If str <> "" Then
str = "," & str
End If
str = str & arr(R, 1).Address
End If
Next R
Set rng = ActiveSheet.Range(str)
RowsDeleted = rng.Rows.Count
rng.Delete
MsgBox ("Rows Deleted: " & RowsDeleted)
End Sub
It takes ages may due to formulas in your cells that are going to be deleted.
What you should do is to turn off auto calculation and Clear the contents of that row before delete. Also you should start from bottom up!
Try this:
Sub Main()
Dim lMode As Long
' Store initial state of Calculation mode
lMode = Application.Calculation
' Change to Manual Calculation
Application.Calculation = xlCalculationManual
' Disable screen update
Application.ScreenUpdating = False
RowsDeleted = 0
Keyword = "COLA"
' Start from bottom up!
For i = ActiveSheet.UsedRange.Rows.Count To 2 Step -1
If InStr(Cells(i, 1).Value, Keyword) = 0 Then
Rows(i).ClearContents
Rows(i).Delete
RowsDeleted = RowsDeleted + 1
End If
Next i
' Restore screenupdate and calculation mode
Application.ScreenUpdating = True
Application.Calculation = lMode
MsgBox ("Rows Deleted: " & RowsDeleted)
End Sub
Here could be something to look at,
It filters Column A for cells <>"Cola" and clears them
It then sorts column A so the blank cells in column A are now at the bottom
It then deletes the blank rows.
Not knowing the setup of the OP's ws, there may have to be adjustments made.
On my sample sheet I use 81,000 rows, when I run the code it takes about 5 seconds.
Sub SomeDeleteCode()
Dim Rws As Long, Rng As Range, nwRw As Long
Rws = Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = 0
Application.Calculation = xlCalculateManual
Columns("A:A").AutoFilter Field:=1, Criteria1:="<>*Cola*"
Set Rng = Range(Cells(2, 1), Cells(Rws, 1)).SpecialCells(xlCellTypeVisible)
Rng.ClearContents
ActiveSheet.AutoFilterMode = 0
Columns(1).Sort Key1:=Range("A1"), Header:=xlYes
nwRw = Cells(Rows.Count, "A").End(xlUp).Row
Range(Range("B" & nwRw + 1), Range("B" & nwRw + 1).End(xlDown)).EntireRow.Delete
Application.Calculation = xlCalculationAutomatic
End Sub
Amend your code to look like this:
Sub Main()
On Error Goto ErrHandler
Application.ScreenUpdating = False
RowsDeleted = 0
Keyword = "COLA"
For i = ActiveSheet.UsedRange.Rows.Count to 2
If InStr(Cells(i, 1).Value, Keyword) = 0 Then
Rows(i).Delete
RowsDeleted = RowsDeleted + 1
' i = i - 1 ' -- manually changing the loop counter is a bad idea
End If
Next i
MsgBox("Rows Deleted: " & RowsDeleted)
EndSub:
Application.ScreenUpdating = True
exit sub
ErrHandler:
' Error handling here
resume EndSub
End Sub
The error handler is required to ensure that the ScreenUpdating is restored, even in case of an error.
I have two .vbs file say a.vbs and b.vbs.Now both are written for the same Excel,but would work on 2 different sheets.So can we run those in parallel?
EDIT
a.vbs will update sheet2 and b.vbs will update sheet3.But for both source sheet is sheet1.
Please advice how to set such environment
CODE A
Option Explicit
Dim objExcel1
Dim strPathExcel1
Dim objSheet1,objSheet2
Dim IntRow1,IntRow2
Dim ColStart
Set objExcel1 = CreateObject("Excel.Application")'Object for Condition Dump
strPathExcel1 = "D:\AravoVB\Copy of Original Scripts\CopyofGEWingtoWing_latest_dump_21112012.xls"
objExcel1.Workbooks.open strPathExcel1
Set objSheet1 = objExcel1.ActiveWorkbook.Worksheets(1)
Set objSheet2 = objExcel1.ActiveWorkbook.Worksheets("Bad Data")
objExcel1.ScreenUpdating = False
objExcel1.Calculation = -4135 'xlCalculationManual
IntRow2=2
IntRow1=4
Do Until IntRow1 > objSheet1.UsedRange.Rows.Count
ColStart = objExcel1.Application.WorksheetFunction.Match("Parent Business Process ID", objSheet1.Rows(3), 0) + 1
Do Until ColStart > objSheet1.UsedRange.Columns.Count And objSheet1.Cells(IntRow1,ColStart) = ""
If objSheet1.Cells(IntRow1,ColStart + 1) > objSheet1.Cells(IntRow1,ColStart + 5) And objSheet1.Cells(IntRow1,ColStart + 5) <> "" Then
objSheet1.Range(objSheet1.Cells(IntRow1,1),objSheet1.Cells(IntRow1,objSheet1.UsedRange.Columns.Count)).Copy
objSheet2.Range(objSheet2.Cells(IntRow2,1),objSheet2.Cells(IntRow2,objSheet1.UsedRange.Columns.Count)).PasteSpecial
IntRow2=IntRow2+1
Exit Do
End If
ColStart=ColStart+4
Loop
IntRow1=IntRow1+1
Loop
objExcel1.ScreenUpdating = True
objExcel1.Calculation = -4105 'xlCalculationAutomatic
CODE B
Option Explicit
Dim objExcel1
Dim strPathExcel1
Dim objSheet1,objSheet2
Dim IntRow1,IntRow2
Dim Flag
Dim IntColTemp,IntRowTemp
Dim Strcmp1,Strcmp2
Flag=0
IntColTemp=1
IntRowTemp=3
Set objExcel1 = CreateObject("Excel.Application")'Object for Condition Dump
If Err.Number <> 0 Then
On Error GoTo 0
Wscript.Echo "Excel application not found."
Wscript.Quit
End If
strPathExcel1 = "D:\VA\CopyofGEWingtoWing_latest_dump_21112012.xls"
objExcel1.Workbooks.open strPathExcel1
Set objSheet1 = objExcel1.ActiveWorkbook.Worksheets(1)
Set objSheet2 = objExcel1.ActiveWorkbook.Worksheets(2)
IntRow1=4
IntRow2=1
Do While objSheet1.Cells(IntRow1, 1).Value <> ""
objSheet2.Cells(IntRow2, 1).Value = objSheet1.Cells(IntRow1, 1).Value
IntColTemp=1
Flag=0
'This will travarse to the Parent Business Process ID column horizantally in the excel.
Do While Flag=0
If objSheet1.Cells(IntRowTemp,IntColTemp).Value="Parent Business Process ID" Then
Flag=1
End If
IntColTemp=IntColTemp+1
Loop
IntColTemp=IntColTemp-1
'MsgBox(IntColTemp)
Strcmp1=trim(objSheet1.Cells(IntRow1, 1).Value)
Strcmp2=trim(objSheet1.Cells(IntRow1,IntColTemp).Value)
If Strcmp1=Strcmp2 Then
objSheet2.Cells(IntRow2, 2).Value="Parent"
Else
objSheet2.Cells(IntRow2, 2).Value="child"
End If
IntRow1=IntRow1+1
IntRow2=IntRow2+1
Loop
Working on two different sheets should be possible by putting something like this in both of your scripts:
strPathExcel1 = "D:\CopyofGEWingtoWing_latest_dump_21112012.xls"
On Error Resume Next
Set objExcel1 = GetObject(, "Excel.Application") ' attach to running instance
If Err.Number = 429 Then ' if that fails
Err.Clear
Set objExcel1 = CreateObject("Excel.Application") ' create new instance
If Err Then ' if that still fails
WScript.Echo Err.Description & " (0x" & Hex(Err.Number) & ")"
WScript.Quit 1 ' report error and terminate
End If
objExcel1.Workbooks.Open strPathExcel1
End If
On Error Goto 0
However, I doubt that this approach would gain you enough performance to justify the additional complexity.
In CODE A replace the lines
Set objExcel1 = CreateObject("Excel.Application")'Object for Condition Dump
strPathExcel1 = "D:\AravoVB\Copy of Original Scripts\CopyofGEWingtoWing_latest_dump_21112012.xls"
objExcel1.Workbooks.open strPathExcel1
with the above code block.
In CODE B replace the lines
Set objExcel1 = CreateObject("Excel.Application")'Object for Condition Dump
If Err.Number <> 0 Then
On Error GoTo 0
Wscript.Echo "Excel application not found."
Wscript.Quit
End If
strPathExcel1 = "D:\VA\CopyofGEWingtoWing_latest_dump_21112012.xls"
objExcel1.Workbooks.open strPathExcel1
with the above code block.
I have a third party application that invokes a vsbscript file for certain operations. I would like to put up a user prompt with a choice of options, either a drop down list or checkbox or some such. However, all I can find is the input box option.
I don't think HTAs are an option in my case (unless there is a way to call them from a .vbs file?)
My other thought was some sort of ActiveX control, but I can't locate a built-in one that would be available by default on WindowsXP/Vista.
Anybody have any ideas on how I could accomplish this?
The simple answer is, you really can't. Tmdean's solution is the only way I can think of either. That said, you can spruce up the input box so it doesn't look horrible. Give this a run, I don't think it's an epic fail:
Dim bullet
Dim response
bullet = Chr(10) & " " & Chr(149) & " "
Do
response = InputBox("Please enter the number that corresponds to your selection:" & Chr(10) & bullet & "1.) Apple" & bullet & "2.) Bannana" & bullet & "3.) Pear" & Chr(10), "Select Thing")
If response = "" Then WScript.Quit 'Detect Cancel
If IsNumeric(response) Then Exit Do 'Detect value response.
MsgBox "You must enter a numeric value.", 48, "Invalid Entry"
Loop
MsgBox "The user chose :" & response, 64, "Yay!"
If you would like to use an hta for this it can be done like this.
The VBScript:
Set WshShell = CreateObject("WScript.Shell")
'Run the hta.
WshShell.Run "Test.hta", 1, true
'Display the results.
MsgBox "Return Value = " & getReturn
Set WshShell = Nothing
Function getReturn
'Read the registry entry created by the hta.
On Error Resume Next
Set WshShell = CreateObject("WScript.Shell")
getReturn = WshShell.RegRead("HKEY_CURRENT_USER\Volatile Environment\MsgResp")
If ERR.Number 0 Then
'If the value does not exist return -1
getReturn = -1
Else
'Otherwise return the value in the registry & delete the temperary entry.
WshShell.RegDelete "HKEY_CURRENT_USER\Volatile Environment\MsgResp"
End if
Set WshShell = Nothing
End Function
Then design the hta as desired, and include the following methods
'Call this when the OK button is clicked.
Sub OK_Click
For Each objradiobutton In Opt
If objradiobutton.Checked Then
WriteResponse objradiobutton.Value
End If
Next
window.Close
End Sub
'Call this when the Cancel button is clicked.
Sub Cancel_Click
WriteResponse("CANCEL")
window.Close
End Sub
'Write the response to the registry
Sub WriteResponse(strValue)
Set WshShell = CreateObject("WScript.Shell")
WshShell.RegWrite "HKEY_CURRENT_USER\Volatile Environment\MsgResp", strValue
Set WshShell = Nothing
End Sub
I used a group of radio buttons named "Opt" to make a choice, but you could use any controls you would like.
Because hta's cannot return values, this will create a temperary registry entry. If you are not comforatable messing with the registry, you could also write the result to a temperary text file.
This approach is nice because you can design the hta any way you like, rather than using the supplied inputbox and choosing numbers (thats so DOS).
This could also be nice if you expanded the hta to create itself based on arguments passed to it, like passing in a title, a message to display, an array of options, a set of buttons. That way you could use the same hta any time you needed to get input from the user.
You can use DialogLib to create forms with dropdowns and checkboxes. DialogLib is still in it's ealy stages, but is's allready quite usefull: http://www.soren.schimkat.dk/Blog/?p=189
Try WshShell.Popup. Depending upon your data that may work for you...
Otherwise you could investigate PowerShell.
One option is to script Internet Explorer. You can use VBScript to launch IE and load a local HTML file, and attach a VBScript sub to a form's submit button (or any other JavaScript events), which can then close the IE window as part of its execution.
You can launch an HTA from a VBScript.
Set shell = CreateObject("WScript.Shell")
shell.Run "Test.hta"
EDIT
Since you have full control of the VBScript, could you make the 3rd party VBScript simply call your HTA? You could put the UI and whatever processing code inside of the HTA.
As an example of #TmDean's suggestion, there's this class that I sometimes use which scripts IE (well, it scripted IE6; I haven't tried the more recent incarnations.)
class IEDisplay
'~ Based on original work by Tony Hinkle, tonyhinkle#yahoo.com
private TEMPORARY_FOLDER
private objShell
private objIE
private objFSO
private objFolder
private strName
private streamOut
private objDIV
private numHeight
private numWidth
private numTop
private numLeft
private sub Class_Initialize()
Dim strComputer
Dim objWMIService
Dim colItems
Dim objItem
Dim arrMonitors( 10, 1 )
Dim numMonitorCount
Set objShell = WScript.CreateObject("WScript.Shell")
Set objIE = CreateObject("InternetExplorer.Application")
strComputer = "."
Set objWMIService = GetObject( "winmgmts:\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService.ExecQuery( "Select * from Win32_DesktopMonitor")
numMonitorCount = 0
For Each objItem in colItems
arrMonitors( numMonitorCount, 0 ) = objItem.ScreenHeight
arrMonitors( numMonitorCount, 1 ) = objItem.ScreenWidth
numMonitorCount = numMonitorCount + 1
Next
numHeight = arrMonitors( 0, 0 )
numWidth = arrMonitors( 0, 1 )
Set objFSO = CreateObject("Scripting.FileSystemObject")
TEMPORARY_FOLDER = 2
set objFolder = objFSO.GetSpecialFolder( TEMPORARY_FOLDER )
strName = objFSO.BuildPath( objFolder, objFSO.GetTempName ) & ".html"
WriteFileU strName, Join( Array( "<HTML><HEAD><TITLE>Information</TITLE></HEAD>", _
"<BODY SCROLL='NO'><CENTER><FONT FACE='arial black'> <HR COLOR='BLACK'>", _
"<DIV id='MakeMeAnObject'></DIV>", _
"<HR COLOR='BLACK'></FONT></CENTER></BODY></HTML>" ), vbCRLF ), WF_CREATE
numTop = 0
numLeft = 0
end sub
Sub Init( strPosition )
'NW, N, NE, W, CENTRE, E, SW, S, SE
Select Case strPosition
Case "NW"
numTop = 0
numLeft = 0
Case "N"
numTop = 0
numLeft = ( numWidth / 2 ) - 250
Case "NE"
numTop = 0
numLeft = numWidth - 500
Case "W"
numTop = ( numHeight / 2 ) - 55
numLeft = 0
Case "CENTRE"
numTop = ( numHeight / 2 ) - 55
numLeft = ( numWidth / 2 ) - 250
Case "E"
numTop = ( numHeight / 2 ) - 55
numLeft = numWidth - 500
Case "SW"
numTop = numHeight - 110
numLeft = 0
Case "S"
numTop = numHeight - 110
numLeft = ( numWidth / 2 ) - 250
Case "SE"
numTop = numHeight - 110
numLeft = numWidth - 500
Case Else
numTop = 0
numLeft = 0
End Select
SetupIE( strName )
Set objDIV = objIE.Document.All("MakeMeAnObject")
end sub
private sub Class_Terminate()
'Close IE and delete the file
objIE.Quit
'~ optionally you may want to get rid of the temp file
end sub
public sub Display( strMsg, numMillisec )
objDIV.InnerHTML = strMsg
WScript.Sleep numMillisec
end sub
Private Sub SetupIE(File2Load)
objIE.Navigate File2Load
objIE.ToolBar = False
objIE.StatusBar = False
objIE.Resizable = False
Do
Loop While objIE.Busy
objIE.Width = 500
objIE.Height = 110
objIE.Left = numLeft
objIE.Top = numTop
objIE.Visible = True
objShell.AppActivate("Microsoft Internet Explorer")
End Sub
end class
here is the missing (from the original posting) WriteFileU function
Const WF_APPEND = 1
Const WF_CREATE = 2
Const WF_FOR_APPENDING = 8
Const WF_FOR_WRITING = 2
Const WF_CREATE_NONEXISTING = True
Const CONST_READ = 1, CONST_WRITE = 2, CONST_APPEND = 8
Const AS_SYSTEMDEFAULT = -2, AS_UNICODE = -1, AS_ASCII = 0
Sub WriteFileU( sFilename, sContents, nMode )
Dim oStream
If nMode = WF_APPEND Then
Set oStream = oFSO.OpenTextFile( sFilename, WF_FOR_APPENDING, WF_CREATE_NONEXISTING, AS_UNICODE )
ElseIf nMode = WF_CREATE Then
Set oStream = oFSO.OpenTextFile( sFilename, WF_FOR_WRITING, WF_CREATE_NONEXISTING, AS_UNICODE )
Else
STOP
End If
oStream.Write sContents
oStream.Close
Set oStream = Nothing
End Sub
and then as an example of it's use
set i = new IEDisplay
a = array("NW", "N", "NE", "W", "CENTRE", "E", "SW","S","SE")
for each aa in a
i.init aa
i.display "Here in " & aa & " of screen", 1000
next
Now that's not immediately useful (especially are there are a pile of calls to my own utility routines in there) but it gives a framework. By modifying what HTML is stored, you could add support for listboxes etc.
I know this is eleven years too late, but it sounds like this would be more along the lines of what the original request would be looking for:
Sub CustomMsgBox(msg)
Dim ie, Style, FormExit
Set ie = CreateObject("InternetExplorer.Application")
ie.Navigate "about:blank"
While ie.ReadyState <> 4: WScript.Sleep 100: Wend
ie.Toolbar = False
ie.StatusBar = False
ie.Width = 450
ie.Height = 275
ie.document.body.innerHTML = "<title>Choose a Color</title><p class='msg'>Choose an option:</p>" & "<input type='radio' id='myRadio' name='colors' value='red'>Red</br><input type='radio' id='myRadio' name='colors' value='yellow'>Yellow</br><input type='radio' id='myRadio' name='colors' value='blue'>Blue"
Set Style = ie.document.CreateStyleSheet
Style.AddRule "p.msg", "font-family:calibri;font-weight:bold;"
ie.Visible = True
ie.Quit
End Sub
This code worked for me in an HTA file (that I opened from VBS using WScript.Shell Run). The trick was to get the data back to VBS which I accomplished by having HTA create an XML file that VBS read.
Sub CopySelect(sSrcId, sTargetId)
Dim oTarget: Set oTarget = document.getElementById(sTargetId)
Dim oSrc: Set oSrc = document.getElementById(sSrcId)
Dim j, n, o
oTarget.length = 0
For j = 0 to oSrc.length - 1
Set o = oSrc.options(j)
Set n = document.createElement("option")
n.text = o.text
n.value = o.value
oTarget.add n
Next
End Sub