VBA Code to Read the Active Program - vba

My hope is to have this macro continually record the name of whatever program is the current active program. I have a user form that runs a timer user a Macro that recalls itself every second. I would like it to record the name of the active window in that same macro and (if different from the last name) append that on to a descriptive string.
I had originally used the "Active window.caption" only to learn that it doesn't apply to other programs (such as chrome, word, or Outlook), But below is a chunk of my code.
If ActiveApp <> ActiveWindow.Caption Then 'look at active program for name
ActiveApp = ActiveWindow.Caption 'if the last name is not the same as the current
aapp2 = ThisWorkbook.Sheets("bts").Range("b13").Value & "|" & ActiveApp & ": " & Format(dteElapsed, "hh:mm:ss")
'updates the descriptive string
ThisWorkbook.Sheets("bts").Range("b13").Value = aapp2
End If
Whole Macro:
Sub timeloop()
If ThisWorkbook.Sheets("BTS").Range("b7").Value = "" Then 'the location on theworksheet that time is stored
ThisWorkbook.Sheets("BTS").Range("b7").Value = Time '
ThisWorkbook.Sheets("BTS").Range("b12").Value = Date
End If
dteStart = ThisWorkbook.Sheets("BTS").Range("b7").Value
dteFinish = Time
DoEvents
dteElapsed = dteFinish - dteStart
If Not booldead = True Then 'See if form has died
TimeRun.Label1 = Format(dteElapsed, "hh:mm:ss")
If ActiveApp <> ActiveWindow.Caption Then 'look at active program for name
ActiveApp = ActiveWindow.Caption 'if the last name is not the same as the current
aapp2 = ThisWorkbook.Sheets("bts").Range("b13").Value & "|" & ActiveApp & ": " & Format(dteElapsed, "hh:mm:ss")
'updates the descriptive string
ThisWorkbook.Sheets("bts").Range("b13").Value = aapp2
End If
Else
Exit Sub
End If
Alerttime = Now + TimeValue("00:00:01")
Application.OnTime Alerttime, "TimeLoop"
End Sub

To get the Name of the active application/window, you'll need to use API calls.
This Question on the office site should help you.
Public Declare Function GetForegroundWindow Lib "user32" _
Alias "GetForegroundWindow" () As Long
Public Declare Function GetWindowText Lib "user32" _
Alias "GetWindowTextA" (ByVal hwnd As Long, _
ByVal lpString As String, ByVal cch As Long) As Long
Sub AAA()
Dim WinText As String
Dim HWnd As Long
Dim L As Long
HWnd = GetForegroundWindow()
WinText = String(255, vbNullChar)
L = GetWindowText(HWnd, WinText, 255)
WinText = Left(WinText, InStr(1, WinText, vbNullChar) - 1)
Debug.Print L, WinText
End Sub
Running the AAA sub should print the title of the active window to the debug console.

Related

excel vba to Print a Document opened in IE browser

