如何在其他窗口之上制作Outlook提醒弹出窗口

Question

如何在其他窗口之上制作Outlook提醒弹出窗口

Tra*_*mor 18 outlook reminders focus windows-7

如何在其他窗口之上制作Outlook提醒弹出窗口？

在网上看了很久之后; 我无法找到这个问题的满意答案.

使用Windows 7和Microsoft Outlook 2007+; 当提醒闪烁时,它不再提供模态框来吸引你的注意力.在其他插件可能有问题需要安装(管理员权限)以及使用安静系统时,会议请求经常被忽略.

有没有比使用第三方插件/应用程序更容易实现此方法？

Answer 1

Tra*_*mor 15

*有关最新的宏,请参阅更新3*

在搜索了一段时间后,我在网站上找到了部分答案,似乎给了我大部分解决方案; https://superuser.com/questions/251963/how-to-make-outlook-calendar-reminders-stay-on-top-in-windows-7

然而,如评论中所述,第一个提醒未能弹出; 然后进一步提醒.根据我假设的代码,这是因为在实例化一次之前未检测到窗口

为了解决这个问题,我希望使用一个计时器来定期测试窗口是否存在以及是否存在,然后将其带到前面.从以下网站获取代码; Outlook VBA - 每半小时运行一次代码

然后将两个解决方案融合在一起为这个问题提供了可行的解决方案.

从信任中心,我启用了宏的使用,然后从Outlook打开可视化基本编辑器(alt + F11)我将以下代码添加到'ThisOutlookSession'模块

Private Sub Application_Startup()
    Call ActivateTimer(5) 'Set timer to go off every 5 seconds
End Sub

Private Sub Application_Quit()
  If TimerID <> 0 Then Call DeactivateTimer 'Turn off timer upon quitting 
End Sub

Run Code Online (Sandbox Code Playgroud)

然后添加了一个模块并添加了以下代码

Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent _
As Long, ByVal uElapse As Long, ByVal lpTimerfunc As Long) As Long

Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent _
As Long) As Long

Private Declare Function FindWindowA Lib "user32" (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 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 eventually turn off the timer. 
' If the timer ID <> 0 then the timer is running

Public Sub ActivateTimer(ByVal nSeconds As Long)
    nSeconds = nSeconds * 1000 
    'The SetTimer call accepts milliseconds, so convert from seconds
    If TimerID <> 0 Then Call DeactivateTimer 
    'Check to see if timer is running before call to SetTimer
    TimerID = SetTimer(0, 0, nSeconds, AddressOf TriggerTimer)
    If TimerID = 0 Then MsgBox "The timer failed to activate."
End Sub

Public Sub DeactivateTimer()
    Dim lSuccess As Long
    lSuccess = KillTimer(0, TimerID)
    If lSuccess = 0 Then
        MsgBox "The timer failed to deactivate."
    Else
        TimerID = 0
    End If
End Sub

Public Sub TriggerTimer(ByVal hwnd As Long, ByVal uMsg As Long, _
ByVal idevent As Long, ByVal Systime As Long)
    Call EventMacro
End Sub

Public Sub EventMacro()
    Dim ReminderWindowHWnd As Variant
    On Error Resume Next
    ReminderWindowHWnd = FindWindowA(vbNullString, "1 Reminder")
    If ReminderWindowHWnd <> 0 Then SetWindowPos ReminderWindowHWnd, _
    HWND_TOPMOST, 0, 0, 0, 0, FLAGS
    ReminderWindowHWnd = Nothing
End Sub

Run Code Online (Sandbox Code Playgroud)

就是这样了; 每隔5秒,计时器检查一个带有标题"1 Reminder"的窗口是否存在,然后将其碰到顶部...

更新 (2015年2月12日):在使用了一段时间后,我发现了一个真正的烦恼,即触发定时器会从当前窗口中移除焦点.当你写一封电子邮件时,这是一个巨大的麻烦.

因此,我升级了代码,使得计时器仅每60秒运行一次,然后在找到第一个活动提醒时,停止计时器,然后立即使用辅助事件功能来激活窗口焦点变化.

更新2 (2015年9月4日):已转换到Outlook 2013 - 此代码停止为我工作.我现在使用另一个函数(FindReminderWindow)更新它,查找一系列弹出提醒标题.这在2013年对我有用,应该适用于2013年以下的版本.

FindReminderWindow函数接受一个值,该值是要逐步查找窗口的迭代次数.如果你经常有比10个弹出窗口更多的提醒,那么你可以在EventMacro子句中增加这个数字......

更新后面的代码:将以下代码添加到'ThisOutlookSession'模块中

Private Sub Application_Startup()
    Call ActivateTimer(60) 'Set timer to go off every 60 seconds
End Sub

Private Sub Application_Quit()
    If TimerID <> 0 Then Call DeactivateTimer 'Turn off timer upon quitting
End Sub

Private Sub Application_Reminder(ByVal Item As Object)
    Call EventMacro
End Sub

Run Code Online (Sandbox Code Playgroud)

然后更新的模块代码......

Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent _
As Long, ByVal uElapse As Long, ByVal lpTimerfunc As Long) As Long

Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent _
As Long) As Long

