In several of my .HTA scripts that I created, I had the need for the VBScript WScript.Sleep command which simply waits for a number of milliseconds without utilizing the CPU.
And when I browse the web, it appears that I am not the only one looking for this:
https://www.google.nl/search?q=hta+sleep
(I bet that if you read this, you probably need(ed) this as well)
The best solution that I could find appears to be the one which uses the PING command.
But especially for a situation were just need to pause the script for a few 100ms, this solution is quiet odd as it uses an external command and triggers all kind of (network) processes that unlikely have anything to do with the concerned .HTA script.
So the first thing that came to my mind was to use the WMI Win32_PingStatus class to avoid the external command but then I started to question why not completely basing it on WMI.
It has taken me several hours to get the right WMI classes and methods in place, but finally I succeeded…
When writing HTA's you should be thinking asynchronously. Consider rewriting your code to use window.setTimeout. In the following example, I will use window.setTimeout to make a bell sound every 2 seconds:
<!DOCTYPE html>
<html>
<head>
<meta http-equiv="x-ua-compatible" content="ie=8">
<title>Bell Test</title>
<script language="VBScript">
Option Explicit
Dim objWShell
Set objWShell = CreateObject("WScript.Shell")
Sub DoPing
divText.innerText = Now
objWShell.Run "%COMSPEC% /c ECHO " & Chr(7), 0, False
window.setTimeOut "DoPing", 2000
End Sub
Sub window_OnLoad
window.ResizeTo 240,130
DoPing
End Sub
</script>
</head>
<body>
<div id="divText">TEST</div>
</body>
</html>
I had the same problem with HTA.
My solution with vbs ...
Sub sleep (Timesec)
Set objwsh = CreateObject("WScript.Shell")
objwsh.Run "Timeout /T " & Timesec & " /nobreak" ,0 ,true
Set objwsh = Nothing
End Sub
' example wait for 3 seconds
sleep 3
The routine will call a shell command, minimized and without a keyboard command.
Only ^C is permitted, but this will no user given in these situation.
Sub Sleep(iMilliSeconds)
With GetObject("winmgmts:\\.\root\cimv2")
With .Get("__IntervalTimerInstruction").SpawnInstance_()
.TimerId = "Sleep"
.IntervalBetweenEvents = iMilliSeconds
.Put_()
End With
.ExecNotificationQuery("SELECT * FROM __TimerEvent WHERE TimerId='Sleep'").NextEvent
End With
End Sub
Added 2015-02-11:
Unfortunately, this function doesn’t work when using Internet Explorer 10 (see comments below).
With Internet Explorer 11 installed, it appears to work if you run the HTA as administrator.
Wait(2000) 'pauses 2 seconds
Sub Wait(Time)
Dim wmiQuery, objWMIService, objPing, objStatus
wmiQuery = "Select * From Win32_PingStatus Where Address = '1.1.1.1' AND Timeout = " & Time
Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
Set objPing = objWMIService.ExecQuery(wmiQuery)
For Each objStatus in objPing
Next
End Sub
Sub Sleep (ms)
Set fso = CreateObject("Scripting.FileSystemObject")
Dim sFilePath: sFilePath = fso.GetSpecialFolder(2) & "\WScriptSleeper.vbs"
If Not fso.FileExists(sFilePath) Then
Set oFile = fso.CreateTextFile(sFilePath, True)
oFile.Write "wscript.sleep WScript.Arguments(0)"
oFile.Close
End If
Dim oShell: Set oShell = CreateObject("WScript.Shell")
oShell.Run sFilePath & " " & ms, 1, True
End Sub
Related
When terminating internet explorer within VBA I'm using the following code sourced (more or less) from stackoverflow:
Sub IE_Sledgehammer()
Dim objWMI As Object, objProcess As Object, objProcesses As Object
Set objWMI = GetObject("winmgmts://.")
Set objProcesses = objWMI.ExecQuery( _
"SELECT * FROM Win32_Process WHERE Name = 'iexplore.exe'")
MsgBox "iexplore.exe processes = " & objProcesses.Count
For Each objProcess In objProcesses
Call objProcess.Terminate
Next
Set objProcesses = Nothing: Set objWMI = Nothing
End sub
The number of processes returned is "2" (which is correct) but in the first iteration of the For loop, when the first iexplore.exe is terminated that also terminates the second process and so in the second loop iteration a 'not found' error occurs. I understand that this is because closing one iexplorer.exe process closes all iexplore.exe tasks.
My question is, how can I reference and terminate only the first 'objprocess' in the objprocesses list OR force the For loop to exit after one iteration?
Do you mean you want to close the first tab or IE window?
I suggest you create an object of Shell and loop through IE windows.
You can close the first IE window and exit the loop or you can match the title of the IE window and close that specific IE window.
You need to add the reference to Microsoft Shell Controls and Automation and Microsoft Internet Controls.
Code:
Sub demo()
Dim oShellWin As Shell
Dim oWin As Object
Dim objIE As InternetExplorer
Set oShellWin = New Shell
For Each objIE In oShellWin.Windows
If TypeName(objIE.Document) = "HTMLDocument" Then
'Debug.Print objIE.Document.Title
If objIE.Document.Title = "Bing" Then 'User can modify the title here...
objIE.Quit
Exit For
End If
End If
Next objIE
End Sub
Output:
Further, you can try to modify the code as per your requirement.
There are many articles dealing with finding the existing IE sessions and then working with them. For some reason, they don't work for me.
I have the following code which creates IE 11 sessions. Sometimes, I manually terminated the VBA code. That left the IE session as an orphan.
Set IE = GetObject("InternetExplorer.Application")
If IE Is Nothing Then Set IE = CreateObject("INTERNETEXPLORER.APPLICATION")
With IE
.Visible = True
.Navigate URL
I have found many articles with all sorts of code to find the existing IE sessions but they don't work for me. The following code is an example.
Sub test_is()
Dim IE As SHDocVw.InternetExplorer
On Error Resume Next
Set IE = GetObject(, "InternetExplorer.Application")
Debug.Print Err.Description
On Error GoTo 0
If IE Is Nothing Then
Set IE = CreateObject("InternetExplorer.Application")
If IE Is Nothing Then
Debug.Print "error getting IE"
Else
IE.Quit
End If
End If
End Sub
When it got to "Set IE = GetObject(, "InternetExplorer.Application")", Debug.Print reported that "ActiveX component can't create object
".
As the code went on, an IE session was created and then quit. That's the only IE session quit. The other IE sessions which had been created by other code stayed intact. I have tried at least six codes I found on the NET. They work for some people but never work for me.
The following is another example:
Sub Find_IE_Windows()
Dim Shell As Object
Dim IE As Object
Set Shell = CreateObject("Shell.Application")
For Each IE In Shell.Windows
If TypeName(IE.Document) = "HTMLDocument" Then
MsgBox "Internet Explorer window found:" & vbCrLf & _
"LocationURL=" & IE.LocationURL & vbCrLf & _
"LocationName=" & IE.LocationName
IE.Quit
End If
Next
End Sub
In my case, the Shell.Windows.Count was zero. So, the code went from the For loop directly to End Sub.
In other cases, Shell.Windows.Count were 2 when I had excel, IE 11 and MS Edge running. And those two shell windows were File Explorer sessions, not Excel, not Edge, not IE 11.
I have Microsoft Internet Controls, Microsoft HTML Object Library, Microsoft Shell Control and Automation all checked. Am I missing some other library?
The only code that works is this one but it stops MS Edge from getting online. So, can't use it.
Sub IE_Sledgehammer()
Dim objWMI As Object, objProcess As Object, objProcesses As Object
Set objWMI = GetObject("winmgmts://.")
Set objProcesses = objWMI.ExecQuery( _
"SELECT * FROM Win32_Process WHERE Name = 'iexplore.exe'")
For Each objProcess In objProcesses
Call objProcess.Terminate
Next
Set objProcesses = Nothing: Set objWMI = Nothing
End Sub
I'm running Windows 10 Pro and Excel 2010.
We have been trying to resolve this issue for almost a week now without an answer.
Issue: While creating zip file, an error is thrown saying "The method Namespace failed on IShellDispatch6."
What we have tried so far?
Our code is based on instructions at https://www.rondebruin.nl/win/s7/win001.htm. It works on our development environments but explicitly fails on few of client's machine.
Our code:
Code (vb):
Option Explicit
Public zipfile As Variant ' Care taken that this must be a variant
Private baseDirectory As Variant ' Care taken that this must be a variant
Private FileName As String ' This needn't be a variant - tried and tested.
Private done As Boolean
#If VBA7 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwmilliseconds As Long)
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal dwmilliseconds As Long)
#End If
' Optional folderNumber taken to try create 10 zip files in a loop.
' Read somewhere that shell activities spawn into separate threads.
' A loop can expose any such vulneribility
Public Sub zip(Optional folderNumber As Integer = 0)
Dim oApp
Dim dFolder
Sleep 100
baseDirectory = "C:\Users\Siddhant\AppData\Local\Temp\b w\"
zipfile = "" & baseDirectory & "stestzip" & CStr(folderNumber) & ".zip"
FileName = "" & baseDirectory & "stestzip.txt"
'Set dFolder = CreateObject("WScript.Shell")
Set oApp = CreateObject("Shell.Application")
Debug.Print "Starting zip process at " & CStr(VBA.Timer) & ". First creating zip file."
' Note the round brackets below around zipfile - These evaluate zipfile at run-time.
' These are not for parameter passing but to force evaluation.
NewZip (zipfile)
Debug.Print "Zip created at " & CStr(VBA.Timer)
'On Error GoTo here
' On development machine, following works fine.
' On client machine, call to oApp.Namespace(zipfile) fails
' giving error message described at beginning of this post..
Debug.Print "Critical Error----------------" & CStr(oApp.Namespace(zipfile) Is Nothing)
Dim loopChecker As Integer
loopChecker = 1
' On client machine, code doesn't even reach here.
While oApp.Namespace(zipfile) Is Nothing
' Well this loop simply waits 3 seconds
' in case the spawned thread couldn't create zipfile in time.
Debug.Print "Waiting till zip gets created."
Sleep 100
If loopChecker = 30 Then
Debug.Print "Wated 3 seconds for zip to get created. Can't wait any longer."
GoTo afterloop
End If
loopChecker = loopChecker + 1
Wend
afterloop:
Debug.Print "Now Condition is ---------------" & CStr(oApp.Namespace(zipfile) Is Nothing)
If oApp.Namespace(zipfile) Is Nothing Then
Debug.Print "Couldnot create zip file " & zipfile
Exit Sub
End If
Set dFolder = oApp.Namespace(zipfile)
'MsgBox FileName
Sleep 200
dFolder.CopyHere "" & FileName, 4
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until dFolder.Items.Count = 1
done = False
'Application.Wait (Now + TimeValue("0:00:01"))
Sleep 100 'wait for 1/10 th of second
Loop
done = True
On Error GoTo 0
here:
If Not dFolder Is Nothing Then
Set dFolder = Nothing
End If
If Not oApp Is Nothing Then
Set oApp = Nothing
End If
End Sub
Public Function Success() As Boolean
Success = done
End Function
Public Sub ClearFileSpecs()
FileName = ""
End Sub
Public Sub AddFileSpec(FileLocation As String)
FileName = FileLocation
End Sub
Sub NewZip(sPath)
'Create empty Zip File
If Len(Dir(sPath)) > 0 Then Kill sPath
Debug.Print "Creating zip file"
Open sPath For Output As #1
Debug.Print "Zip file created, writing zip header"
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Debug.Print "zip header written, closing file."
Close #1
Debug.Print "Closing zip file."
End Sub
Function Split97(sStr As Variant, sdelim As String) As Variant
Split97 = Evaluate("{""" & _
Application.Substitute(sStr, sdelim, """,""") & """}")
End Function
Sub testZipping()
Dim i As Integer
For i = 1 To 10
zip i
Next i
MsgBox "Done"
End Sub
Sub tryWait()
Dim i As Integer
For i = 1 To 10
Sleep 2000
Next i
End Sub
By the way, we have also tried another solution to call oApp.Namespace((zipfile)) forcing evaluation of zipfile variable. Many forums described another issue where literal strings worked with oApp.Namespace("c:\an\example"). In such forums solution to use 2 round brackets was suggested.
But neither keeping "DIM zipfile As Variant" worked nor "oApp.Namespace((zipfile))" work.
Could it be the case that the shell32.dll is damaged on client's machine? Please help! I would be quite thankful for any help offered!
I've also posted this issue at http://forum.chandoo.org/threads/create-zip-error-namespace-method-fails-on-ishelldispatch.34010/
We were finally able to get this through. When it came down to Namespace() method failing on IShellDispatch instance, OS installation had to be repaired which fixed the issue. Further, we later discovered that relying on Windows Shell based zipping isn't reliable enough as the copyhere() method doesn't return any status of completion. Additionally, it is asynchronous which mandates hacks like putting a loop after copyhere() call. This loop would sleep few milliseconds and compare source and target folders' items. This hack causes a possible conflict in actual copyhere operation and the comparison query. We have finally moved on to implementing ZLib based DLL that can help us with our compression and decompression requirements.
Right now I have this VBA script:
Sub executeFTPBatch(ftpfileName)
Call Shell("FTP -i -s:C:\Temp\" & ftpfileName & ".txt")
On Error Resume Next
Kill (C:\temp\" & ftpfileName & ".txt")
End Sub
The problem is that it kills the text file before the FTP script has even begun. I saw some wsh codes, but I wasn't sure of the syntax on how to use it with respect to calling the shell FTP. If you can help me with the correct syntax I would really appreciate it!
Use WScript's Shell instead, then you can check the status of the command
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Function RunCMD(ByVal strCMD As String) As String
'Runs the provided command
Dim wsh As New wshShell
Dim cmd As WshExec
Dim x As Integer
On Error GoTo wshError
x = 0
RunCMD = "Error"
Set cmd = wsh.Exec(strCMD)
Do While cmd.Status = WshRunning
Sleep 100 'for 1/10th of a second
x = x + 1
If x > 1200 Then 'We've waited 2 minutes so kill it
cmd.Terminate
MsgBox "Error: Timed Out", vbCritical, "Timed Out"
End If
Loop
RunCMD = cmd.StdOut.ReadAll & cmd.StdErr.ReadAll
Exit Function
wshError:
RunCMD = cmd.StdErr.ReadAll
End Function
This is a function I use, and it will return the status of the command including any errors.
(Almost forgot the Sleep declaration!)
(Edit 2: You will also want to include a reference to the Windows Script Host Object Model (wshom.ocx) so you can use the Intellisense features)
I prefered omegastripe's suggest:
Public Sub RunCMD(ByVal strCMD As String)
'Runs the provided command
Dim wsh As Object
Set wsh = CreateObject("WScript.Shell")
Call wsh.Run(strCMD, 2, True)
End Sub
With 2 as second param to avoid windows to popup
If I use
Set ie = CreateObject("InternetExplorer.Application")
To open a URL I can use the following
ie.Navigate "http://google.com"
But I cant go for this option because, "InternetExplorer.Application" opens 64-bit IE browser. I need 32-bit IE browser to work. So I used the following
set Objshell=CreateObject("WScript.shell")
return=Objshell.run ("""C:\Program Files\Internet Explorer\iexplore.exe""" & "www.google.com")
So in this case I don't know how to navigate or to use getElements() for that opened browser window.
Please let me know how to handle this!
Option Explicit
Main()
Sub Main()
Force32bit()
Dim objExplorer : Set objExplorer = CreateObject("InternetExplorer.Application")
Dim i
i = true
do while i = true
objExplorer.Navigate "www.google.com"
objExplorer.ToolBar = 1
objExplorer.StatusBar = 1
objExplorer.Width = 800
objExplorer.Height = 800
objExplorer.Left = 1
objExplorer.Top = 1
objExplorer.Visible = 1
WScript.Sleep 6000
objExplorer.Navigate "www.yahoo.com"
wscript.sleep 6000
loop
End Sub
Sub Force32bit()
If InStr(UCase(WScript.FullName), "SYSTEM32") > 0 and CreateObject("Scripting.FileSystemObject").FolderExists("C:\Windows\SysWOW64") Then
Dim objShell : Set objShell = CreateObject("WScript.Shell")
objShell.CurrentDirectory = "C:\Windows\SysWOW64"
objShell.Run "wscript.exe " & Chr(34) & WScript.ScriptFullName & Chr(34), 1, False
End If
End Sub
Find the solution here
Dim Shell
Set Shell = CreateObject("WScript.Shell")
Shell.Run "iexplore.exe www.google.com"
If you go back to your original code and simply modify the instantiation line to the following:
Set ie = CreateObject("InternetExplorer.Application.1")
That should be enough to force a 32-bit instance of the IE application object.
If you still want to go with the shell route, remember that you want to launch the iEXPLORE.EXE from the Programs (x86) folder.
"C:\Program Files (x86)\Internet Explorer\iexplore.exe"