I have 4 slides with an ActiveX Label in each of the slides. The first slide contains an ActiveX Command Button.
Private Sub CommandButton1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Set shpPoint = ActivePresentation.SlideShowWindow.View.Slide.Shapes("TextBox 1")
If (KeyCode = vbKeyA) Then
Point = Point + 1
shpPoint.TextFrame.TextRange = Point
End If
End Sub
This code allows me to capture the keypress and run the corresponding macro. To start capturing the keypresses, I would have to first click on the Command Button present in Slide 1. After that, the code does its job wonderfully. However, the code would not work if I go to another slide. The keypress capture occurs only in Slide 1. I assume it has to do with the Private Sub present within Slide1
I'm stuck at replicating the same as I navigate through slides 1 to 4. I do not want to place a command button on every slide. I would like for vbKeyA to be captured across all slides and run the corresponding macro.
Please advise the best method to proceed.
Your approach works because when you click the button for the first time, it gets the focus. As long as the button has the focus, the KeyDown event will trigger. As soon as the button loses focus the event will not trigger anymore. Once you change slide the button on the first slide loses focus.
The comment provided by #DanielDuĊĦek is sensible. Using this approach, you need a control that exposes a KeyDown event in order to trap it and unfortunately you would need such a control to always have the focus, hence one on each slide. Could be a Frame, TextBox, CommandButton etc.
Initial approach - you can skip this section
My initial approach was to try to improve on your approach. Main steps:
At the click of the initial button I've programmatically added a transparent button on each slide using Slide.Shapes.AddOLEObject ClassName:="Forms.CommandButton.1"
I've retrieved each button using the shape returned by AddOLEObject with: Shape.OLEFormat.Object
I added each button in a wrapper class so I can trap the KeyDown events
I edited each button (like making it transparent)
I then added all wrapped buttons to a global collection so I can remove them later.
I encountered 2 issues:
I was not able to programatically set the focus on the transparent buttons (BTW it seems the slide app events are not firing properly - yes, I had a wrapper WithEvents application class as well). Even if this worked the control can still lose focus so it wouldn't be too reliable
The wrapped buttons seemed to lose state (although the global collection had a reference to each) and I could not remove them later
Overall the above approach is horrible and unreliable.
Actual solution
Instead of relying on controls with events I proceeded to hook into the keyboard itself. The following solution will only work on Windows (not on a Mac). As far as I tested it works well.
Drop the following code into a standard module. Call it KeyboardHook:
Option Explicit
'API declarations
#If Mac Then
'No Mac functionality implemented
#Else 'Windows API functionality
#If VBA7 Then
Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare PtrSafe Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare PtrSafe Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Long
#Else
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Declare Function GetActiveWindow Lib "user32" () 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 SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
#End If
#End If
'Id of the hook procedure to be installed with SetWindowsHookExA for KeyboardProc
Private Const WH_KEYBOARD As Long = 2
'Hook handle returned by SetWindowsHookEx. Used later in UnhookWindowsHookEx
#If VBA7 Then
Private m_hHookKeyboard As LongPtr
#Else
Private m_hHookKeyboard As Long
#End If
'Stored to check if presentation is still running via 'IsPresentationActive'
Private m_presentation As Presentation
Private Const REG_APP As String = "PP"
Private Const REG_SECTION As String = "KeyHook"
Private Const REG_KEY As String = "hHook"
Private Function IsPresentationActive() As Boolean
On Error Resume Next
IsPresentationActive = ActivePresentation.SlideShowWindow.Active
IsPresentationActive = (Err.Number = 0)
On Error GoTo 0
End Function
'*******************************************************************************
'Hooks Keyboard messages
'*******************************************************************************
Public Sub HookKeyboard()
UnHookKeyboard 'Remove previous hook
'
Set m_presentation = ActivePresentation
If Not IsPresentationActive Then Exit Sub
'
Dim isHookSuccessful As Boolean
'
#If Mac Then
#Else
m_hHookKeyboard = SetWindowsHookEx(idHook:=WH_KEYBOARD _
, lpfn:=AddressOf KeyboardProc _
, hmod:=0 _
, dwThreadId:=GetCurrentThreadId())
#End If
If m_hHookKeyboard <> 0 Then
SaveSetting REG_APP, REG_SECTION, REG_KEY, m_hHookKeyboard
Debug.Print "Keyboard hooked " & Now
End If
End Sub
'*******************************************************************************
'UnHooks Keyboard
'*******************************************************************************
Public Sub UnHookKeyboard()
If m_hHookKeyboard = 0 Then 'Try to restore if state was lost
Dim savedHook As String
'
savedHook = GetSetting(REG_APP, REG_SECTION, REG_KEY)
If savedHook <> vbNullString Then
#If VBA7 Then
m_hHookKeyboard = CLngPtr(savedHook)
#Else
m_hHookKeyboard = CLng(savedHook)
#End If
End If
End If
'
If m_hHookKeyboard <> 0 Then
#If Mac Then
#Else
UnhookWindowsHookEx m_hHookKeyboard
#End If
m_hHookKeyboard = 0
DeleteSetting REG_APP, REG_SECTION, REG_KEY
Debug.Print "Keyboard unhooked " & Now
End If
End Sub
'*******************************************************************************
'Callback hook function - monitors keyboard messages
'https://learn.microsoft.com/en-us/previous-versions/windows/desktop/legacy/ms644984(v=vs.85)
'*******************************************************************************
#If Mac Then
#Else
#If VBA7 Then
Private Function KeyboardProc(ByVal ncode As Long _
, ByVal wParam As Long _
, ByVal lParam As Long) As LongPtr
#Else
Private Function KeyboardProc(ByVal ncode As Long _
, ByVal wParam As Long _
, ByVal lParam As Long) As Long
#End If
'nCode
Const HC_ACTION As Long = 0
Const HC_NOREMOVE As Long = 3
'
'WM_KEYUP/DOWN/CHAR HIWORD(lParam) flags
Const KF_EXTENDED = &H100
Const KF_DLGMODE = &H800
Const KF_MENUMODE = &H1000
Const KF_ALTDOWN = &H2000
Const KF_REPEAT = &H4000
Const KF_UP = &H8000
'
If IsVBEActive Then GoTo Unhook 'Unhook if a VBE window is active (to avoid crashes)
If Not IsPresentationActive Then GoTo Unhook
'
If ncode = HC_ACTION Then
If wParam = vbKeyA And (lParam And KF_UP) > 0 Then
Debug.Print "A " & Now
Debug.Print "Shift is down: " & IsShiftKeyDown()
Debug.Print "Ctrl is down: " & IsControlKeyDown()
Debug.Print
'
KeyboardProc = -1
Exit Function
End If
End If
'
NextHook:
KeyboardProc = CallNextHookEx(0, ncode, wParam, ByVal lParam)
Exit Function
Unhook:
UnHookKeyboard
GoTo NextHook
End Function
#End If
'*******************************************************************************
'Get Shift/Control Key State
'https://learn.microsoft.com/en-us/windows/desktop/api/winuser/nf-winuser-getkeystate
'https://learn.microsoft.com/en-us/windows/desktop/inputdev/virtual-key-codes
'*******************************************************************************
Private Function IsShiftKeyDown() As Boolean
Const VK_SHIFT As Long = &H10
'
IsShiftKeyDown = CBool(GetKeyState(VK_SHIFT) And &H8000) 'hi-order bit only
End Function
Private Function IsControlKeyDown() As Boolean
Const VK_CONTROL As Long = &H11
'
IsControlKeyDown = CBool(GetKeyState(VK_CONTROL) And &H8000)
End Function
'*******************************************************************************
'Returns the String Caption of a Window identified by a handle
'*******************************************************************************
#If VBA7 Then
Private Function GetWindowCaption(ByVal hwnd As LongPtr) As String
#Else
Private Function GetWindowCaption(ByVal hwnd As Long) As String
#End If
Dim bufferLength As Long: bufferLength = GetWindowTextLength(hwnd)
GetWindowCaption = VBA.Space$(bufferLength)
GetWindowText hwnd, GetWindowCaption, bufferLength + 1
End Function
'*******************************************************************************
'Checks if the ActiveWindow is a VBE Window
'*******************************************************************************
Private Function IsVBEActive() As Boolean
#If Mac Then
#Else
IsVBEActive = VBA.InStr(1, GetWindowCaption(GetActiveWindow()) _
, "Microsoft Visual Basic", vbTextCompare) <> 0
#End If
End Function
All you need to do to start tracking key presses is to call the the HookKeyboard method once the presentation has started. You can do that in a few ways. Here are 2:
Press Alt+F8 (Macro Dialog Box) and then run the Macro directly
Use an ActiveX button on the first slide:
Private Sub CommandButton1_Click()
HookKeyboard
End Sub
Important! I've written the code in such a way that it hooks only if the presentation is already started at the moment you call it. Also, it automatically unhooks when the presentation is over (at any key press). If you want to stop the hook before the presentation ends then simply call the UnHookKeyboard method.
Currently, the above code will only display some info in the Immediate Window whenever you press the A key:
All you need to do is to go to the KeyboardProc method and change these lines:
Debug.Print "A " & Now
Debug.Print "Shift is down: " & IsShiftKeyDown()
Debug.Print "Ctrl is down: " & IsControlKeyDown()
Debug.Print
to whatever you need. I suppose you will simply call you desired macro.
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