Private Declare Function FindWindowA Lib "user32" (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 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 eventually turn off the timer. 
' If the timer ID <> 0 then the timer is running

Public Sub ActivateTimer(ByVal nSeconds As Long)
    nSeconds = nSeconds * 1000 
    'The SetTimer call accepts milliseconds, so convert from seconds
    If TimerID <> 0 Then Call DeactivateTimer 
    'Check to see if timer is running before call to SetTimer
    TimerID = SetTimer(0, 0, nSeconds, AddressOf TriggerTimer)
    If TimerID = 0 Then MsgBox "The timer failed to activate."
End Sub

Public Sub DeactivateTimer()
    Dim lSuccess As Long
    lSuccess = KillTimer(0, TimerID)
    If lSuccess = 0 Then
        MsgBox "The timer failed to deactivate."
    Else
        TimerID = 0
    End If
End Sub

Public Sub TriggerTimer(ByVal hwnd As Long, ByVal uMsg As Long, _
ByVal idevent As Long, ByVal Systime As Long)
    Call EventMacro
End Sub

Public Sub EventMacro()
    Dim ReminderWindowHWnd As Variant
    On Error Resume Next
    ReminderWindowHWnd = FindReminderWindow(10)
    If ReminderWindowHWnd <> 0 Then
        SetWindowPos ReminderWindowHWnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS
        If TimerID <> 0 Then Call DeactivateTimer
    End If
    ReminderWindowHWnd = Nothing
End Sub

Private Function FindReminderWindow(iUB As Integer) As Variant
    Dim i As Integer: i = 1
    FindReminderWindow = FindWindowA(vbNullString, "1 Reminder")
    Do While i < iUB And FindReminderWindow = 0
        FindReminderWindow = FindWindowA(vbNullString, i & " Reminder(s)")
        i = i + 1
    Loop
End Function

Run Code Online (Sandbox Code Playgroud)

更新3 (2016年8月8日):重新思考我的方法并基于观察 - 我重新设计了代码,试图在Outlook开放时对工作产生最小的影响; 我会发现计时器仍然把注意力从我正在写的电子邮件上移开,并且可能与Windows失去焦点的其他问题可能有关.

相反 - 我假设一旦实例化的提醒窗口只是隐藏而不是在显示提醒时被销毁; 因此,我现在保持窗口的全局句柄,所以我只需要在窗口标题上查看一次,然后检查提醒窗口是否可见,然后再进行模态化.

此外 - 计时器现在仅在触发提醒窗口时使用,然后在功能运行后关闭; 希望在工作日停止任何侵入式宏的运行.

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

更新后面的代码:将以下代码添加到'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

Run Code Online (Sandbox Code Playgroud)

然后更新的模块代码......

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

Run Code Online (Sandbox Code Playgroud)

一个微小的变化允许窗口在顶部而不会窃取焦点。添加这一行： Private Const SWP_NOACTIVATE = &H10 并更改这一行： Private Const FLAGS As Long = SWP_NOMOVE 或 SWP_NOSIZE 或 SWP_NOACTIVATE 如下所示：http://www.vbforums.com/showthread.php?558277-RESOLVED-Stay-On -Top-Don-t-Steal-Focus！ (2认同)

Answer 2

Eri*_*sky 13

使用AutoHotKey,您可以将窗口设置为Always On Top而不会窃取当前窗口的焦点.(使用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
}

Run Code Online (Sandbox Code Playgroud)

伟大的！它在我的机器上没有使用可辨别的 CPU 时间。简单的步骤：安装AutoHotkey，把上面的脚本放到一个.ahk后缀的文件中，右键编译它，让它在Windows下自动启动（shell:startup）。 (2认同)

归档时间：	11 年，5 月前
查看次数：	46834 次
最近记录：	6 年，7 月前