vba - 如何弹出 Outlook 提醒并保持在其他窗口之上

Question

如何弹出 Outlook 提醒并保持在其他窗口之上？

网上查了半天；我无法找到这个问题的满意答案。

使用 Windows 7 和 Microsoft Outlook 2007+；当提醒闪烁时，它不再提供模式框来吸引您的注意力。在工作中，安装其他插件可能会出现问题(管理员权限)，并且在使用安静的系统时， session 请求经常被忽视。

是否有更简单的方法来实现此而不使用第三方插件/应用程序？

Sep 2021: Updated question title to indicate modal popup

Answer 1

For the latest macro please see update 4 (Office 365 inclusion)

经过一段时间的搜索，我在一个网站上找到了部分答案，该网站似乎为我提供了大部分解决方案； https://superuser.com/questions/251963/how-to-make-outlook-calendar-reminders-stay-on-top-in-windows-7

但是正如评论中所指出的，第一个提醒未能弹出；然后进一步提醒。根据我认为这是因为窗口在实例化一次之前未被检测到的代码

为了解决这个问题，我希望使用一个计时器来定期测试窗口是否存在，如果存在，则将其放在前面。从以下网站获取代码； Outlook VBA - Run a code every half an hour

然后将这两个解决方案融合在一起，为这个问题提供了一个有效的解决方案。

从信任中心，我启用了宏的使用，然后从 Outlook 打开 Visual Basic 编辑器 (alt+F11)，我将以下代码添加到“ThisOutlookSession”模块

CODE REMOVED

<小时/>

UPDATE 1 (Feb 12, 2015)

使用了一段时间后，我发现触发计时器会从当前窗口中删除焦点这一事实确实令人烦恼。当你写电子邮件时这是一个巨大的麻烦。

因此，我升级了代码，以便计时器每 60 秒运行一次，然后在找到第一个事件提醒时，计时器停止，然后立即使用辅助事件函数来激活窗口焦点更改。

<小时/>

UPDATE 2 (Sep 4, 2015)

转换到 Outlook 2013 后 - 此代码不再为我工作。我现在用另一个函数(FindReminderWindow)更新了它，该函数查找一系列弹出提醒标题。这现在适用于 2013 年的我，并且应该适用于 2013 年以下的版本。

FindReminderWindow 函数采用一个值，该值是查找窗口所需的迭代次数。如果您的提醒数量通常多于 10 个弹出窗口，那么您可以在 EventMacro 子项中增加此数量...

CODE REMOVED

<小时/>

UPDATE 3 (Aug 8, 2016)

根据观察重新思考了我的方法 - 我重新设计了代码，尝试在 Outlook 打开时对工作产生最小的影响；我会发现计时器仍然将焦点从我正在编写的电子邮件上移开，并且可能与窗口失去焦点的其他问题有关。

相反 - 我假设提醒窗口一旦实例化就只是隐藏，并且在显示提醒时不会被破坏；因此，我现在保留了窗口的全局句柄，因此我只需要查看窗口标题一次，然后在使其成为模态之前检查提醒窗口是否可见。

此外 - 计时器现在仅在触发提醒窗口时使用，然后在函数运行后关闭；希望能够在工作日停止任何侵入性宏的运行。

看看哪一个适合你，我猜......

更新了以下代码:将以下代码添加到“ThisOutlookSession”模块

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

然后更新模块代码...

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)

过渡到 Office 365:现在设置中有一个选项可以在窗口顶部显示提醒(如下图)，那么为什么您现在要运行宏以将其放在顶部呢？原因是您可以将其设置为模式提醒框(使用 SWP_DRAWFRAME)，因此如果您在程序之间交换，它将保持可见，而普通选项不会发生这种情况

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