如何使Outlook日历提醒在Windows 7中排在最前面

我刚刚开始使用Windows 7，我想知道如何使Outlook提醒弹出并突出显示自己。它们一直谨慎打开，就像任务栏上Outlook堆栈中的另一个窗口一样。结果，我一直忽略它们，因为它们突然出现在其他所有东西后面。

如何使它们不那么容易被忽视？

（显然，人们通常不希望将讨厌的应用程序推到最前沿。但是在某些地方，这种行为是可取的，而Outlook日历提醒就是其中之一。）

我在使用Outlook 2010时遇到了同样的问题。使用下面提到的步骤，它的工作原理很吸引人。不要忘记启用所有宏：“信任中心”>“宏设置”。

• 创建数字证书供以后使用：单击“开始”，然后键入“ certificate”，选择“ VBA项目数字证书”。
• 输入证书名称。单击确定。打开Outlook，然后按Alt+ F11启动VBA编辑器。
• 在左侧的树中，展开“ Microsoft Office Outlook对象”，然后双击“ ThisOutlookSession”

• 粘贴此代码：

  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
  ReminderWindowHWnd = FindWindowA(vbNullString, "1 Reminder")
  SetWindowPos ReminderWindowHWnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS
  
  End Sub
  

• 对宏进行签名，以便它可以运行：工具>数字签名...，然后选择您之前创建的证书

• 关闭VBA窗口
• 在文件>选项>信任中心>信任中心设置>宏设置中启用所有宏

AutoHotKey也可以用来解决此问题。该脚本将提醒窗口置于顶部而不会失去焦点（已在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
}

AHK脚本 - 编译的EXE

我找到的最佳答案是：如何使用一些简单的VBA使Outlook约会提醒再次弹出其他窗口。

它需要在“ ThisOutlookSession”中添加几行简单的VBA代码。现在，它每次都会弹出一个窗口。好多了。

• 创建数字证书供以后使用
• 点击开始，然后输入“证书”，选择“ VBA项目数字证书”
• 输入证书名称
• 完成了
• 打开Outlook，然后按Alt + F11启动VBA编辑器。
• 在左侧的树中，展开“ Microsoft Office Outlook对象”，然后双击“ ThisOutlookSession”

• 粘贴此代码，修改引号中的文本以适合您的偏好。保留引号。

  Private Sub Application_Reminder(ByVal Item As Object)
  
  
      If TypeOf Item Is AppointmentItem Then
      MsgBox "Message text", vbSystemModal, "Message title"
      End If
  
  
  End Sub
  

• 对宏进行签名，以使其运行，方法是转到工具>数字签名…，然后选择您之前创建的证书

• 关闭VBA窗口

不可能。我们公司尝试将其直接升级到Microsoft。人们在这里要做的一件事就是给它分配一个更令人讨厌的声音，以帮助注意它。但是微软已经告诉我们这是设计使然。

与上面的Gullu回答相同，但进行了更改以适应不同的窗口标题：

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

'// TO ACCOUNT FOR WINDOW TITLE CHANGING WITH NOTIFICATION COUNT:
Private Sub Application_Reminder(ByVal Item As Object)
    Dim ReminderWindowHWnd As Variant
    'On Error Resume Next
    On Error GoTo err
    'Loop 25 times as FindWindowA needs exact title which varies according to number of reminder items...
    Dim iReminderCount As Integer
    For iReminderCount = 1 To 25
        'Try two syntaxes...
        ReminderWindowHWnd = FindWindowA(vbNullString, iReminderCount & " Reminder"): SetWindowPos ReminderWindowHWnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS
        ReminderWindowHWnd = FindWindowA(vbNullString, iReminderCount & " Reminder(s)"): SetWindowPos ReminderWindowHWnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS
    Next
Exit Sub
err:
    Debug.Print err.Number & " - " & err.Description & " (iReminderCount = " & iReminderCount & ")"
    Resume Next
End Sub

从版本1803（2018年2月）开始，“显示其他窗口上方的提醒”选项现在可用。默认情况下，它似乎没有启用。

这也困扰着我。经过一番激烈的搜索，我找到了部分答案：http : //www.pcreview.co.uk/forums/hidden-outlook-reminders-t3972914.html

如果将“任务栏和开始菜单属性”下的“任务栏按钮”设置更改为“从不合并”，则分组将分开，并且在您打开的所有菜单之前都会弹出提醒。

我尝试对其进行测试，发现它不一致。一次它隐藏在我正在处理的内容后面，另一次它突然出现在前面。在这两种情况下，任务栏上的图标看上去都与Outlook本身不同，因此至少有机会我会注意到它。

