Related
When launching an .exe using .Run in VBA, a typical call may look like this:
x = wsh.Run(Command:="program.exe ""argument""", WindowStyle:=0, waitonreturn:=False)
Where windowStyle=0 should theoretically cause the program to run invisible to the user. But what if a pop-up window occurs within the .exe that you don't want to the user to see?
The windowStyle input will not suppress the appearance of warning messages or pop up windows declaring things like 'calculation complete' from appearing to the user, this often also pauses the code until the pop up is cleared. Clearing the window (i.e. clicking 'okay') in an automated manner is trivial (see this answer), but preventing it from appearing to the user to begin with is proving difficult to me as a relative beginner. (i.e. when the pop up is triggered by the .exe it is invisible to the user, and then closed automatically by the VBA code)
Currently I detect the existence of a new pop up window using this function (where sCaption is the name of the pop up window):
Private Function GetHandleFromPartialCaption(ByRef lWnd As Long, ByVal sCaption As String) As Boolean
Dim lhWndP As Long
Dim sStr As String
GetHandleFromPartialCaption = False
lhWndP = FindWindow(vbNullString, vbNullString) 'PARENT WINDOW
Do While lhWndP <> 0
sStr = String(GetWindowTextLength(lhWndP) + 1, Chr$(0))
GetWindowText lhWndP, sStr, Len(sStr)
sStr = Left$(sStr, Len(sStr) - 1)
If InStr(1, sStr, sCaption) > 0 Then
GetHandleFromPartialCaption = True
lWnd = lhWndP
Exit Do
End If
lhWndP = GetWindow(lhWndP, GW_HWNDNEXT)
Loop
End Function
Then close it automatically. But it still briefly flashes up on screen to the user. Ideally I'd like this VBA code to run in the background so the user can get on with other tasks whilst it runs, not being distracted by flashing boxes.
Is there a way to force all windows of program.exe, including pop ups, to be invisible whilst it is running?
For further information, see my previous question on how to close the pop up window, here. This thread concerns how to prevent its appearance to a user.
EDIT 1
SendKeys is temperamental, so I am using this looping code to kill the .exe when I detect the pop up window, therefore the .exe does not need to be in focus to close the pop up (closing the pop up kills the .exe in my case anyway):
....
Main Code Body
....
t = Now
waittime = Now + TimeValue("0:01:30") 'limit to run a single row of calculations
Do While t < waittime
If GetHandleFromPartialCaption(lhWndP, "Popup Window Text") = True Then
Set oServ = GetObject("winmgmts:")
Set cProc = oServ.ExecQuery("Select * from Win32_Process")
For Each oProc In cProc
If oProc.Name = "Program.exe" Then
errReturnCode = oProc.Terminate()
Marker2 = 1
Exit Do
End If
Next
Endif
Loop
....
Main Code Body Continues
....
where GetHandleFromPartialCaption() is the function above, finding the pop up window based on the sCaption argument. My code loops and searches constantly for the pop up whilst the .exe is running the calculation, and kills the .exe as soon as it appears. But it still flashes up to the user.
To run an application completely hidden, launch it in a different desktop with CreateProcess.
Here's an example executing a simple command line and waiting for the process to exit :
Option Explicit
Private Declare PtrSafe Function OpenDesktop Lib "user32.dll" Alias "OpenDesktopW" (ByVal lpszDesktop As LongPtr, ByVal dwFlags As Long, ByVal fInherit As Byte, ByVal dwDesiredAccess As Long) As LongPtr
Private Declare PtrSafe Function CreateDesktop Lib "user32.dll" Alias "CreateDesktopW" (ByVal lpszDesktop As LongPtr, ByVal lpszDevice As LongPtr, ByVal pDevmode As LongPtr, ByVal dwFlags As Long, ByVal dwDesiredAccess As Long, ByVal lpsa As LongPtr) As LongPtr
Private Declare PtrSafe Function CloseDesktop Lib "user32.dll" (ByVal hDesktop As LongPtr) As Long
Private Declare PtrSafe Function CreateProcess Lib "kernel32.dll" Alias "CreateProcessW" (ByVal lpApplicationName As LongPtr, ByVal lpCommandLine As LongPtr, ByVal lpProcessAttributes As LongPtr, ByVal lpThreadAttributes As LongPtr, ByVal bInheritHandles As Byte, ByVal dwCreationFlags As Long, ByVal lpEnvironment As LongPtr, ByVal lpCurrentDirectory As LongPtr, ByRef lpStartupInfo As STARTUPINFO, ByRef lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare PtrSafe Function WaitForSingleObject Lib "kernel32.dll" (ByVal hHandle As LongPtr, ByVal dwMilliseconds As Long) As Long
Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32.dll" (ByVal hProcess As LongPtr, ByRef lpExitCode As Long) As Long
Private Declare PtrSafe Function CloseHandle Lib "kernel32.dll" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function GetWindowText Lib "user32.dll" Alias "GetWindowTextW" (ByVal hwnd As LongPtr, ByVal lpString As LongPtr, ByVal nMaxCount As Long) As Long
Private Declare PtrSafe Function EnumDesktopWindows Lib "user32.dll" (ByVal hDesktop As LongPtr, ByVal lpfn As LongPtr, ByRef lParam As Any) As Long
Private Declare PtrSafe Function SendMessageW Lib "user32.dll" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Private Declare PtrSafe Function GetLastError Lib "kernel32.dll" () As Long
Private Type STARTUPINFO
cb As Long
lpReserved As LongPtr
lpDesktop As LongPtr
lpTitle As LongPtr
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As LongPtr
hStdInput As LongPtr
hStdOutput As LongPtr
hStdError As LongPtr
End Type
Private Type PROCESS_INFORMATION
hProcess As LongPtr
hThread As LongPtr
dwProcessID As Long
dwThreadID As Long
End Type
Public Sub UsageExample()
Dim exitCode As Long
exitCode = ExecuteHidden("cmd /C echo abcd > %USERPROFILE%\Desktop\output.txt", timeoutMs:=10000)
End Sub
Public Function ExecuteHidden(command As String, timeoutMs As Long) As Long
Dim si As STARTUPINFO, pi As PROCESS_INFORMATION, hDesktop As LongPtr, ex As Long
Const NORMAL_PRIORITY_CLASS& = &H20&, INFINITE& = &HFFFFFFFF, GENERIC_ALL& = &H10000000
On Error GoTo Catch
' get a virtual desktop '
si.lpDesktop = StrPtr("hidden-desktop")
hDesktop = OpenDesktop(si.lpDesktop, 0, 0, GENERIC_ALL)
If hDesktop Then Else hDesktop = CreateDesktop(si.lpDesktop, 0, 0, 0, GENERIC_ALL, 0)
If hDesktop Then Else Err.Raise GetLastError()
' run the command '
si.cb = LenB(si)
If CreateProcess(0, StrPtr(command), 0, 0, 1, NORMAL_PRIORITY_CLASS, 0, 0, si, pi) Then Else Err.Raise GetLastError()
' wait for exit '
If WaitForSingleObject(pi.hProcess, timeoutMs) Then Err.Raise 1000, , "Timeout while waiting for the process to exit"
If GetExitCodeProcess(pi.hProcess, ExecuteHidden) <> 0 Then Else Err.Raise GetLastError()
' cleanup '
Catch:
If pi.hThread Then CloseHandle pi.hThread
If pi.hProcess Then CloseHandle pi.hProcess
If hDesktop Then CloseDesktop hDesktop
If Err.Number Then Err.Raise Err.Number
End Function
And if you need to find a window in the desktop, use EnumDesktopWindows instead of EnumWindows:
Private Function FindWindow(ByVal hDesktop As LongPtr, title As String) As LongPtr
Dim hwnds As New Collection, hwnd, buffer$
buffer = Space$(1024)
EnumDesktopWindows hDesktop, AddressOf EnumDesktopWindowsProc, hwnds
For Each hwnd In hwnds
If Left$(buffer, GetWindowText(hwnd, StrPtr(buffer), Len(buffer))) Like title Then
FindWindow = hwnd
Exit Function
End If
Next
End Function
Private Function EnumDesktopWindowsProc(ByVal hwnd As LongPtr, hwnds As Collection) As Long
hwnds.Add hwnd
EnumDesktopWindowsProc = True
End Function
If you need to close a window, simply send WM_CLOSE to the main window or to a popup:
const WM_CLOSE& = &H10&
SendMessageW hwnd, WM_CLOSE, 0, 0
The short answer is to hide popups it is required to call ShowOwnedPopups(hwnd,0). The VBA declaration is given here
Declare Function ShowOwnedPopups Lib "user32" Alias "ShowOwnedPopups" _
(ByVal hwnd As Long, ByVal fShow As Long) As Long
For a longer answer with some experimental C# code investigating this see this blog post. I have copied first part of blog post into answer here for brevity.
Firstly, a key reading resource is Windows Features which tells that all windows are created with CreateWindowEx but popups are create by specifying WS_POPUP and child windows are created by specifying WS_CHILD. So popups and child windows are different.
On the same page in the section Window Visibility it explains that we can set the visibility of a main window and the change will cascade down to all child windows but there is no mention of this cascade affecting popups.
And here is some final VBA code but which depends upon a simple C# demo program called VisibilityExperiment
Option Explicit
Private Declare Function ShowOwnedPopups Lib _
"user32" (ByVal hwnd As Long, _
ByVal fShow As Long) As Long
Private Declare Function EnumWindows _
Lib "user32" ( _
ByVal lpEnumFunc As Long, _
ByVal lParam As Long) _
As Long
Private Declare Function GetWindowThreadProcessId _
Lib "user32" (ByVal hwnd As Long, lpdwprocessid As Long) As Long
Private mlPid As Long
Private mlHWnd As Variant
Private Function EnumAllWindows(ByVal hwnd As Long, ByVal lParam As Long) As Long
Dim plProcID As Long
GetWindowThreadProcessId hwnd, plProcID
If plProcID = mlPid Then
If IsEmpty(mlHWnd) Then
mlHWnd = hwnd
Debug.Print "HWnd:&" & Hex$(mlHWnd) & " PID:&" & Hex$(mlPid) & "(" & mlPid & ")"
End If
End If
EnumAllWindows = True
End Function
Private Function GetPID(ByVal sExe As String) As Long
Static oServ As Object
If oServ Is Nothing Then Set oServ = GetObject("winmgmts:\\.\root\cimv2")
Dim cProc As Object
Set cProc = oServ.ExecQuery("Select * from Win32_Process")
Dim oProc As Object
For Each oProc In cProc
If oProc.Name = sExe Then
Dim lPid As Long
GetPID = oProc.ProcessID
End If
Next
End Function
Private Sub Test()
Dim wsh As IWshRuntimeLibrary.WshShell
Set wsh = New IWshRuntimeLibrary.WshShell
Dim lWinStyle As WshWindowStyle
lWinStyle = WshNormalFocus
Dim sExe As String
sExe = "VisibilityExperiment.exe"
Dim sExeFullPath As String
sExeFullPath = Environ$("USERPROFILE") & "\source\repos\VisibilityExperiment\VisibilityExperiment\bin\Debug\" & sExe
Dim x As Long
x = wsh.Run(sExeFullPath, lWinStyle, False)
mlPid = GetPID(sExe)
mlHWnd = Empty
Call EnumWindows(AddressOf EnumAllWindows, 0)
Stop
Call ShowOwnedPopups(mlHWnd, 0) '* o to hide, 1 to show
End Sub
To repeat, to hide popups one must call ShowOwnedPopups(). Sadly, I cannot see around this restriction. Even if we tried to use the Windows API directly to spawn the process there is nothing in the STARTUPINFO structure (Windows) which looks like it will help, there is nothing to specify the visibility of popups.
How about:
Dim TaskID as Double
TaskID = Shell("program.exe", vbHide)
or if the window is not behaving as desired, try vbNormalNoFocus or vbMinimizedNoFocus.
If this isn't suitable for some reason, please share some more about what the .exe ... Perhaps redirected output could be an option.
More from MSDN.
Some interesting notes here (albeit for C#)
Redirecting standard Shell output
I assume you are unable to modify "program.exe" to use a different type of notification?
An alternative approach is to force Excel to stay "on top":
3 Best Ways to Force a Window to Stay on Top
A utility called "Always On Top"
How to keep Excel Window Always on Top, such as:
#If Win64 Then
Public Declare PtrSafe Function SetWindowPos _
Lib "user32" ( _
ByVal hwnd As LongPtr, _
ByVal hwndInsertAfter As LongPtr, _
ByVal x As Long, ByVal y As Long, _
ByVal cx As Long, ByVal cy As Long, _
ByVal wFlags As Long) _
As Long
#Else
Public Declare Function SetWindowPos _
Lib "user32" ( _
ByVal hwnd As Long, _
ByVal hwndInsertAfter As Long, _
ByVal x As Long, ByVal y As Long, _
ByVal cx As Long, ByVal cy As Long, _
ByVal wFlags As Long) _
As Long
#End If
Public Const SWP_NOSIZE = &H1
Public Const SWP_NOMOVE = &H2
Public Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2
Sub ShowXLOnTop(ByVal OnTop As Boolean)
Dim xStype As Long
#If Win64 Then
Dim xHwnd As LongPtr
#Else
Dim xHwnd As Long
#End If
If OnTop Then
xStype = HWND_TOPMOST
Else
xStype = HWND_NOTOPMOST
End If
Call SetWindowPos(Application.hwnd, xStype, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE)
End Sub
Sub SetXLOnTop()
ShowXLOnTop True
End Sub
Sub SetXLNormal()
ShowXLOnTop False
End Sub
My Code:
Sub login()
Dim IE As Object
Dim HTMLDoc As Object, HTMLDoc2 As Object, HTMLDoc3 As Object, HTMLDoc4 As Object, HTMLDoc5 As Object
Dim objCollection As Object
Dim intChoice As Integer
Dim strPath As String
Const navOpenInNewTab = &H800
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = True
IE.Navigate "https://www.abcd.com/CWRWeb/displayMemberLogin.do"
...............
Do While IE.Busy Or IE.ReadyState <> 4: Loop
Application.Wait (Now + TimeValue("00:0:03"))
IE.Navigate "https://www.abcd.com/CWRWeb/OnlineStmtResultsPremDis.do" 'Final PDF
Application.Wait (Now + TimeValue("00:0:03"))
Set HTMLDoc5 = IE.document
Application.SendKeys "+^{S}" 'Save Key ShortCut
Application.Wait (Now + TimeValue("00:0:03"))
'Finding the Save As Dialog Box
timeout = Now + TimeValue("00:00:30")
Do
hWnd = FindWindow(vbNullString, "Save As")
DoEvents
Sleep 200
Loop Until hWnd Or Now > timeout
If hWnd Then
hWnd = FindWindowEx(hWnd, 0, "Button", "&Save")
End If
If hWnd Then
SetForegroundWindow (hWnd)
Sleep 600
SendMessage hWnd, BM_CLICK, 0, 0
End If
End Sub
My declaration in another module is:
Option Explicit
Public Declare PtrSafe Sub Sleep Lib "kernel32" _
(ByVal dwMilliseconds As Long)
Public Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Public Declare PtrSafe Function FindWindowEx Lib "user32" _
Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, _
ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
Public Declare PtrSafe Function SendMessage Lib "user32" (ByVal hWnd As LongPtr, ByVal wMsg As Long, _
ByVal wParam As LongPtr, lParam As Any) As LongPtr
Public Declare PtrSafe Function SetForegroundWindow Lib "user32" _
(ByVal hWnd As Long) As LongPtr
Public Declare PtrSafe Function SendMessageByString Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As LongPtr
Public Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As LongPtr
Public Declare PtrSafe Sub keybd_event Lib "user32" _
(ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Public Const BM_CLICK = &HF5
Public Const WM_SETTEXT = &HC
Public Const WM_GETTEXT = &HD
Public Const WM_GETTEXTLENGTH = &HE
Public Const VK_KEYDOWN = &H0
Public Const VK_KEYUP = &H2
Public Const VK_CONTROL = &H11
I debugged and found that I am able to get the same Hwnd for FindWindow and FindWindowEx but the SendMessage function gives a run time error453:
Cant find DLL entry point SendMessage in User32
Perhaps a Find Window could work?
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
'Declare this at the top of the module!
... your routine until the save as dialog is shown
Call iDetectScreen("Save As","Save As not found!")
... After detection what should do (Personally I'd do a send keys Enter)
...
Sub iDetectScreen(iScreen As String, iWriteErr As Integer)
Do Until lHnd1 > 0
lHnd1 = FindWindow(vbNullString, iScreen)
If i < 5 Then
Application.Wait (Now() + TimeValue("00:00:01"))
i = i + 1
Else
msgbox iWriteErr,vbCritical
'window save didn't show 5 secs after supposed to
End Sub
EDIT:
This should work. Tested in x64 2013, fit to your needs.
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
'Declare this at the top of the module!
Sub iDetectScreen(iScreen As String, iWriteErr As String)
Do Until lHnd1 > 0
lHnd1 = FindWindow(vbNullString, iScreen)
If i < 5 Then
Application.Wait (Now() + TimeValue("00:00:01"))
i = i + 1
Else
MsgBox iWriteErr, vbCritical
Exit Sub
'window save didn't show 5 secs after supposed to
End If
Loop
End Sub
Sub SendEnter()
Call iDetectScreen("Save As", "Save As not found!")
AppActivate "Save As"
Application.Wait (Now() + TimeValue("00:00:01"))
Application.SendKeys ("~")
End Sub
In your sub
...
Set HTMLDoc5 = IE.document
Application.SendKeys "+^{S}" 'Save Key ShortCut
call SendEnter
...
How do you make an outlook reminder popup and stay on top of other windows?
After looking online for a long while; I wasn't able to find a satisfactory answer to this question.
Using Windows 7 and Microsoft Outlook 2007+; when a reminder flashes up, it no longer gives a modal box to grab your attention. At work where additional plugins can be problematic to install (admin rights) and when using a quiet system, meeting requests are often overlooked.
Is there an easier way to implement this without using third party plugins/apps?
Sep 2021: Updated question title to indicate modal popup
For the latest macro please see update 4 (Office 365 inclusion)
After searching for a while I found a partial answer on a website that seemed to give me the majority of the solution;
https://superuser.com/questions/251963/how-to-make-outlook-calendar-reminders-stay-on-top-in-windows-7
However as noted in the comments, the first reminder failed to popup; while further reminders then did. based on the code I assumed this was because the window wasn't detected until it had instantiated once
To get around this, I looked to employ a timer to periodically test if the window was present and if it was, then bring it to the front.
Taking the code from the following website; Outlook VBA - Run a code every half an hour
Then melding the two solutions together gave a working solution to this problem.
From the trust centre, I enabled the use of macros then opening the visual basic editor from Outlook (alt+F11) I added the following code to the 'ThisOutlookSession' module
CODE REMOVED
UPDATE 1 (Feb 12, 2015)
After using this for a while I found a real annoyance with the fact that triggering the timer removes the focus from the current window. It's a massive hassle as you're writing an e-mail.
As such I upgraded the code so that the timer only runs every 60 seconds then upon finding the first active reminder, the timer is stopped and the secondary event function is then used forthwith to activate the window focus change.
UPDATE 2 (Sep 4, 2015)
Having transitioned to Outlook 2013 - this code stopped working for me. I have now updated it with a further function (FindReminderWindow) that looks for a range of popup reminder captions. This now works for me in 2013 and should work for versions below 2013.
The FindReminderWindow function takes a value which is the number of iterations to step through to find the window. If you routinely have a larger number of reminders than 10 popup then you could increase this number in the EventMacro sub...
CODE REMOVED
UPDATE 3 (Aug 8, 2016)
Having rethought my approach and based on observation - I redesigned the code to try and have a minimal impact on working while Outlook was open; I would find the timer still took focus away from e-mails I was writing and possibly other issues with windows losing focus might have been related.
Instead - I assumed the reminders window once instantiated was merely hidden and not destroyed when reminders were shown; as such I now keep a global handle to the window so I should only need to look once at the window titles and subsequently check if the reminders window is visible before making it modal.
Also - the timer is now only employed when the reminders window is triggered, then turned off once the function has run; hopefully stopping any intrusive macro's running during the working day.
See which one works for you I guess...
Updated code below:
Add the following code to the 'ThisOutlookSession' module
Private WithEvents MyReminders As Outlook.Reminders
Private Sub Application_Startup()
On Error Resume Next
Set MyReminders = Outlook.Application.Reminders
End Sub
Private Sub MyReminders_ReminderFire(ByVal ReminderObject As Reminder)
On Error Resume Next
Call ActivateTimer(1)
End Sub
Then the updated module code...
Option Explicit
Private Declare Function SetTimer Lib "User32" (ByVal hWnd As Long, ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByVal lpTimerfunc As Long) As Long
Private Declare Function KillTimer Lib "User32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function IsWindowVisible 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 ShowWindow Lib "User32" (ByVal hWnd As Long, ByVal nCmdSHow As Long) As Long
Private Declare Function SetWindowPos Lib "User32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, _
ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const FLAGS As Long = SWP_NOMOVE Or SWP_NOSIZE
Private Const HWND_TOPMOST = -1
Public TimerID As Long 'Need a timer ID to turn off the timer. If the timer ID <> 0 then the timer is running
Public hRemWnd As Long 'Store the handle of the reminder window
Public Sub ActivateTimer(ByVal Seconds As Long) 'The SetTimer call accepts milliseconds
On Error Resume Next
If TimerID <> 0 Then Call DeactivateTimer 'Check to see if timer is running before call to SetTimer
If TimerID = 0 Then TimerID = SetTimer(0, 0, Seconds * 1000, AddressOf TriggerEvent)
End Sub
Public Sub DeactivateTimer()
On Error Resume Next
Dim Success As Long: Success = KillTimer(0, TimerID)
If Success <> 0 Then TimerID = 0
End Sub
Public Sub TriggerEvent(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idevent As Long, ByVal Systime As Long)
Call EventFunction
End Sub
Public Function EventFunction()
On Error Resume Next
If TimerID <> 0 Then Call DeactivateTimer
If hRemWnd = 0 Then hRemWnd = FindReminderWindow(100)
If IsWindowVisible(hRemWnd) Then
ShowWindow hRemWnd, 1 ' Activate Window
SetWindowPos hRemWnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS ' Set Modal
End If
End Function
Public Function FindReminderWindow(iUB As Integer) As Long
On Error Resume Next
Dim i As Integer: i = 1
FindReminderWindow = FindWindow(vbNullString, "1 Reminder")
Do While i < iUB And FindReminderWindow = 0
FindReminderWindow = FindWindow(vbNullString, i & " Reminder(s)")
i = i + 1
Loop
If FindReminderWindow <> 0 Then ShowWindow FindReminderWindow, 1
End Function
UPDATE 4 (Sep 9, 2021)
Transition to Office 365: This comes with an option in the settings now to show reminders on top of windows (picture below), so why would you want to run a macro to place it on top now? The reason is that you can set it as a modal reminder box (using SWP_DRAWFRAME) so if you swap between programs, it will stay visible which doesn't happen with the vanilla option
Code should be compatible with all Outlook versions and allow transition between them easily (however I can no longer error check the non-VBA7 code)
In ThisOutlookSession
Private WithEvents MyReminders As Outlook.Reminders
Private Sub Application_Startup()
On Error Resume Next
With Outlook.Application
Set MyReminders = .Reminders
End With
End Sub
Private Sub MyReminders_ReminderFire(ByVal ReminderObject As Reminder)
On Error Resume Next
Call ReminderStartTimer
End Sub
In a module
Option Explicit
' https://jkp-ads.com/articles/apideclarations.asp; useful resource for Declare functions
Private Const SWP_NOSIZE = &H1, SWP_NOMOVE = &H2, SWP_NOACTIVATE = &H10, SWP_DRAWFRAME = &H20, HWND_TOPMOST = -1, GW_HWNDNEXT = 2
Private Const FLAGS As Long = SWP_NOMOVE Or SWP_NOSIZE Or SWP_DRAWFRAME
#If VBA7 Then
Private Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As LongPtr, ByVal lpString As String, ByVal cch As LongPtr) As Long
Private Declare PtrSafe Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function GetWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal wCmd As Long) As LongPtr
Private Declare PtrSafe Function IsWindowVisible Lib "user32" (ByVal hWnd As LongPtr) As Boolean
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal nCmdShow As Long) As Boolean
Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hWnd As LongPtr, ByVal hWndInsertAfter As LongPtr, _
ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
#Else
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 Long
Private Declare Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function ShowWindow Lib "User32" (ByVal hWnd As Long, ByVal nCmdSHow As Long) As Long
Private Declare Function SetWindowPos Lib "User32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, _
ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
#End If
#If VBA7 Then
Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, _
ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
#End If
#If VBA7 Then
'TimerIDs to turn off timers. If a TimerID <> 0 then the timer is running
Public ReminderTimerID As LongPtr
Public Function ReminderStartTimer()
On Error Resume Next
Call ActivateTimer(1, AddressOf ReminderEvent, ReminderTimerID)
End Function
Public Sub ReminderEvent(ByVal hWnd As LongPtr, ByVal uMsg As LongPtr, ByVal idevent As LongPtr, ByVal Systime As LongPtr)
On Error Resume Next
Call EventFunction
End Sub
Private Function EventFunction()
On Error Resume Next
If ReminderTimerID <> 0 Then Call DeactivateTimer(ReminderTimerID)
Dim hRemWnd As LongPtr: FindWindowFromPartialCaption hRemWnd, "Reminder"
If IsWindowVisible(hRemWnd) Then
'ShowWindow hRemWnd, 1 ' Activate Window
SetWindowPos hRemWnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS ' Set Modal
End If
Debug.Print TimeInMS() & "; " & hRemWnd
End Function
Private Function FindWindowFromPartialCaption(ByRef hWnd As LongPtr, ByVal PartialCaption As String)
Dim hWndP As LongPtr: hWndP = FindWindow(vbNullString, vbNullString) 'Parent Window
Do While hWndP <> 0
If InStr(GetNameFromHwnd(hWndP), PartialCaption) > 0 Then hWnd = hWndP
If hWnd = hWndP Then Exit Do
hWndP = GetWindow(hWndP, GW_HWNDNEXT)
Loop
End Function
Private Function GetNameFromHwnd(ByRef hWnd As LongPtr) As String
Dim Title As String * 255
GetWindowText hWnd, Title, 255
GetNameFromHwnd = Left(Title, GetWindowTextLength(hWnd))
End Function
Private Function ActivateTimer(ByVal Seconds As Long, FunctionAddress As LongLong, ByRef TimerID As LongPtr) 'The SetTimer call accepts milliseconds
On Error Resume Next
If TimerID = 0 Then TimerID = SetTimer(0, 0, Seconds * 1000, FunctionAddress) 'Check to see if timer is running before call to SetTimer
End Function
Private Function DeactivateTimer(ByRef TimerID As LongLong)
On Error Resume Next
If KillTimer(0&, TimerID) <> 0 Then TimerID = 0
End Function
#Else
'TimerIDs to turn off timers. If a TimerID <> 0 then the timer is running
Public ReminderTimerID As Long
Public Function ReminderStartTimer()
On Error Resume Next
Call ActivateTimer(1, AddressOf ReminderEvent, ReminderTimerID)
End Function
Public Sub ReminderEvent(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idevent As Long, ByVal Systime As Long)
Call EventFunction
End Sub
Private Function ActivateTimer(ByVal Seconds As Long, FunctionAddress As Long, ByRef TimerID As Long) 'The SetTimer call accepts milliseconds
On Error Resume Next
If TimerID = 0 Then TimerID = SetTimer(0, 0, Seconds * 1000, FunctionAddress) 'Check to see if timer is running before call to SetTimer
End Function
Private Function DeactivateTimer(ByRef TimerID As Long)
On Error Resume Next
If KillTimer(0, TimerID) <> 0 Then TimerID = 0
End Function
Private Function EventFunction()
On Error Resume Next
If ReminderTimerID <> 0 Then Call DeactivateTimer(ReminderTimerID)
Dim hRemWnd As Long: FindWindowFromPartialCaption hRemWnd, "Reminder"
If IsWindowVisible(hRemWnd) Then
'ShowWindow hRemWnd, 1 ' Activate Window
SetWindowPos hRemWnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS ' Set Modal
End If
Debug.Print TimeInMS() & "; " & hRemWnd
End Function
Private Function FindWindowFromPartialCaption(ByRef hWnd As Long, ByVal PartialCaption As String)
Dim hWndP As Long: hWndP = FindWindow(vbNullString, vbNullString) 'Parent Window
Do While hWndP <> 0
If InStr(GetNameFromHwnd(hWndP), PartialCaption) > 0 Then hWnd = hWndP
If hWnd = hWndP Then Exit Do
hWndP = GetWindow(hWndP, GW_HWNDNEXT)
Loop
End Function
Private Function GetNameFromHwnd(ByRef hWnd As Long) As String
Dim Title As String * 255
GetWindowText hWnd, Title, 255
GetNameFromHwnd = Left(Title, GetWindowTextLength(hWnd))
End Function
#End If
Private Function TimeInMS() As String
Dim TimeNow As Double: TimeNow = Timer
TimeInMS = Format(Date, "dd/mm/yyyy ") & Format(DateAdd("s", TimeNow, 0), "hh:mm:ss.") & Right(Format(TimeNow, "#0.00"), 2)
End Function
Using AutoHotKey you can set the window to be Always On Top without stealing focus of the current window. (Tested with WIn10 / Outlook 2013)
TrayTip Script, Looking for Reminder window to put on top, , 16
SetTitleMatchMode 2 ; windows contains
loop {
WinWait, Reminder(s),
WinSet, AlwaysOnTop, on, Reminder(s)
WinRestore, Reminder(s)
TrayTip Outlook Reminder, You have an outlook reminder open, , 16
WinWaitClose, Reminder(s), ,30
}
I've found a free program called PinMe! that will do exactly what I want. When your Outlook Reminder appears, right click on PinMe! in the system tray and select the Reminder window. This will place a lock icon next to the window. Go ahead Dismiss or Snooze your Reminder. The next time the reminder pops, it should appear in the front of every other window. This will work regardless of Outlook in the foreground or minimized.
After being inspired by Eric Labashosky's answer, I took his concept a step further and created the NotifyWhenMicrosoftOutlookReminderWindowIsOpen app, which you can download for free. It is a small executable that can ensure the Outlook Reminders window appears on top of other windows, as well as has some other optional ways of alerting the user that the window has opened.
I have Office 2013 and Windows 8.1 Pro. Many macros I found weren't handling the variable nature of the title Outlook places on the Reminder dialog. When you have 1 reminder, the title is "1 Reminder(s)" etc. I created a simple windows forms application in VB.NET, which I load on startup and keep minimized to the system tray. There is a 60 Timer added to the form which triggers the active code. When there is more than 0 reminders, the dialog box will be set to topmost and moved to 0,0.
Here is the code:
Imports System.Runtime.InteropServices
Imports System.Text
Module Module1
<DllImport("user32.dll", SetLastError:=True, CharSet:=CharSet.Auto)>
Public Function FindWindowEx(ByVal parentHandle As IntPtr, ByVal childAfter As IntPtr, ByVal lclassName As String, ByVal windowTitle As String) As IntPtr
End Function
<DllImport("user32.dll", SetLastError:=True)> _
Public Function SetWindowPos(ByVal hWnd As IntPtr, ByVal hWndInsertAfter As IntPtr, ByVal X As Integer, ByVal Y As Integer, ByVal cx As Integer, ByVal cy As Integer, ByVal uFlags As Integer) As Boolean
End Function
<DllImport("user32.dll", SetLastError:=True, CharSet:=CharSet.Auto)> _
Public Function GetWindowText(ByVal hwnd As IntPtr, ByVal lpString As StringBuilder, ByVal cch As Integer) As Integer
End Function
End Module
Public Class Form1
Private Sub Timer1_Tick(sender As Object, e As EventArgs) Handles Timer1.Tick
Dim titleString As String = ""
Dim nullHandle As New IntPtr
Dim windowHandle As New IntPtr
Dim titleLength As Long
Try
Do
Dim sb As New StringBuilder
sb.Capacity = 512
Dim prevHandle As IntPtr = windowHandle
windowHandle = FindWindowEx(nullHandle, prevHandle, "#32770", vbNullString)
If windowHandle <> 0 And windowHandle <> nullHandle Then
titleLength = GetWindowText(windowHandle, sb, 256)
If titleLength > 0 Then
titleString = sb.ToString
Dim stringPos As Integer = InStr(titleString, "Reminde", CompareMethod.Text)
If stringPos Then
Dim reminderCount As Integer = Val(Mid(titleString, 1, 2))
If reminderCount > 0 Then
Dim baseWindow As IntPtr = -1 '-1 is the topmost position
SetWindowPos(windowHandle, baseWindow, 0, 0, 100, 100, &H41)
End If
Exit Sub
End If
End If
Else
Exit Sub
End If
Loop
Catch ex As Exception
MsgBox(ex.Message.ToString)
End Try
End Sub
Private Sub ToolStripMenuItem1_Click(sender As Object, e As EventArgs) Handles ToolStripMenuItem1.Click
Me.Close()
End Sub
Private Sub Form1_Shown(sender As Object, e As EventArgs) Handles Me.Shown
Me.Hide()
End Sub
End Class
Outlook 2016 now provides an option to "Show reminders on top of other windows". Use File > Options > Advanced, and then use the checkbox in the Reminders section. See this support.office.com page for screenshot. This option was added in Version 1804 of Outlook 2016, released to the "monthly channel" on April 25, 2018.
This Outlook 2016 option puts the reminder on top of all apps only initially. I like to keep the reminder on top until I explicitly dismiss, even if I click some other window. To keep the reminder on top I highly recommend using the app in #deadlydog's answer. #Tragamor's accepted answer on this question also works to keep on top, and I used it for years, but much more complicated compared to the app by #deadlydog.
This should work in different Outlook versions even if I tested it only on Outlook 2013.
Since I cannot test it in a localized English version, you may need to customize the code lines related to searching the reminders window even if, in my answer, I changed the related code lines in order to find the window in the English localized version.
Let me know if the macro works in your English Outlook version.
The user is free to minimize or close the reminders window in which cases, when a new or existing reminder fires, the reminders window will be topmost and not activated.
The reminders window title will be always updated reflecting the real number of visible reminders even without activating it.
In all cases the reminders window will never steal focus unless, obviously, the foreground window is the reminders window, that is unless the user has deliberately selected the reminders window.
This macro, other than making the reminders window topmost, will also select the most recent reminder in the reminder window itself, you can customize this behavior, please read the code in order to be able to do that.
The macro also flashes the reminders window when showing the window for the first time and whenever a new or existing reminder fires again.
You can customize how many times the window flashes or any other parameters related to it, it should be clear how to do that.
Paste the next code lines into the class module 'ThisOutlookSession':
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, _
ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function FlashWindowEx Lib "user32" (FWInfo As FLASHWINFO) As Boolean
Private Const FLASHW_STOP = 0
Private Const FLASHW_CAPTION = 1
Private Const FLASHW_TRAY = 2
Private Const FLASHW_ALL = FLASHW_CAPTION Or FLASHW_TRAY
Private Const FLASHW_TIMER = 4
Private Const FLASHW_TIMERNOFG = 12
Private Type FLASHWINFO
cbSize As Long
hwnd As Long
dwFlags As Long
uCount As Long
dwTimeout As Long
End Type
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private Const HWND_TOP = 0
Private Const HWND_BOTTOM = 1
Private Const SWP_NOSIZE = 1
Private Const SWP_NOMOVE = 2
Private Const SWP_NOACTIVATE = 16
Private Const SWP_DRAWFRAME = 32
Private Const SWP_NOOWNERZORDER = 512
Private Const SWP_NOZORDER = 4
Private Const SWP_SHOWWINDOW = 64
Private Existing_reminders_window As Boolean
Private WithEvents Rmds As Reminders
Public Reminders_window As Long
Private Sub Application_Reminder(ByVal Item As Object)
If Existing_reminders_window = False Then
Set Rmds = Application.Reminders
'In order to create the reminders window
ActiveExplorer.CommandBars.ExecuteMso ("ShowRemindersWindow")
Reminders_window = FindWindow("#32770", "0 Reminder(s)")
If Reminders_window = 0 Then
Reminders_window = FindWindow("#32770", "0 Reminder")
If Reminders_window = 0 Then
Reminders_window = FindWindow("#32770", "0 Reminder ")
End If
End If
'To prevent stealing focus in case Outlook was in the foreground
ShowWindow Reminders_window, 0
SetWindowPos Reminders_window, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE Or SWP_NOACTIVATE
Existing_reminders_window = True
End If
End Sub
Private Sub Rmds_BeforeReminderShow(Cancel As Boolean)
Dim FWInfo As FLASHWINFO
If Existing_reminders_window = True Then
Cancel = True
With FWInfo
.cbSize = 20
.hwnd = Reminders_window
.dwFlags = FLASHW_CAPTION
.uCount = 4
.dwTimeout = 0
End With
'In case the reminders window was not the highest topmost. This will not work on Windows 10 if the task manager window is topmost, the task manager and some other system windows have special z position
SetWindowPos Reminders_window, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE Or SWP_NOACTIVATE
ShowWindow Reminders_window, 4
Select_specific_reminder
FlashWindowEx FWInfo
End If
End Sub
Paste the next code lines into a new or existing standard module:
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function EnumChildWindows Lib "user32" (ByVal hWndParent As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Private Const WM_CHAR = &H102
Private Const VK_HOME = &H24
Private Const VK_END = &H23
Private Const WM_KEYDOWN = &H100
Private Const WM_KEYUP = &H101
Public Sub Select_specific_reminder()
Dim Retval As Long
Retval = EnumChildWindows(ThisOutlookSession.Reminders_window, AddressOf EnumChildProc, 0)
End Sub
Private Function EnumChildProc(ByVal hwnd As Long, ByVal lParam As Long) As Long
Dim Nome_classe As String
Nome_classe = Space$(256)
GetClassName hwnd, Nome_classe, 256
If InStr(Nome_classe, "SysListView32") Then
'You can customize the next code line in order to select a specific reminder
SendMessage hwnd, WM_KEYDOWN, VK_HOME, ByVal 0&
End If
EnumChildProc = 1
End Function
The latest Outlook has this feature inbuilt and the same is answered in https://superuser.com/a/1327856/913992
Just Alt F11 and copy paste this code..Works for me
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
Private Const GW_HWNDNEXT = 2
Private Declare PtrSafe Function FindWindowA Lib "User32" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function SetWindowPos Lib "User32" ( _
ByVal hWnd As Long, ByVal hWndInsertAfter As Long, _
ByVal X As Long, ByVal Y As Long, ByVal cx As Long, _
ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const FLAGS As Long = SWP_NOMOVE Or SWP_NOSIZE
Private Const HWND_TOPMOST = -1
Private Sub Application_Reminder(ByVal Item As Object)
Dim ReminderWindowHWnd As Variant
On Error Resume Next
Dim lhWndP As Long
If GetHandleFromPartialCaption(lhWndP, "Reminder") = True Then
SetWindowPos lhWndP, HWND_TOPMOST, 0, 0, 0, 0, FLAGS
End If
End Sub
Private Function GetHandleFromPartialCaption(ByRef lWnd As Long, ByVal sCaption As String) As Boolean
Dim lhWndP As Long
Dim sStr As String
GetHandleFromPartialCaption = False
lhWndP = FindWindow(vbNullString, vbNullString) 'PARENT WINDOW
Do While lhWndP <> 0
sStr = String(GetWindowTextLength(lhWndP) + 1, Chr$(0))
GetWindowText lhWndP, sStr, Len(sStr)
sStr = Left$(sStr, Len(sStr) - 1)
If InStr(1, sStr, sCaption) > 0 Then
GetHandleFromPartialCaption = True
lWnd = lhWndP
Exit Do
End If
lhWndP = GetWindow(lhWndP, GW_HWNDNEXT)
Loop
End Function
How can i unprotect my VB project from a vb macro ?
i have found this code:
Sub UnprotectVBProject(ByRef WB As Workbook, ByVal Password As String)
Dim VBProj As Object
Set VBProj = WB.VBProject
Application.ScreenUpdating = False
'Ne peut procéder si le projet est non-protégé.
If VBProj.Protection <> 1 Then Exit Sub
Set Application.VBE.ActiveVBProject = VBProj
'Utilisation de "SendKeys" Pour envoyer le mot de passe.
SendKeys Password & "~"
SendKeys "~"
'MsgBox "Après Mot de passe"
Application.VBE.CommandBars(1).FindControl(ID:=2578, recursive:=True).Execute
Application.Wait (Now + TimeValue("0:00:1"))
End Sub
But this solution doesn't work for Excel 2007. It display the authentification's window and print password in my IDE.
Then, my goal is to unprotect my VBproject without displaying this window.
Thanks for any help.
EDIT:
Converted this to a BLOG post for VBA and VB.Net.
I have never been in favor of Sendkeys. They are reliable in some case but not always. I have a soft corner for API's though.
What you want can be achieved, however you have to ensure that workbook for which you want to un-protect the VBA has to be opened in a separate Excel Instance.
Here is an example
Let's say we have a workbook who's VBA project looks like this currently.
LOGIC:
Find the Handle of the "VBAProject Password" window using FindWindow
Once that is found, find the handle of the Edit Box in that window using FindWindowEx
Once the handle of the Edit Box is found, simply use SendMessage to write to it.
Find the handle of the Buttons in that window using FindWindowEx
Once the handle of the OK button is found, simply use SendMessage to click it.
RECOMMENDATION:
For API's THIS is the best link I can recommend.
If you wish to become good at API's like FindWindow, FindWindowEx and SendMessage then get a tool that gives you a graphical view of the system’s processes, threads, windows, and window messages. For Ex: uuSpy or Spy++.
Here is what Spy++ will show you for "VBAProject Password" window
TESTING:
Open a new Excel instance and paste the below code in a module.
CODE:
I have commented the code so you shouldn't have any problem understanding it.
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, _
ByVal lpsz2 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 SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Dim Ret As Long, ChildRet As Long, OpenRet As Long
Dim strBuff As String, ButCap As String
Dim MyPassword As String
Const WM_SETTEXT = &HC
Const BM_CLICK = &HF5
Sub UnlockVBA()
Dim xlAp As Object, oWb As Object
Set xlAp = CreateObject("Excel.Application")
xlAp.Visible = True
'~~> Open the workbook in a separate instance
Set oWb = xlAp.Workbooks.Open("C:\Sample.xlsm")
'~~> Launch the VBA Project Password window
'~~> I am assuming that it is protected. If not then
'~~> put a check here.
xlAp.VBE.CommandBars(1).FindControl(ID:=2578, recursive:=True).Execute
'~~> Your passwword to open then VBA Project
MyPassword = "Blah Blah"
'~~> Get the handle of the "VBAProject Password" Window
Ret = FindWindow(vbNullString, "VBAProject Password")
If Ret <> 0 Then
'MsgBox "VBAProject Password Window Found"
'~~> Get the handle of the TextBox Window where we need to type the password
ChildRet = FindWindowEx(Ret, ByVal 0&, "Edit", vbNullString)
If ChildRet <> 0 Then
'MsgBox "TextBox's Window Found"
'~~> This is where we send the password to the Text Window
SendMess MyPassword, ChildRet
DoEvents
'~~> Get the handle of the Button's "Window"
ChildRet = FindWindowEx(Ret, ByVal 0&, "Button", vbNullString)
'~~> Check if we found it or not
If ChildRet <> 0 Then
'MsgBox "Button's Window Found"
'~~> Get the caption of the child window
strBuff = String(GetWindowTextLength(ChildRet) + 1, Chr$(0))
GetWindowText ChildRet, strBuff, Len(strBuff)
ButCap = strBuff
'~~> Loop through all child windows
Do While ChildRet <> 0
'~~> Check if the caption has the word "OK"
If InStr(1, ButCap, "OK") Then
'~~> If this is the button we are looking for then exit
OpenRet = ChildRet
Exit Do
End If
'~~> Get the handle of the next child window
ChildRet = FindWindowEx(Ret, ChildRet, "Button", vbNullString)
'~~> Get the caption of the child window
strBuff = String(GetWindowTextLength(ChildRet) + 1, Chr$(0))
GetWindowText ChildRet, strBuff, Len(strBuff)
ButCap = strBuff
Loop
'~~> Check if we found it or not
If OpenRet <> 0 Then
'~~> Click the OK Button
SendMessage ChildRet, BM_CLICK, 0, vbNullString
Else
MsgBox "The Handle of OK Button was not found"
End If
Else
MsgBox "Button's Window Not Found"
End If
Else
MsgBox "The Edit Box was not found"
End If
Else
MsgBox "VBAProject Password Window was not Found"
End If
End Sub
Sub SendMess(Message As String, hwnd As Long)
Call SendMessage(hwnd, WM_SETTEXT, False, ByVal Message)
End Sub
I know you've locked this for new answers but I had a few issues with the above code, principally that I'm working in Office 64-bit (VBA7). However I also made it so the code would work in the current instance of Excel and added a bit more error checking and formatted it up to be pasted into a separate module with only the method UnlockProject exposed.
For full disclosure I really started with the code in this post although it's a variant on a theme.
The code also shows conditional compilation constants so that it ought to be compatible with both 32-bit and 64-bit flavours of Excel at the same time. I used this page to help me with figuring this out.
Anyways here's the code. Hope someone finds it useful:
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hwndParent As LongPtr, ByVal hwndChildAfter As LongPtr, ByVal lpszClass As String, ByVal lpszWindow As String) As LongPtr
Private Declare PtrSafe Function GetParent Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
Private Declare PtrSafe Function GetDlgItem Lib "user32" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr ' nIDDlgItem = int?
Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal Msg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare PtrSafe Function SetFocusAPI Lib "user32" Alias "SetFocus" (ByVal hWnd As LongPtr) As LongPtr
Private Declare PtrSafe Function LockWindowUpdate Lib "user32" (ByVal hWndLock As LongPtr) As Long
Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal uIDEvent As LongPtr) As Long
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hwndParent As Long, ByVal hwndChildAfter As Long, ByVal lpszClass As String, ByVal lpszWindow As String) As Long
Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long ' nIDDlgItem = int?
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function SetFocusAPI Lib "user32" Alias "SetFocus" (ByVal hWnd As Long) As Long
Private Declare Function LockWindowUpdate Lib "user32" (ByVal hWndLock As Long) As Long
Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal uIDEvent As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
Private Const WM_CLOSE As Long = &H10
Private Const WM_GETTEXT As Long = &HD
Private Const EM_REPLACESEL As Long = &HC2
Private Const EM_SETSEL As Long = &HB1
Private Const BM_CLICK As Long = &HF5&
Private Const TCM_SETCURFOCUS As Long = &H1330&
Private Const IDPassword As Long = &H155E&
Private Const IDOK As Long = &H1&
Private Const TimeoutSecond As Long = 2
Private g_ProjectName As String
Private g_Password As String
Private g_Result As Long
#If VBA7 Then
Private g_hwndVBE As LongPtr
Private g_hwndPassword As LongPtr
#Else
Private g_hwndVBE As Long
Private g_hwndPassword As Long
#End If
Sub Test_UnlockProject()
Select Case UnlockProject(ActiveWorkbook.VBProject, "Test")
Case 0: MsgBox "The project was unlocked"
Case 2: MsgBox "The active project was already unlocked"
Case Else: MsgBox "Error or timeout"
End Select
End Sub
Public Function UnlockProject(ByVal Project As Object, ByVal Password As String) As Long
#If VBA7 Then
Dim lRet As LongPtr
#Else
Dim lRet As Long
#End If
Dim timeout As Date
On Error GoTo ErrorHandler
UnlockProject = 1
' If project already unlocked then no need to do anything fancy
' Return status 2 to indicate already unlocked
If Project.Protection <> vbext_pp_locked Then
UnlockProject = 2
Exit Function
End If
' Set global varaibles for the project name, the password and the result of the callback
g_ProjectName = Project.Name
g_Password = Password
g_Result = 0
' Freeze windows updates so user doesn't see the magic happening :)
' This is dangerous if the program crashes as will 'lock' user out of Windows
' LockWindowUpdate GetDesktopWindow()
' Switch to the VBE
' and set the VBE window handle as a global variable
Application.VBE.MainWindow.Visible = True
g_hwndVBE = Application.VBE.MainWindow.hWnd
' Run 'UnlockTimerProc' as a callback
lRet = SetTimer(0, 0, 100, AddressOf UnlockTimerProc)
If lRet = 0 Then
Debug.Print "error setting timer"
GoTo ErrorHandler
End If
' Switch to the project we want to unlock
Set Application.VBE.ActiveVBProject = Project
If Not Application.VBE.ActiveVBProject Is Project Then GoTo ErrorHandler
' Launch the menu item Tools -> VBA Project Properties
' This will trigger the password dialog
' which will then get picked up by the callback
Application.VBE.CommandBars.FindControl(ID:=2578).Execute
' Loop until callback procedure 'UnlockTimerProc' has run
' determine run by watching the state of the global variable 'g_result'
' ... or backstop of 2 seconds max
timeout = Now() + TimeSerial(0, 0, TimeoutSecond)
Do While g_Result = 0 And Now() < timeout
DoEvents
Loop
If g_Result Then UnlockProject = 0
ErrorHandler:
' Switch back to the Excel application
AppActivate Application.Caption
' Unfreeze window updates
LockWindowUpdate 0
End Function
#If VBA7 Then
Private Function UnlockTimerProc(ByVal hWnd As LongPtr, ByVal uMsg As Long, ByVal idEvent As LongPtr, ByVal dwTime As Long) As Long
#Else
Private Function UnlockTimerProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long) As Long
#End If
#If VBA7 Then
Dim hWndPassword As LongPtr
Dim hWndOK As LongPtr
Dim hWndTmp As LongPtr
Dim lRet As LongPtr
#Else
Dim hWndPassword As Long
Dim hWndOK As Long
Dim hWndTmp As Long
Dim lRet As Long
#End If
Dim lRet2 As Long
Dim sCaption As String
Dim timeout As Date
Dim timeout2 As Date
Dim pwd As String
' Protect ourselves against failure :)
On Error GoTo ErrorHandler
' Kill timer used to initiate this callback
KillTimer 0, idEvent
' Determine the Title for the password dialog
Select Case Application.LanguageSettings.LanguageID(msoLanguageIDUI)
' For the japanese version
Case 1041
sCaption = ChrW(&H30D7) & ChrW(&H30ED) & ChrW(&H30B8) & _
ChrW(&H30A7) & ChrW(&H30AF) & ChrW(&H30C8) & _
ChrW(&H20) & ChrW(&H30D7) & ChrW(&H30ED) & _
ChrW(&H30D1) & ChrW(&H30C6) & ChrW(&H30A3)
Case Else
sCaption = " Password"
End Select
sCaption = g_ProjectName & sCaption
' Set a max timeout of 2 seconds to guard against endless loop failure
timeout = Now() + TimeSerial(0, 0, TimeoutSecond)
Do While Now() < timeout
hWndPassword = 0
hWndOK = 0
hWndTmp = 0
' Loop until find a window with the correct title that is a child of the
' VBE handle for the project to unlock we found in 'UnlockProject'
Do
hWndTmp = FindWindowEx(0, hWndTmp, vbNullString, sCaption)
If hWndTmp = 0 Then Exit Do
Loop Until GetParent(hWndTmp) = g_hwndVBE
' If we don't find it then could be that the calling routine hasn't yet triggered
' the appearance of the dialog box
' Skip to the end of the loop, wait 0.1 secs and try again
If hWndTmp = 0 Then GoTo Continue
' Found the dialog box, make sure it has focus
Debug.Print "found window"
lRet2 = SendMessage(hWndTmp, TCM_SETCURFOCUS, 1, ByVal 0&)
' Get the handle for the password input
hWndPassword = GetDlgItem(hWndTmp, IDPassword)
Debug.Print "hwndpassword: " & hWndPassword
' Get the handle for the OK button
hWndOK = GetDlgItem(hWndTmp, IDOK)
Debug.Print "hwndOK: " & hWndOK
' If either handle is zero then we have an issue
' Skip to the end of the loop, wait 0.1 secs and try again
If (hWndTmp And hWndOK) = 0 Then GoTo Continue
' Enter the password ionto the password box
lRet = SetFocusAPI(hWndPassword)
lRet2 = SendMessage(hWndPassword, EM_SETSEL, 0, ByVal -1&)
lRet2 = SendMessage(hWndPassword, EM_REPLACESEL, 0, ByVal g_Password)
' As a check, get the text back out of the pasword box and verify it's the same
pwd = String(260, Chr(0))
lRet2 = SendMessage(hWndPassword, WM_GETTEXT, Len(pwd), ByVal pwd)
pwd = Left(pwd, InStr(1, pwd, Chr(0), 0) - 1)
' If not the same then we have an issue
' Skip to the end of the loop, wait 0.1 secs and try again
If pwd <> g_Password Then GoTo Continue
' Now we need to close the Project Properties window we opened to trigger
' the password input in the first place
' Like the current routine, do it as a callback
lRet = SetTimer(0, 0, 100, AddressOf ClosePropertiesWindow)
' Click the OK button
lRet = SetFocusAPI(hWndOK)
lRet2 = SendMessage(hWndOK, BM_CLICK, 0, ByVal 0&)
' Set the gloabal variable to success to flag back up to the initiating routine
' that this worked
g_Result = 1
Exit Do
' If we get here then something didn't work above
' Wait 0.1 secs and try again
' Master loop is capped with a longstop of 2 secs to terminate endless loops
Continue:
DoEvents
Sleep 100
Loop
Exit Function
' If we get here something went wrong so close the password dialog box (if we have a handle)
' and unfreeze window updates (if we set that in the first place)
ErrorHandler:
Debug.Print Err.Number
If hWndPassword <> 0 Then SendMessage hWndPassword, WM_CLOSE, 0, ByVal 0&
LockWindowUpdate 0
End Function
#If VBA7 Then
Function ClosePropertiesWindow(ByVal hWnd As LongPtr, ByVal uMsg As Long, ByVal idEvent As LongPtr, ByVal dwTime As Long) As Long
#Else
Function ClosePropertiesWindow(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long) As Long
#End If
#If VBA7 Then
Dim hWndTmp As LongPtr
Dim hWndOK As LongPtr
Dim lRet As LongPtr
#Else
Dim hWndTmp As Long
Dim hWndOK As Long
Dim lRet As Long
#End If
Dim lRet2 As Long
Dim timeout As Date
Dim sCaption As String
' Protect ourselves against failure :)
On Error GoTo ErrorHandler
' Kill timer used to initiate this callback
KillTimer 0, idEvent
' Determine the Title for the project properties dialog
sCaption = g_ProjectName & " - Project Properties"
Debug.Print sCaption
' Set a max timeout of 2 seconds to guard against endless loop failure
timeout = Now() + TimeSerial(0, 0, TimeoutSecond)
Do While Now() < timeout
hWndTmp = 0
' Loop until find a window with the correct title that is a child of the
' VBE handle for the project to unlock we found in 'UnlockProject'
Do
hWndTmp = FindWindowEx(0, hWndTmp, vbNullString, sCaption)
If hWndTmp = 0 Then Exit Do
Loop Until GetParent(hWndTmp) = g_hwndVBE
' If we don't find it then could be that the calling routine hasn't yet triggered
' the appearance of the dialog box
' Skip to the end of the loop, wait 0.1 secs and try again
If hWndTmp = 0 Then GoTo Continue
' Found the dialog box, make sure it has focus
Debug.Print "found properties window"
lRet2 = SendMessage(hWndTmp, TCM_SETCURFOCUS, 1, ByVal 0&)
' Get the handle for the OK button
hWndOK = GetDlgItem(hWndTmp, IDOK)
Debug.Print "hwndOK: " & hWndOK
' If either handle is zero then we have an issue
' Skip to the end of the loop, wait 0.1 secs and try again
If (hWndTmp And hWndOK) = 0 Then GoTo Continue
' Click the OK button
lRet = SetFocusAPI(hWndOK)
lRet2 = SendMessage(hWndOK, BM_CLICK, 0, ByVal 0&)
' Set the gloabal variable to success to flag back up to the initiating routine
' that this worked
g_Result = 1
Exit Do
' If we get here then something didn't work above
' Wait 0.1 secs and try again
' Master loop is capped with a longstop of 2 secs to terminate endless loops
Continue:
DoEvents
Sleep 100
Loop
Exit Function
' If we get here something went wrong so unfreeze window updates (if we set that in the first place)
ErrorHandler:
Debug.Print Err.Number
LockWindowUpdate 0
End Function
#James Macadie's answer (above) is the best I found (I'm running 32-bit Excel 365/2019)
Note: I found that you must have Application.ScreenUpdating = True in order to call James' method via a different sub or function. Otherwise, you may get an Invalid procedure call or argument error (if running outside of debug-mode).
This solution appears superior to both of the following:
http://www.siddharthrout.com/index.php/2019/01/20/unprotect-vbproject-from-vb-code/. creates a separate Excel Application instance to run the unlock process which didn't work for my use case
https://www.mrexcel.com/board/threads/lock-unlock-vbaprojects-programmatically-without-sendkeys.1136415/. unstable and would fail if run sequentially for multiple workbooks, I think due to a lack of the timer/waiting loops implemented in James' solution - I didn't thoroughly debug the problem
I am wrapping up an office application (VBA) that makes a call to a C# console application to perform some of the heavy lifting for the application (large simulation program). I would like to be able to have the VBA application wait for the console application to complete as well as retreive the exit code from the console application. I have been able to do the former, but have yet to be able to retrieve the exit code from the application. Is there any way that I can use something like
Diagnostics.Process.Start(filePath)
I have seen this in VB but not sure about VBA. Otherwise, any other suggestions?
Have a look at WaitForSingleObject and GetExitCodeProcess functions.
Example Usage:
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
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 FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As Long
Public Const INFINITE = &HFFFF
Public Const PROCESS_ALL_ACCESS = &H1F0FFF
Sub RunApplication(ByVal Cmd as String)
lTaskID = Shell(Cmd, vbNormalFocus)
' Get process handle
lPID = OpenProcess(PROCESS_ALL_ACCESS, True, lTaskID)
If lPID Then
' Wait for process to finish
Call WaitForSingleObject(lPID, INFINITE)
' Get Exit Process
If GetExitCodeProcess(lPID, lExitCode) Then
' Received value
MsgBox "Successfully returned " & lExitCode, vbInformation
Else
MsgBox "Failed: " & DLLErrorText(Err.LastDllError), vbCritical
End If
Else
MsgBox "Failed: " & DLLErrorText(Err.LastDllError), vbCritical
End If
lTaskID = CloseHandle(lPID)
End Sub
Public Function DLLErrorText(ByVal lLastDLLError As Long) As String
Dim sBuff As String * 256
Dim lCount As Long
Const FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100, FORMAT_MESSAGE_ARGUMENT_ARRAY = &H2000
Const FORMAT_MESSAGE_FROM_HMODULE = &H800, FORMAT_MESSAGE_FROM_STRING = &H400
Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000, FORMAT_MESSAGE_IGNORE_INSERTS = &H200
Const FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF
lCount = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS, 0, lLastDLLError, 0&, sBuff, Len(sBuff), ByVal 0)
If lCount Then
DLLErrorText = Left$(sBuff, lCount - 2) ' Remove line feeds
End If
End Function
This functionality has been wrapped up in the ShellAndWait function.
Excellent write up on it here.