I would like to Print a document which is downloaded from a webpage, document has been opened in a IE browser( inspect element option not present)using send keys i can print it, but if the file size is more while printing it shows as Printing is in progress.
Application.Wait
will not help me to determine the wait time, please suggest is there is a any way to pause the execution of macro until printing progress is completed?
Function used to print:
Function Sample(tet As Variant)
Dim IE_Tab As SHDocVw.InternetExplorer, ie As InternetExplorer
Dim HTML_Doc As MSHTML.HTMLDocument
Dim SH_Win As SHDocVw.ShellWindows, sh As Object
Dim T_Str As String
Set SH_Win = New SHDocVw.ShellWindows
For Each IE_Tab In SH_Win
T_Str = IE_Tab.LocationURL
If T_Str = tet Then
Application.Wait (Now + TimeValue("00:00:05"))
Set sh = CreateObject("WScript.Shell")
'this command just populates the print dialog box, it worked fine only if i print an web page here iam trying to print a document opened as IE
IE_Tab.ExecWB OLECMDID_PRINT, OLECMDEXECOPT_DODEFAULT, 2, 0
sh.AppActivate "Print"
Application.Wait (Now + TimeValue("00:00:02"))
sh.SendKeys "c", 1
Application.Wait (Now + TimeValue("00:00:02"))
sh.SendKeys ("{ENTER}")
IE_Tab.Quit
Exit For
End If
Next
End Function
Print window:
Progress Window:
Thank You
With a the help of some Windows functions, you can use a loop to "wait" until your "Progress" window is closed.
The API functions must be placed at the top of a module (or better yet, keep it tidy by putting this in it's own module.)
Option Explicit
Private Declare Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowText Lib "User32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindowTextLength Lib "User32" Alias "GetWindowTextLengthA" (ByVal hWnd As Long) As Long
Private Declare Function GetWindow Lib "User32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long
Private Declare Function IsWindowVisible Lib "User32" (ByVal hWnd As Long) As Boolean
Sub WaitForWindowToClose(winCaption As String)
'pauses code execution until no window caption (title) matches [winCaption]
Dim lhWndP As Long, sStr As String
Dim foundWindow As Boolean, startTime As Single
'loop through all windows
lhWndP = FindWindow(vbNullString, vbNullString)
Do While lhWndP <> 0
sStr = String(GetWindowTextLength(lhWndP) + 1, Chr$(0))
GetWindowText lhWndP, sStr, Len(sStr)
'check if this window is a match
If InStr(1, sStr, winCaption, vbTextCompare) > 0 Then
Debug.Print "Found Window: " & sStr & " (#" & lhWndP & ")"
foundWindow = True
Exit Do
End If
lhWndP = GetWindow(lhWndP, 2)
Loop
If Not foundWindow Then
Debug.Print "Window '" & winCaption & "' not found."
Exit Sub
End If
'check if window still exists
Do While FindWindow(vbNullString, sStr) <> 0 And IsWindowVisible(lhWndP)
'pause for a quarter second before checking again
startTime = Timer
Do While Timer < startTime + 0.25
DoEvents
Loop
Loop
Debug.Print "Window no longer exists."
End Sub
Example Usage:
WaitForWindowToClose "progress"
...pauses execution of code until there is no open window with progress in its' title bar.
The procedure looks for case-insensitive, partial matches, because window captions are not always what they appear to be.
This shouldn't be an issue unless you have another window open with a similar caption to the one you're waiting for. For example, progress could refer to your printer's progress window, or a browser window called "Progressive Insurance".
Troubleshooting:
The following procedures aren't necessary for operation of the above, but I figured I'd include them anyway, for troubleshooting purposes (ie., in case you're having trouble identifying your printer's progress window).
Usage should be self-explanatory:
Sub ListAllVisibleWindows()
'Lists all named, visible windows in the Immediate Window
Dim lhWndP As Long, sStr As String
lhWndP = FindWindow(vbNullString, vbNullString)
Do While lhWndP <> 0
x = x + 1
sStr = String(GetWindowTextLength(lhWndP) + 1, Chr$(0))
If Len(sStr) > 1 And IsWindowVisible(lhWndP) Then
GetWindowText lhWndP, sStr, Len(sStr)
Debug.Print "#" & x, lhWndP, sStr
End If
lhWndP = GetWindow(lhWndP, 2)
Loop
End Sub
Public Function IsWindowOpen(winCaption As String) As Boolean
'returns TRUE if winCaption is a partial match for an existing window
Dim lhWndP As Long, sStr As String
lhWndP = FindWindow(vbNullString, vbNullString)
Do While lhWndP <> 0
sStr = String(GetWindowTextLength(lhWndP) + 1, Chr$(0))
GetWindowText lhWndP, sStr, Len(sStr)
If InStr(1, sStr, winCaption, vbTextCompare) > 0 Then
Debug.Print "Found Window: " & sStr & " (#" & lhWndP & ")"
IsWindowOpen = True
Exit Do
End If
lhWndP = GetWindow(lhWndP, 2)
Loop
End Function
(Code was adapted from here.)

Filling a web form using VBA

So I have been given the task to create new users in the company I work for website. I was given an excel sheet of 100 + usernames and email addresses. I did not want to have to manually do it so is decided to try and write a program. I have never touched VB before, and this is how far I have been able to reach. It works for the first run through the while loop but then I receive an error:
Run-time error '91'
Object variable or With block variable not set
When I try to debug this error, This line in my code becomes highlighted:
IE.document.GetElementsbyname("user_login")(0).Value = ThisWorkbook.Sheets("sheet1").Cells(j, i) ' sets login info
In my Excel Spreadsheet, the email addresses are same as the login info, and they are links to send an email via outlook. I will see if this is causing my error, but in the meantime, I wanted to get a second pair of eyes on this. Thank you for reading this. this is my first post on here so I apologize if it isn't as informative as you'd like
Here is the rest of my code so far
Sub FillInternetForm()
Dim IE As Object
Set IE = CreateObject("InternetExplorer.Application")
'create new instance of IE
Dim i As Integer
Dim j As Integer
Dim x As Integer
Dim y As Integer
Dim s As String
s = "paswd" ' pasword setting
i = 4 ' column D for email input
j = 50 ' row to start
x = 9 ' column I For last name input
y = 10 'column j for last name
'you want to use open IE window. Easiest way I know of is via title bar.
While j < 121
Wait
IE.Navigate "website link"
'go to web page listed inside quotes
IE.Visible = True
While IE.busy
DoEvents 'wait until IE is done loading page.
Wend
IE.document.GetElementsbyname("user_login")(0).Value = ThisWorkbook.Sheets("sheet1").Cells(j, i) ' sets login info
IE.document.GetElementsbyname("email")(0).Value = ThisWorkbook.Sheets("sheet1").Cells(j, i) ' sets email address
IE.document.GetElementsbyname("first_name")(0).Value = ThisWorkbook.Sheets("sheet1").Cells(j, y) ' sets first name
IE.document.GetElementsbyname("last_name")(0).Value = ThisWorkbook.Sheets("sheet1").Cells(j, x) ' sets last name
Set elementcol = IE.document.getElementsByClassName("button button-secondary wp-generate-pw hide-if-no-js")
elementcol.Item(0).Click 'shows the password
While IE.busy
DoEvents 'wait until IE is done loading page.
Wend
IE.document.GetElementsbyname("pass1-text")(0).Value = s 'sets the password
Wait
Set elementcol = IE.document.getElementsByClassName("pw-checkbox")
elementcol.Item(0).Click ' clicks confirmation of weak password choice
While IE.busy
DoEvents 'wait until IE is done loading page.
Wend
Set elementcol = IE.document.GetElementsbyname("send_user_notification")
elementcol.Item(0).Click ' unclicks send new user email
While IE.busy
DoEvents 'wait until IE is done loading page.
Wend
IE.document.getElementByID("createusersub").Click ' clicks add new user
While IE.busy
DoEvents 'wait until IE is done loading page.
Wend
j = j + 1
While IE.busy
DoEvents 'wait until IE is done loading page.
Wend
Wend
End Sub
Sub Wait()
Application.Wait Time + TimeSerial(0, 0, 5)
End Sub
EDIT: THIS ERROR ONLY appears after 5 runs through my loop
The cache is probably clogged up from all the looping.
Option Explicit
Private Declare Function FindFirstUrlCacheGroup Lib "wininet.dll" ( _
ByVal dwFlags As Long, _
ByVal dwFilter As Long, _
ByRef lpSearchCondition As Long, _
ByVal dwSearchCondition As Long, _
ByRef lpGroupId As Date, _
ByRef lpReserved As Long) As Long
Private Declare Function FindNextUrlCacheGroup Lib "wininet.dll" ( _
ByVal hFind As Long, _
ByRef lpGroupId As Date, _
ByRef lpReserved As Long) As Long
Private Declare Function DeleteUrlCacheGroup Lib "wininet.dll" ( _
ByVal sGroupID As Date, _
ByVal dwFlags As Long, _
ByRef lpReserved As Long) As Long
Private Declare Function FindFirstUrlCacheEntry Lib "wininet.dll" Alias "FindFirstUrlCacheEntryA" ( _
ByVal lpszUrlSearchPattern As String, _
ByRef lpFirstCacheEntryInfo As INTERNET_CACHE_ENTRY_INFO, _
ByRef lpdwFirstCacheEntryInfoBufferSize As Long) As Long
Private Type INTERNET_CACHE_ENTRY_INFO
dwStructSize As Long
szRestOfData(1024) As Long
End Type
Private Declare Function DeleteUrlCacheEntry Lib "wininet.dll" Alias "DeleteUrlCacheEntryA" ( _
ByVal lpszUrlName As Long) As Long
Private Declare Function FindNextUrlCacheEntry Lib "wininet.dll" Alias "FindNextUrlCacheEntryA" ( _
ByVal hEnumHandle As Long, _
ByRef lpNextCacheEntryInfo As INTERNET_CACHE_ENTRY_INFO, _
ByRef lpdwNextCacheEntryInfoBufferSize As Long) As Long
Private Const CACHGROUP_SEARCH_ALL = &H0
Private Const ERROR_NO_MORE_FILES = 18
Private Const ERROR_NO_MORE_ITEMS = 259
Private Const CACHEGROUP_FLAG_FLUSHURL_ONDELETE = &H2
Private Const BUFFERSIZE = 2048
Private Sub Command1_Click()
Dim sGroupID As Date
Dim hGroup As Long
Dim hFile As Long
Dim sEntryInfo As INTERNET_CACHE_ENTRY_INFO
Dim iSize As Long
On Error Resume Next
' Delete the groups
hGroup = FindFirstUrlCacheGroup(0, 0, 0, 0, sGroupID, 0)
' To avoid error using it with IE4 as FindFirstUrlCacheGroup is not implemented
If Err.Number <> 453 Then
If (hGroup = 0) And (Err.LastDllError <> 2) Then
MsgBox "An error occurred enumerating the cache groups" & Err.LastDllError
Exit Sub
End If
Else
Err.Clear
End If
If (hGroup <> 0) Then
'we succeeded in finding the first cache group.. enumerate and
'delete
Do
If (0 = DeleteUrlCacheGroup(sGroupID, CACHEGROUP_FLAG_FLUSHURL_ONDELETE, 0)) Then
' To avoid error using it with IE4 as FindFirstUrlCacheGroup is not implemented
If Err.Number <> 453 Then
MsgBox "Error deleting cache group " & Err.LastDllError
Exit Sub
Else
Err.Clear
End If
End If
iSize = BUFFERSIZE
If (0 = FindNextUrlCacheGroup(hGroup, sGroupID, iSize)) And (Err.LastDllError <> 2) Then
MsgBox "Error finding next url cache group! - " & Err.LastDllError
End If
Loop Until Err.LastDllError = 2
End If
' Delete the files
sEntryInfo.dwStructSize = 80
iSize = BUFFERSIZE
hFile = FindFirstUrlCacheEntry(0, sEntryInfo, iSize)
If (hFile = 0) Then
If (Err.LastDllError = ERROR_NO_MORE_ITEMS) Then
GoTo done
End If
MsgBox "ERROR: FindFirstUrlCacheEntry - " & Err.LastDllError
Exit Sub
End If
Do
If (0 = DeleteUrlCacheEntry(sEntryInfo.szRestOfData(0))) _
And (Err.LastDllError <> 2) Then
Err.Clear
End If
iSize = BUFFERSIZE
If (0 = FindNextUrlCacheEntry(hFile, sEntryInfo, iSize)) And (Err.LastDllError <> ERROR_NO_MORE_ITEMS) Then
MsgBox "Error: Unable to find the next cache entry - " & Err.LastDllError
Exit Sub
End If
Loop Until Err.LastDllError = ERROR_NO_MORE_ITEMS
done:
MsgBox "cache cleared"
Command1.Enabled = True
End Sub
http://www.vbforums.com/showthread.php?440508-Clear-IE-Browser-Cache-and-History-with-VBA

Open folder, open file, run code, close file, go to next folder

I've been looking around for a VBA script that will open a folder, open a .xlsx file, run my code, close the .xlsx file, and go to the next folder (not subfolder). I just can't figure it out. My folder structure is as follows:
C:\Files\[hundreds of folders]\name.xlsx
Each folder has a .xlsx file in it and I need to run my code on all of these files (about 1000 folders each with 1 file).
Any and all help would be greatly appreciated! Thanks!
This uses a list "mfList" that gets created based on the criteria that it begins with "C:\Files\" and has exactly one sub folder after that point. All such folders "qualify" to be recorded in the list. Once you have the list, you can go through each of the paths, and for every .xlsx file in that path, run your code. I took one of my programs and manipulated it, so I haven't actually tested it, but hopefully this gives you the idea, and points you in the right direction. (And again these are functions, you'd have to create the subroutine that calls them, of course, with appropriate variables)
Function MapFolders(fPath As String, Optional ByRef mfList As Collection, Optional NotTopLevel As Boolean)
Dim i As Long, Temp As String, nList As New Collection, mfVariant As Variant
On Error Resume Next: i = mfList.Count: On Error GoTo 0: If i = 0 Then Set mfList = nList
If Left(fPath, 9) = "C:\Files\" And InStr(Right(fPath, Len(fPath) - 9), "\") = InStrRev(Right(fPath, Len(fPath) - 9), "\") And Not InStr(Right(fPath, Len(fPath) - 9), "\") = 0 Then mfList.Add fPath
i = 1: Temp = SubFolder(fPath, i)
While Len(Temp) > 0
MapFolders Temp, mfList, True
i = i + 1: Temp = SubFolder(fPath, i)
Wend
If (Not mfList.Count = 0) And (Not NotTopLevel) Then Set mfVariant = Nothing: Set mfList = nList
Set nList = Nothing
End Function
Function SubFolder(fPath As String, i As Long) As String
Dim FSO As New FileSystemObject, FSOFolder As Object, FSOSubFolder As Object, FCount As Integer, j As Long
SubFolder = "": On Error Resume Next: Set FSOFolder = FSO.GetFolder(fPath): On Error GoTo 0
If FSOFolder Is Nothing Then Exit Function
On Error Resume Next: FCount = FSOFolder.SubFolders.Count: On Error GoTo 0
If i <= FCount Then
For Each FSOSubFolder In FSOFolder.SubFolders
j = j + 1: If j = i Then Exit For
Next FSOSubFolder
SubFolder = FSOSubFolder.Path & "\"
End If
Set FSO = Nothing: Set FSOFolder = Nothing
End Function
Hope this helps. You can extrapolate accordingly.
Sub Openfile()
Dim MyFolder As String
Dim MyFile As String
'The code below opens up the specified folder.
'Replace the pathway with your own.
'Keep the explorer.exe string.
Call Shell("explorer.exe" & " " & "C:\Users\mvanover\Desktop\Test", vbNormalFocus)
'The code below opens up every excel file with .xlsx extension in the MyFolder path.
MyFolder = "C:\Users\mvanover\Desktop\Test"
MyFile = Dir(MyFolder & "\*.xlsx")
Do While MyFile <> ""
Workbooks.Open Filename:=MyFolder & "\" & MyFile
MyFile = Dir
Loop
End Sub
Update:
You could also input all the folder names in cells located in your macro-enabled workbook and set those values to the an object in your macro. You can then add that object to the end of your string located in the shell function. An example is shown below:
Call Shell("explorer.exe" & " " & "C:\Users\mvanover\Desktop\Test\" & FolderName, vbNormalFocus)
You could then set up an easy loop that would go through each folder name and open them accordingly. Your code inside that loop would consist of opening all/one excel workbook(s), running the code you'd like to run, and closing the each folder. The code for closing the folders as well is shown below:
Call Shell("explorer.exe" & " " & "C:\Users\mvanover\Desktop\Test\" & FolderName, vbNormalFocus)
DoEvents
Hwnd = apiFindWindow("CabinetWClass", vbNullString)
Dim retval As Long
If (Hwnd) Then
retval = apiPostMessage(Hwnd, CLOSE_WIN, 0, ByVal 0&)
End If
Add the code shown below before your sub statement as well or the closing folder code won't work:
Private Const CLOSE_WIN = &H10
Dim Hwnd As Long
Private Declare Function apiFindWindow _
Lib "user32" Alias "FindWindowA" _
(ByVal lpClassname As String, _
ByVal lpWindowName As String) _
As Long
Private Declare Function apiPostMessage _
Lib "user32" Alias "PostMessageA" _
(ByVal Hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) _
As Long
Sorry about all this new code. It's actually a lot harder to close a folder compared to opening it. When I was debugging through the closing code with F8 it works.

Limiting number of instances of executables called by a for loop

I have a program that exports text files which which are then used by an executable to run simulations which take generally 5 to 10 minutes each.
I have created a for loop which runs this process For Each text file. I originally wrote code for a separate executable, which the VBA macro would call, and this would run each simulation in series. I wanted to be able to run more in parallel, so I transferred the macro directly to VBA, but this causes every simulation to run simultaneously and brings the processor to a crawl.
Is there a way to allow for a limited number of simulations to run at one time?
EDIT: Sorry, I wrote this using a phone, because my computer was bogged down with this exact problem at the time. Here is the code. I have a function for running one simulation which moves the required exe (same for every simulation) and input.txt file into its own subfolder, and a second function which runs the first function on a loop over listbox selections:
Function RunSimulations() As Boolean
For k = 0 To myListBox.ListCount - 1
If myListBox.Selected(k) = True Then
SimulateOne(myListBox.List(k))
End If
End If
Next k
End Function
Function SimulateOne(inputFName As String) As Boolean
Dim currPath As String, inptPath As String, simsPath As String
Dim destPath As String, origFile As String, destFile As String
'Defines various folder paths
currPath = ThisWorkbook.Path & "\"
inptPath = currPath & INPUT_FOLDERNAME & "\"
simsPath = currPath & SIMS_FOLDERNAME & "\"
If Len(Dir(simsPath, vbDirectory)) = 0 Then MkDir simsPath
destPath = simsPath & Replace(inputFName, ".txt", "") & "\"
If Len(Dir(destPath, vbDirectory)) = 0 Then MkDir destPath
'Move input files from "input_files" to subfolders within "simulations"
origFile = inptPath & inputFName
destFile = destPath & INPUT_FILENAME 'Changes name to "INPUT.TXT"
If Len(Dir(destFile)) <> 0 Then SetAttr destFile, vbNormal: Kill destFile
If Len(Dir(origFile)) <> 0 Then
FileCopy origFile, destFile
Else
SimulateOne = False
Exit Function
End If
If Len(Dir(currPath & EXE_FILENAME)) <> 0 Then
'Moves exe files to new subfolder within "simulations"
FileCopy currPath & EXE_FILENAME, destPath & EXE_FILENAME
'Run exe
ChDrive Left(destPath, 1)
ChDir destPath
Shell (destPath & EXE_FILENAME)
SimulateOne = True
Else
SimulateOne = False
Exit Function
End If
End Function
EDIT: Implemented this loop recently. Wondering about the efficiency (or lack thereof) of the loop that goes constantly until the processor count drops low enough.
For k = 0 To myListBox.ListCount - 1
Do While ProcessRunningCount(EXE_FILENAME) >= processLimit
Application.Wait (Now + TimeValue("0:00:05"))
Loop
If myListBox.Selected(k) = True Then runResult = SimulateOne(myListBox.List(k))
Next k
EDIT: OK here is a tested implementation of the sort of thing you want to do. I'm using a simple vbscript to simulate your exe (so I'm monitoring "wscript.exe")
Dim colFiles As Collection 'has items to be processed
'sets up the items to be processed and kicks off the runs
Sub InitSimulations()
Dim x As Long, arr(1 To 20) As String
Set colFiles = New Collection
For x = 1 To 20
colFiles.Add "File_" & x
Next x
RunSimulations
End Sub
'Initially called by InitSimulations, then calls itself periodically
' to check whether a new run needs to be started
Sub RunSimulations()
Const MAX_PROCESSES As Long = 5
Dim sFile As String
'below our threshold?
If HowMany("wscript.exe") < MAX_PROCESSES Then
'any left to process?
If colFiles.Count > 0 Then
sFile = colFiles(1)
colFiles.Remove 1
SimulateOne sFile
Debug.Print Now, "Kicked off " & sFile
End If
End If
'Calls itself again in one second if any still remaining to process
' if your processes are long-running then can adjust for longer delay
If colFiles.Count > 0 Then
Application.OnTime Now + TimeSerial(0, 0, 1), "RunSimulations", , True
End If
End Sub
'Launch a simulation process
Sub SimulateOne(FileName)
Shell "wscript.exe ""C:\_Stuff\Test.vbs"""
'not doing anything with FileName...
'test vbs has one line: WScript.Sleep 10000
End Sub
'Count how many "procName" processes are running
Function HowMany(procName As String) As Long
Dim objWMIService, colProcess, processName
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colProcess = objWMIService.ExecQuery _
("Select * from Win32_Process where Name = '" & procName & "'")
HowMany = colProcess.Count
End Function
Could the answer be as simple as waiting a certain amount of time in your loop. That could control the number of processes to some degree. This will kick one off, wait five minutes, kick off the next, wait five minutes, kick off the next etc..
Function RunSimulations() As Boolean
For k = 0 To myListBox.ListCount - 1
If myListBox.Selected(k) = True Then
SimulateOne(myListBox.List(k))
Application.Wait (Now + TimeValue("0:05:00"))
End If
Next k
End Function
If that isn't good enough I have some VBA functions that can be used.
'API Calls - place these at the top of your code with your globals
Private Declare Function OpenProcess Lib "kernel32" ( _
ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" ( _
ByVal hObject As Long) As Long
Private Declare Function EnumProcesses Lib "PSAPI.DLL" ( _
lpidProcess As Long, ByVal cb As Long, cbNeeded As Long) As Long
Private Declare Function EnumProcessModules Lib "PSAPI.DLL" ( _
ByVal hProcess As Long, lphModule As Long, ByVal cb As Long, lpcbNeeded As Long) As Long
Private Declare Function GetModuleBaseName Lib "PSAPI.DLL" Alias "GetModuleBaseNameA" ( _
ByVal hProcess As Long, ByVal hModule As Long, ByVal lpFileName As String, ByVal nSize As Long) As Long
Private Const PROCESS_VM_READ = &H10
Private Const PROCESS_QUERY_INFORMATION = &H400
Just feed the proc name b = IsProcessRunning("ProcName.exe")
Private Function IsProcessRunning(ByVal sProcess As String) As Boolean
'Check to see if a process is currently running
Const MAX_PATH As Long = 260
Dim lProcesses() As Long
Dim lModules() As Long
Dim N As Long
Dim lRet As Long
Dim hProcess As Long
Dim sName As String
sProcess = UCase$(sProcess)
ReDim lProcesses(1023) As Long
If EnumProcesses(lProcesses(0), 1024 * 4, lRet) Then
For N = 0 To (lRet \ 4) - 1
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, lProcesses(N))
If hProcess Then
ReDim lModules(1023)
If EnumProcessModules(hProcess, lModules(0), 1024 * 4, lRet) Then
sName = String$(MAX_PATH, vbNullChar)
GetModuleBaseName hProcess, lModules(0), sName, MAX_PATH
sName = Left$(sName, InStr(sName, vbNullChar) - 1)
If sProcess = UCase$(sName) Then
IsProcessRunning = True
Exit Function
End If
End If
End If
CloseHandle hProcess
Next N
End If
End Function
You probably want this one. It will return the number of time it finds the process. If it is more than you want running. Don't kick off another.
Private Function ProcessRunningCount(ByVal sProcess As String) As Long
'Check to see if how many occurences of a process are currently running
Const MAX_PATH As Long = 260
Dim lProcesses() As Long
Dim lModules() As Long
Dim N As Long
Dim lRet As Long
Dim hProcess As Long
Dim sName As String
Dim lCount As Long
sProcess = UCase$(sProcess)
ReDim lProcesses(1023) As Long
lCount = 0
If EnumProcesses(lProcesses(0), 1024 * 4, lRet) Then
For N = 0 To (lRet \ 4) - 1
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, lProcesses(N))
If hProcess Then
ReDim lModules(1023)
If EnumProcessModules(hProcess, lModules(0), 1024 * 4, lRet) Then
sName = String$(MAX_PATH, vbNullChar)
GetModuleBaseName hProcess, lModules(0), sName, MAX_PATH
sName = Left$(sName, InStr(sName, vbNullChar) - 1)
If sProcess = UCase$(sName) Then
lCount = lCount + 1
End If
End If
End If
CloseHandle hProcess
Next N
End If
ProcessRunningCount = lCount
End Function
Something like this
Function RunSimulations() As Boolean
For k = 0 To myListBox.ListCount - 1
Do While ProcessRunningCount("chrome.exe") >= 5 'Enter you proc name here
Application.Wait (Now + TimeValue("0:00:10"))
Loop
If myListBox.Selected(k) = True Then
SimulateOne(myListBox.List(k))
End If
Next k
End Function

