aliaslamy2k
Active Member
- Joined
- Sep 15, 2009
- Messages
- 416
- Office Version
- 2019
- Platform
- Windows
Dear Experts,
I have below VBA script which does periodic display of windows configured. However, it is take very long time execute.
I would be oblidge to help me to execute this script fast.
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function SetForegroundWindow Lib "user32" _
(ByVal hWnd As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" _
(ByVal hWnd As Long, _
lpdwProcessId As Long) As Long
Private Declare Function IsIconic Lib "user32" _
(ByVal hWnd As Long) As Long
Private Declare Function ShowWindow Lib "user32" _
(ByVal hWnd As Long, _
ByVal nCmdShow As Long) As Long
Private Declare Function AttachThreadInput Lib "user32" _
(ByVal idAttach As Long, _
ByVal idAttachTo As Long, _
ByVal fAttach As Long) As Long
Private Declare Function GetForegroundWindow Lib "user32" _
() As Long
Private Const SW_RESTORE = 9
Private Const SW_SHOW = 5
Private Const SW_MINIMIZE = 2
Private Declare Function EnumWindows Lib "user32" _
(ByVal lpEnumFunc As Long, _
ByVal lParam As Long) As Long
Private Declare Function GetWindowText Lib "user32" _
Alias "GetWindowTextA" _
(ByVal hWnd As Long, _
ByVal lpString As String, _
ByVal cch As Long) As Long
'Custom structure for passing in the parameters in/out of the hook enumeration function
'Could use global variables instead, but this is nicer.
Private Type FindWindowParameters
strTitle As String 'INPUT
hWnd() As Long 'OUTPUT
End Type
Dim Parameters As FindWindowParameters
Dim Count As Integer
Public Function FnFindWindowLike(strWindowTitle As String) As Boolean
'We'll pass a custom structure in as the parameter to store our result...
Parameters.strTitle = strWindowTitle ' Input parameter
Count = -1
Call EnumWindows(AddressOf EnumWindowProc, VarPtr(Parameters))
If Count > -1 Then
FnFindWindowLike = True
Else
FnFindWindowLike = False
End If
End Function
Private Function EnumWindowProc(ByVal hWnd As Long, _
lParam As FindWindowParameters) As Long
Dim strWindowTitle As String
strWindowTitle = Space(260)
Call GetWindowText(hWnd, strWindowTitle, 260)
strWindowTitle = TrimNull(strWindowTitle) ' Remove extra null terminator
If StrComp(Trim(strWindowTitle), Trim(lParam.strTitle)) = 0 Then
Count = Count + 1
ReDim Preserve lParam.hWnd(Count)
lParam.hWnd(Count) = hWnd 'Store the result for later.
EnumWindowProc = 0 'This will stop enumerating more windows
End If
EnumWindowProc = 1
End Function
Private Function TrimNull(strNullTerminatedString As String)
Dim lngPos As Long
'Remove unnecessary null terminator
lngPos = InStr(strNullTerminatedString, Chr$(0))
If lngPos Then
TrimNull = Left$(strNullTerminatedString, lngPos - 1)
Else
TrimNull = strNullTerminatedString
End If
End Function
Public Function FnSetForegroundWindow(strWindowTitle As String, STime As Long) As Boolean
Dim MyAppHWnd As Long
Dim CurrentForegroundThreadID As Long
Dim NewForegroundThreadID As Long
Dim lngRetVal As Long
Dim findSuccessful As Boolean
Dim blnSuccessful As Boolean
Dim I As Integer
findSuccessful = FnFindWindowLike(strWindowTitle)
If findSuccessful Then
For I = 0 To Count
MyAppHWnd = Parameters.hWnd(I)
If MyAppHWnd <> 0 Then
'We've found the application window by the caption
CurrentForegroundThreadID = GetWindowThreadProcessId(GetForegroundWindow(), ByVal 0&)
NewForegroundThreadID = GetWindowThreadProcessId(MyAppHWnd, ByVal 0&)
'AttachThreadInput is used to ensure SetForegroundWindow will work
'even if our application isn't currently the foreground window
'(e.g. an automated app running in the background)
Call AttachThreadInput(CurrentForegroundThreadID, NewForegroundThreadID, True)
lngRetVal = SetForegroundWindow(MyAppHWnd)
Call AttachThreadInput(CurrentForegroundThreadID, NewForegroundThreadID, False)
If lngRetVal <> 0 Then
'Now that the window is active, let's restore it from the taskbar
If IsIconic(MyAppHWnd) Then
Call ShowWindow(MyAppHWnd, SW_RESTORE)
Else
Call ShowWindow(MyAppHWnd, SW_SHOW)
End If
blnSuccessful = True
Else
MsgBox "Found the window, but failed to bring it to the foreground!"
End If
Else
'Failed to find the window caption
'Therefore the app is probably closed.
MsgBox "Application Window '" + strWindowTitle + "' not found!"
End If
If STime > 0 Then
Sleep STime
End If
Call ShowWindow(MyAppHWnd, SW_MINIMIZE)
Next I
End If
FnSetForegroundWindow = blnSuccessful
End Function
Sub Start()
'Application.ScreenUpdating = False
Dim WS As Worksheet
Set WS = Worksheets("Config")
Dim FinalRow As Integer
Dim AppName As String
Dim AppShowTime As Integer
Dim I As Integer
FinalRow = WS.Cells(65536, 2).End(xlUp).Row
Do While (1)
For I = 2 To FinalRow
AppName = WS.Cells(I, 1).Value
AppShowTime = WS.Cells(I, 2).Value
Call FnSetForegroundWindow(AppName, AppShowTime * 1000)
Next I
Loop
End Sub
I have below VBA script which does periodic display of windows configured. However, it is take very long time execute.
I would be oblidge to help me to execute this script fast.
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function SetForegroundWindow Lib "user32" _
(ByVal hWnd As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" _
(ByVal hWnd As Long, _
lpdwProcessId As Long) As Long
Private Declare Function IsIconic Lib "user32" _
(ByVal hWnd As Long) As Long
Private Declare Function ShowWindow Lib "user32" _
(ByVal hWnd As Long, _
ByVal nCmdShow As Long) As Long
Private Declare Function AttachThreadInput Lib "user32" _
(ByVal idAttach As Long, _
ByVal idAttachTo As Long, _
ByVal fAttach As Long) As Long
Private Declare Function GetForegroundWindow Lib "user32" _
() As Long
Private Const SW_RESTORE = 9
Private Const SW_SHOW = 5
Private Const SW_MINIMIZE = 2
Private Declare Function EnumWindows Lib "user32" _
(ByVal lpEnumFunc As Long, _
ByVal lParam As Long) As Long
Private Declare Function GetWindowText Lib "user32" _
Alias "GetWindowTextA" _
(ByVal hWnd As Long, _
ByVal lpString As String, _
ByVal cch As Long) As Long
'Custom structure for passing in the parameters in/out of the hook enumeration function
'Could use global variables instead, but this is nicer.
Private Type FindWindowParameters
strTitle As String 'INPUT
hWnd() As Long 'OUTPUT
End Type
Dim Parameters As FindWindowParameters
Dim Count As Integer
Public Function FnFindWindowLike(strWindowTitle As String) As Boolean
'We'll pass a custom structure in as the parameter to store our result...
Parameters.strTitle = strWindowTitle ' Input parameter
Count = -1
Call EnumWindows(AddressOf EnumWindowProc, VarPtr(Parameters))
If Count > -1 Then
FnFindWindowLike = True
Else
FnFindWindowLike = False
End If
End Function
Private Function EnumWindowProc(ByVal hWnd As Long, _
lParam As FindWindowParameters) As Long
Dim strWindowTitle As String
strWindowTitle = Space(260)
Call GetWindowText(hWnd, strWindowTitle, 260)
strWindowTitle = TrimNull(strWindowTitle) ' Remove extra null terminator
If StrComp(Trim(strWindowTitle), Trim(lParam.strTitle)) = 0 Then
Count = Count + 1
ReDim Preserve lParam.hWnd(Count)
lParam.hWnd(Count) = hWnd 'Store the result for later.
EnumWindowProc = 0 'This will stop enumerating more windows
End If
EnumWindowProc = 1
End Function
Private Function TrimNull(strNullTerminatedString As String)
Dim lngPos As Long
'Remove unnecessary null terminator
lngPos = InStr(strNullTerminatedString, Chr$(0))
If lngPos Then
TrimNull = Left$(strNullTerminatedString, lngPos - 1)
Else
TrimNull = strNullTerminatedString
End If
End Function
Public Function FnSetForegroundWindow(strWindowTitle As String, STime As Long) As Boolean
Dim MyAppHWnd As Long
Dim CurrentForegroundThreadID As Long
Dim NewForegroundThreadID As Long
Dim lngRetVal As Long
Dim findSuccessful As Boolean
Dim blnSuccessful As Boolean
Dim I As Integer
findSuccessful = FnFindWindowLike(strWindowTitle)
If findSuccessful Then
For I = 0 To Count
MyAppHWnd = Parameters.hWnd(I)
If MyAppHWnd <> 0 Then
'We've found the application window by the caption
CurrentForegroundThreadID = GetWindowThreadProcessId(GetForegroundWindow(), ByVal 0&)
NewForegroundThreadID = GetWindowThreadProcessId(MyAppHWnd, ByVal 0&)
'AttachThreadInput is used to ensure SetForegroundWindow will work
'even if our application isn't currently the foreground window
'(e.g. an automated app running in the background)
Call AttachThreadInput(CurrentForegroundThreadID, NewForegroundThreadID, True)
lngRetVal = SetForegroundWindow(MyAppHWnd)
Call AttachThreadInput(CurrentForegroundThreadID, NewForegroundThreadID, False)
If lngRetVal <> 0 Then
'Now that the window is active, let's restore it from the taskbar
If IsIconic(MyAppHWnd) Then
Call ShowWindow(MyAppHWnd, SW_RESTORE)
Else
Call ShowWindow(MyAppHWnd, SW_SHOW)
End If
blnSuccessful = True
Else
MsgBox "Found the window, but failed to bring it to the foreground!"
End If
Else
'Failed to find the window caption
'Therefore the app is probably closed.
MsgBox "Application Window '" + strWindowTitle + "' not found!"
End If
If STime > 0 Then
Sleep STime
End If
Call ShowWindow(MyAppHWnd, SW_MINIMIZE)
Next I
End If
FnSetForegroundWindow = blnSuccessful
End Function
Sub Start()
'Application.ScreenUpdating = False
Dim WS As Worksheet
Set WS = Worksheets("Config")
Dim FinalRow As Integer
Dim AppName As String
Dim AppShowTime As Integer
Dim I As Integer
FinalRow = WS.Cells(65536, 2).End(xlUp).Row
Do While (1)
For I = 2 To FinalRow
AppName = WS.Cells(I, 1).Value
AppShowTime = WS.Cells(I, 2).Value
Call FnSetForegroundWindow(AppName, AppShowTime * 1000)
Next I
Loop
End Sub