我使用了Filebox eXtender，当第一个提醒出现时，我将其打开并单击标题栏右上角的新“图钉”图标。然后，当下一个提醒进入时，它就在前台...

我找到了一个名为ShowReminders（http://www.sagelamp.com/pages/showreminders.aspx）的插件，它将提醒窗口带到顶部。当您最小化提醒窗口时，它甚至可以工作。

我终于找到了使用Outlook VBA和简单EXE的简单解决方案。

这是如何再也不会错过Outlook会议的约会。

为什么要为此目的安装独立的exe应用程序？好吧，我在VBA中嵌入了大红色框，但是该解决方案充满了问题（我相信是因为我必须使用hwnd和其他异常系统属性才能将大红色框保持在顶部）。因此，为了使事情变得简单，为什么不做一件事情的基本EXE。您可以使用Microsoft提供的免费工具（Visual Studio Community 2015是免费的）。

这是EXE代码。一个窗体的简单Windows窗体应用程序。编译此代码。

Imports System.Timers
Public Class Form1
    Dim tTimer As New Timer
    Public Sub New()
        InitializeComponent()
        Me.StartPosition = Windows.Forms.FormStartPosition.CenterScreen
        Me.TopMost = True
        Me.TopLevel = True
    End Sub
    Private Sub Form1_DoubleClick(sender As Object, e As EventArgs) Handles Me.DoubleClick
        Application.Exit()
    End Sub 
    Private Sub Form1_Shown(sender As Object, e As EventArgs) Handles Me.Shown
        flashingQuick()
    End Sub
    Sub flashingQuick()
        tTimer.Start()
        AddHandler tTimer.Elapsed, New ElapsedEventHandler(AddressOf TimerTick)
    End Sub
    Sub TimerTick(ByVal source As [Object], ByVal e As ElapsedEventArgs)
        Dim theTimer As System.Timers.Timer = DirectCast(source, System.Timers.Timer)
        theTimer.Interval = 500
        theTimer.Enabled = True
        If Me.BackColor = System.Drawing.SystemColors.Control Then
            Me.BackColor = Color.Red
        Else
            Me.BackColor = System.Drawing.SystemColors.Control
        End If
    End Sub
End Class

这就是我在Outlook VBA中所需要的。把它放在ThisOutlookSession中

Private Sub Application_Reminder(ByVal Item As Object)
    On Error Resume Next
    If Item.MessageClass <> "IPM.Appointment" Then
      Exit Sub
    End If
    Dim sAPPData As String
    Dim sFileName As String
    sAPPData = Environ("AppData")
    sFileName = "\Microsoft\Windows\Start Menu\Programs\BigRedBox\BigRedBox.exe"
    If Dir(sAPPData & sFileName) <> "" Then
        Call Shell(sAPPData & sFileName)
    End If
End Sub

这是tbone答案的增强版本，适用于德语版本。

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 Declare PtrSafe Function BringWindowToTop Lib "user32" (ByVal hwnd As Long) As Boolean
Private Declare PtrSafe Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Boolean
Private Declare PtrSafe Function SetFocus Lib "user32" (ByVal hwnd 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 GoTo err
    'Loop 25 times as FindWindowA needs exact title which varies according to number of reminder items...
    Dim iReminderCount As Integer
    For iReminderCount = 1 To 25
        'Try two syntaxes...

        ReminderWindowHWnd = FindWindowA(vbNullString, iReminderCount & " Erinnerung")
        SetWindowPos ReminderWindowHWnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS
        BringWindowToTop (ReminderWindowHWnd)
        SetForegroundWindow ReminderWindowHWnd
        SetFocus ReminderWindowHWnd

        ReminderWindowHWnd = FindWindowA(vbNullString, iReminderCount & " Erinnerung(en)")
        SetWindowPos ReminderWindowHWnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS
        BringWindowToTop ReminderWindowHWnd
        SetForegroundWindow ReminderWindowHWnd
        SetFocus ReminderWindowHWnd
    Next
Exit Sub
err:
    Debug.Print err.Number & " - " & err.Description & " (iReminderCount = " & iReminderCount & ")"
    Resume Next
End Sub

我已经添加了德国的窗口标题，也有一些新的功能（BringWindowToTop，SetForegroundWindow和SetFocus）。

在我的德语Windows 10上与Outlook 2016一起使用。

我并没有设法生成新的证书（按启动键，然后输入“证书”，没有发现什么），但登录时只需选择另一个证书在列表中。