Reference workbooks between instances of Excel

long time user, first question.
So an internet site that my business used to get information on coal ship movements has recently been reworked, so I have to rework my program to scrape the ship information. I had been navigating to each port using button click events and using;
Dim Table As Object, Set Table = ie.document.getElementsByTagName("TABLE")(11)
to get the actual table. On the new site they have the option to export all ship movements to excel and it would be a lot quicker if I could automate the macro to get the excel files. To clarify I am just trying to get my program to go to this site; https://qships.tmr.qld.gov.au/webx/, click on 'Ship Movements' up the top, click 'Tools', click 'Export to excel' then open the file and go back to the site and click 'Vessel At birth', 'Tools', 'Export to excel' and open that file, then use somthing like;
Windows("Traffic.xls").Activate
Application.ActiveProtectedViewWindow.Edit
Sheets("Traffic").Select
Application.DisplayAlerts = False
Sheets("Traffic").Move After:=Workbooks("Search Ship Schedule.xlsm").Sheets(4)
Application.DisplayAlerts = True
To get the sheets from the workbooks back to my main workbook, where I will then search through and get the ones I want. Here's what I've got sofar;
Dim ws1, ws2 As Worksheet
Set ws1 = ActiveSheet
Set ws2 = ThisWorkbook.Sheets("Sheet1")
ws2.Cells.ClearContents
Dim Site, BtnPage(1 To 2), Btn As String
Site = "https://qships.tmr.qld.gov.au/webx/"
Dim ie As InternetExplorer
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = True
ie.navigate Site
Do While Not ie.readyState = 4 Or ie.Busy
DoEvents
Loop
Application.Wait (Now() + TimeValue("0:00:3"))
ie.document.getElementById("Traffic").Click
Do While Not ie.readyState = 4 Or ie.Busy
DoEvents
Loop
Application.Wait (Now() + TimeValue("0:00:3"))
ie.document.getElementsByClassName("ui-widget fg-button fg-button-icon-left ui-corner-all grid-tools")(0).Click
Sleep 100
ie.document.getElementById("0").Click
Do While Not ie.readyState = 4 Or ie.Busy
DoEvents
Loop
Sleep 2500
SendKeys "%o"
Do While Not ie.readyState = 4 Or ie.Busy
DoEvents
Loop
Sleep 6500
'Sleep_DoEvents 7
ie.document.getElementById("InPort").Click
Do While Not ie.readyState = 4 Or ie.Busy
DoEvents
Loop
Application.Wait (Now() + TimeValue("0:00:3"))
ie.document.getElementsByClassName("ui-widget fg-button fg-button-icon-left ui-corner-all grid-tools")(0).Click
Sleep 100
ie.document.getElementById("0").Click
Do While Not ie.readyState = 4 Or ie.Busy
DoEvents
Loop
'Windows("Traffic").Activate
'Application.Windows("Traffic.xls").ActiveProtectedViewWindow.Edit
'Application.Windows("Traffic.xls").Activate
Static hWnds() As Variant
Sleep 500
r = FindWindowLike(hWnds(), 0, "Public Pages - Internet Explorer", "*", Null)
Sleep 3000
If r > 0 Then
SetFocusAPI (hWnds(1))
'Sleep 1000
SendKeys "%o"
Do While Not ie.readyState = 4 Or ie.Busy
DoEvents
Loop
Sleep 6000
'Application.ActiveProtectedViewWindow.Edit
End If
'ie.Close
and I have this in a module
Public Declare Function BlockInput Lib "USER32.dll" (ByVal fBlockIt As Long) As Long
#If VBA7 Then
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) 'For 64 Bit Systems
#Else
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'For 32 Bit Systems
#End If
Declare Function SetFocusAPI Lib "User32" Alias "SetForegroundWindow" _
(ByVal hWnd As Long) As Long
Declare Function GetWindow Lib "User32" (ByVal hWnd As Long, _
ByVal wCmd As Long) As Long
Declare Function GetDesktopWindow Lib "User32" () As Long
Declare Function GetWindowLW Lib "User32" Alias "GetWindowLongA" _
(ByVal hWnd As Long, ByVal nIndex As Long) As Long
Declare Function GetParent Lib "User32" (ByVal hWnd As Long) As Long
Declare Function GetClassName Lib "User32" Alias "GetClassNameA" _
(ByVal hWnd As Long, ByVal lpClassName As String, _
ByVal nMaxCount As Long) As Long
Declare Function GetWindowText Lib "User32" Alias "GetWindowTextA" _
(ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) _
As Long
Public Const GWL_ID = (-12)
Public Const GW_HWNDNEXT = 2
Public Const GW_CHILD = 5
'FindWindowLike
' - Finds the window handles of the windows matching the specified
' parameters
'
'hwndArray()
' - An integer array used to return the window handles
'
'hWndStart
' - The handle of the window to search under.
' - The routine searches through all of this window's children and their
' children recursively.
' - If hWndStart = 0 then the routine searches through all windows.
'
'WindowText
' - The pattern used with the Like operator to compare window's text.
'
'ClassName
' - The pattern used with the Like operator to compare window's class
' name.
'
'ID
' - A child ID number used to identify a window.
' - Can be a decimal number or a hex string.
' - Prefix hex strings with "&H" or an error will occur.
' - To ignore the ID pass the Visual Basic Null function.
'
'Returns
' - The number of windows that matched the parameters.
' - Also returns the window handles in hWndArray()
'
'----------------------------------------------------------------------
'Remove this next line to use the strong-typed declarations
#Const WinVar = True
#If WinVar Then
Function FindWindowLike(hWndArray() As Variant, _
ByVal hWndStart As Variant, WindowText As String, _
Classname As String, ID) As Integer
Dim hWnd
Dim r
Static level
Static iFound
#ElseIf Win32 Then
Function FindWindowLike(hWndArray() As Long, ByVal hWndStart As Long, _
WindowText As String, Classname As String, ID) As Long
Dim hWnd As Long
Dim r As Long
' Hold the level of recursion:
Static level As Long
' Hold the number of matching windows:
Static iFound As Long
#ElseIf Win16 Then
Function FindWindowLike(hWndArray() As Integer, _
ByVal hWndStart As Integer, WindowText As String, _
Classname As String, ID) As Integer
Dim hWnd As Integer
Dim r As Integer
' Hold the level of recursion:
Static level As Integer
'Hold the number of matching windows:
Static iFound As Integer
#End If
Dim sWindowText As String
Dim sClassname As String
Dim sID
' Initialize if necessary:
If level = 0 Then
iFound = 0
ReDim hWndArray(0 To 0)
If hWndStart = 0 Then hWndStart = GetDesktopWindow()
End If
' Increase recursion counter:
level = level + 1
' Get first child window:
hWnd = GetWindow(hWndStart, GW_CHILD)
Do Until hWnd = 0
DoEvents ' Not necessary
' Search children by recursion:
r = FindWindowLike(hWndArray(), hWnd, WindowText, Classname, ID)
' Get the window text and class name:
sWindowText = Space(255)
r = GetWindowText(hWnd, sWindowText, 255)
sWindowText = Left(sWindowText, r)
sClassname = Space(255)
r = GetClassName(hWnd, sClassname, 255)
sClassname = Left(sClassname, r)
' If window is a child get the ID:
If GetParent(hWnd) <> 0 Then
r = GetWindowLW(hWnd, GWL_ID)
sID = CLng("&H" & Hex(r))
Else
sID = Null
End If
' Check that window matches the search parameters:
If sWindowText Like WindowText And sClassname Like Classname Then
If IsNull(ID) Then
' If find a match, increment counter and
' add handle to array:
iFound = iFound + 1
ReDim Preserve hWndArray(0 To iFound)
hWndArray(iFound) = hWnd
ElseIf Not IsNull(sID) Then
If CLng(sID) = CLng(ID) Then
' If find a match increment counter and
' add handle to array:
iFound = iFound + 1
ReDim Preserve hWndArray(0 To iFound)
hWndArray(iFound) = hWnd
End If
End If
Debug.Print "Window Found: "
Debug.Print " Window Text : " & sWindowText
Debug.Print " Window Class : " & sClassname
Debug.Print " Window Handle: " & CStr(hWnd)
End If
' Get next child window:
hWnd = GetWindow(hWnd, GW_HWNDNEXT)
Loop
' Decrement recursion counter:
level = level - 1
' Return the number of windows found:
FindWindowLike = iFound
End Function
My problem is that when these excel files are opening, they open in a new instance of excel and I can't reference them any regular way. Since they are not actually saved I can't use GetObject() like recommended in this answer Can VBA Reach Across Instances of Excel? and I don't know how to reference the excel workbooks using a handle. I think that they are opening in a new instance of excel because the macro is running and even when using Sleep() it doesn't let excel open the new workbooks. I have tried using a Do DoWhile Loop to let excel open the workbooks but that doesn't seem to work. So, if anyone could help me open the workbooks in the same instance of excel so that I can reference them easier or reference between excel instances without GetObject() that would be greatly appreciated.
==================================EDIT=======================================
This was the final result I wound up with. Thanks to user3565396 I just saved it in the downloads folder like you recommended, I couldn't figure out how to use WinHttp like Robert Co recommended. For some reason the code exits without an error message on the line wb2.Sheets(1).Copy After:=wb1.Sheets("Import") but re-opening seems to work fine and it's only used once or twice a day.
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Integer
Function DelTrafficAndInPort()
'Clear all ws's like "Traffic" or "In Port" and all wb's
'In VBE, click Tools, References, find "Microsoft Scripting Runtime"
'and check it off for this program to work
Dim fso As FileSystemObject
Dim fold As Folder
Dim f As File
Dim folderPath As String
Dim cbo As Object
folderPath = "C:\Users\" & Environ("username") & "\Downloads"
Set fso = New FileSystemObject
Set fold = fso.GetFolder(folderPath)
For Each f In fold.Files
If ((Left(f.Name, 7) = "Traffic" Or Left(f.Name, 7) = "In Port") And Right(f.Name, 4) = ".xls") Then
fso.DeleteFile f.Path
End If
Next
End Function
Sub BtnScrape_Click()
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Dim wb1, wb2 As Workbook
Set wb1 = ActiveWorkbook
Run DelTrafficAndInPort() ' from downloads
Dim ws As Worksheet
Application.DisplayAlerts = False
For Each ws In wb1.Worksheets
If (Left(ws.Name, 7) = "Traffic" Or Left(ws.Name, 7) = "In Port") Then ws.Delete
Next ws
Application.DisplayAlerts = True
Dim ie As InternetExplorer 'SHDocVw.InternetExplorer
Dim sw As New SHDocVw.ShellWindows
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = True
ie.navigate "https://qships.tmr.qld.gov.au/webx/"
Do While Not ie.readyState = 4 Or ie.Busy
DoEvents
Loop
Dim BtnName(1 To 2), wbPath(1 To 2) As String
BtnName(1) = "Traffic"
BtnName(2) = "InPort"
wbPath(1) = "C:\Users\" & Environ("username") & "\Downloads\Traffic.xls" '"C:\Users\owner\Downloads\Traffic.xls"
wbPath(2) = "C:\Users\" & Environ("username") & "\Downloads\In Port.xls"
Dim I As Integer
For I = 1 To 2
ie.document.getElementById(BtnName(I)).Click
Do While Not ie.readyState = 4 Or ie.Busy
DoEvents
Loop
Application.Wait (Now() + TimeValue("00:00:04"))
ie.document.getElementsByTagName("span")(8).Click 'Tools
Application.Wait (Now() + TimeValue("00:00:01"))
ie.document.getElementById("0").Click 'Export to Excel 'ie.document.getElementsByTagName("span")(27).Click
Application.Wait (Now() + TimeValue("00:00:5"))
SetForegroundWindow (ie.hwnd)
Application.Wait (Now() + TimeValue("00:00:01"))
SendKeys "%S" 'Save
Application.Wait (Now() + TimeValue("00:00:02"))
Set wb2 = Workbooks.Open(wbPath(I))
wb2.Sheets(1).Copy After:=wb1.Sheets("Import")
wb2.Close False
Next I
ie.Quit
wb1.Sheets("Import").Select
Run DelTrafficAndInPort() ' from downloads
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
MsgBox "Finished"
End Sub
Here is the solution. I skipped some steps which you have done correctly. The code starts from clicking Tools and then Export to excel. After that I click "Alt + S" which is Save (Not Open). With this code I managed to copy worksheet from the downloaded file to the workbook from which I was running the VBA code. Hope that helps.
P.S. All files must be in the same directory.
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Integer
Dim ie As SHDocVw.InternetExplorer
Dim sw As New SHDocVw.ShellWindows
Sub test()
Dim hw As Long, rtrn As Integer
For Each ie In sw
If ie.LocationURL = "https://qships.tmr.qld.gov.au/webx/" Then
ie.Document.getElementsByTagName("span")(8).Click 'Tools
ie.Document.getElementsByTagName("span")(27).Click 'Export to Excel
Application.Wait (Now() + TimeValue("00:00:10"))
Exit For
End If
Next ie
hw = ie.hwnd
rtrn = SetForegroundWindow(hw)
Application.Wait (Now() + TimeValue("00:00:03"))
SendKeys "%S" 'Save
Application.Wait (Now() + TimeValue("00:00:03"))
Workbooks.Open ("Traffic.xls")
Dim sh As Worksheet, wb As Workbook
Set wb = Workbooks("TEST.xlsb") 'Target Workbook
For Each sh In Workbooks("Traffic.xls").Worksheets
sh.Copy After:=wb.Sheets(wb.Sheets.Count)
Next sh
End Sub
When you click a link, it download it to the browser temporary folder and open it with the recommended application in another session. The trick is is download the file within the VBA itself and open it in the same session. If the url is predictable, you can certainly automate that.
Use WinHttp to download as a stream and recreate that file in your own temp folder. It's about 10 lines of code. Continue the VBA with Workbooks.Open which opens the file in the same session.