Как сделать всплывающее напоминание о перспективах поверх других окон

Ответ 1

* Для последнего макроса, пожалуйста, см. Обновление 3 *

После поиска я нашел частичный ответ на веб-сайте, который, казалось, дал мне большую часть решения; https://superuser.com/questions/251963/how-to-make-outlook-calendar-reminders-stay-on-top-in-windows-7

Однако, как отмечено в комментариях, первое напоминание не всплыло; в то время как дальнейшие напоминания тогда сделали. основываясь на коде, который я предположил, это потому, что окно не было обнаружено, пока оно не было создано один раз

Чтобы обойти это, я искал таймер, чтобы периодически проверять, было ли окно, и если оно было, то перенести его на передний план. Взяв код со следующего сайта; Outlook VBA - запускать код каждые полчаса

Затем слияние двух решений дало рабочее решение этой проблемы.

Из центра доверия я включил использование макросов, затем открыл редактор Visual Basic из 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

Затем добавил модуль и добавил следующий код

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

Так что это; каждые 5 секунд таймер проверяет, существует ли окно с заголовком "1 напоминание", затем поднимает его до самого верха...

ОБНОВЛЕНИЕ (12 февраля 2015 г.): после некоторого использования я обнаружил настоящее раздражение в связи с тем, что запуск таймера удаляет фокус из текущего окна. Это огромная проблема, когда вы пишете электронное письмо.

Таким образом, я обновил код так, что таймер работает только каждые 60 секунд, а затем при обнаружении первого активного напоминания таймер останавливается, и функция вторичного события немедленно используется для активации изменения фокуса окна.

ОБНОВЛЕНИЕ 2 (4 сентября 2015 г.): после перехода на 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

Тогда обновленный код модуля...

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

ОБНОВЛЕНИЕ 3 (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

Ответ 2

Используя 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
}

Ответ 3

Я нашел бесплатную программу под названием PinMe!, которая будет делать именно то, что я хочу. Когда появится напоминание Outlook, щелкните правой кнопкой мыши на PinMe! в системном трее и выберите окно напоминания. Это поместит значок блокировки рядом с окном. Вперед Отклонить или отложить напоминание. В следующий раз, когда появится напоминание, оно должно появиться перед каждым другим окном. Это будет работать независимо от Outlook на переднем плане или сведено к минимуму.

Ответ 4

У меня есть Office 2013 и Windows 8.1 Pro. Многие макросы, которые я обнаружил, не обрабатывали переменную характер заголовка Outlook, размещенного в диалоговом окне "Напоминание". Когда у вас есть 1 напоминание, заголовок "1 напоминание (и)" и т.д. Я создал простое приложение для форм Windows в VB.NET, которое загружаю при запуске и сохраняем сведенным к системному диску. В форму добавляется 60 таймеров, которые запускают активный код. Когда появляется больше, чем 0 напоминаний, диалоговое окно будет установлено в верхнее и переместится на 0,0.

Вот код:

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

Ответ 5

В Outlook 2016 появилась опция "Показывать напоминания поверх других окон". Используйте "Файл"> "Параметры"> "Дополнительно", а затем установите флажок в разделе "Напоминания". Смотрите эту страницу support.office.com для скриншота. Эта опция была добавлена в версии 1804 Outlook 2016, выпущенной для "ежемесячного канала" 25 апреля 2018 года.

Эта опция Outlook 2016 ставит напоминание поверх всех приложений только изначально. Мне нравится держать напоминание сверху, пока я не отклоню его явно, даже если я нажму в каком-нибудь другом окне. Чтобы держать напоминание сверху, я настоятельно рекомендую @Tragamor принятый ответ на этот вопрос. Но если ответ @Tragamor кажется слишком сложным, и вы в порядке с напоминанием, которое было только сверху, то теперь вариант в Outlook 2016 очень прост.

Ответ 6

Вдохновленный ответом Эрика Лабашоски, я пошел дальше к его концепции и создал приложение NotifyWhenMicrosoftOutlookReminderWindowIsOpen, которое вы можете скачать бесплатно. Это небольшой исполняемый файл, который может обеспечить отображение окна напоминаний Outlook поверх других окон, а также имеет некоторые другие дополнительные способы оповещения пользователя об открытии окна.

Ответ 7

Это должно работать в разных версиях Outlook, даже если я проверил его только на Outlook 2013.

Так как я не могу проверить его в локализованной английской версии, вам может потребоваться настроить строки кода, связанные с поиском окна напоминаний, даже если в моем ответе я изменил связанные строки кода, чтобы найти окно на английском языке локализованная версия.

Сообщите мне, работает ли макрос в вашей версии на английском языке.

Пользователь имеет право сворачивать или закрывать окно напоминаний, когда в случае возникновения нового или существующего напоминания окно напоминаний будет самым верхним и не активировано.

Заголовок окна напоминаний будет всегда обновляться, отражая реальное количество видимых напоминаний, даже не активируя его.

Во всех случаях окно напоминаний никогда не будет красть фокус, если, очевидно, окно переднего плана не является окном напоминаний, если пользователь не заведомо выбрал окно напоминаний.

Этот макрос, кроме самого окна напоминаний, также будет выбирать самое последнее напоминание в самом окне напоминания, вы можете настроить это поведение, пожалуйста, прочитайте код, чтобы иметь возможность сделать это.

Макрос также мигает окно напоминаний при первом показе окна и всякий раз, когда снова появляется новое или существующее напоминание.

Вы можете настроить, сколько раз мигает окно или какие-либо другие параметры, связанные с ним, должно быть ясно, как это сделать.

Вставьте следующие строки кода в модуль класса "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

Вставьте следующие строки кода в новый или существующий стандартный модуль:

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

Ответ 8

В последней версии Outlook эта функция встроена, и на нее можно ответить в https://superuser.com/a/1327856/913992.

Ответ 9

Просто Alt F11 и скопируйте и вставьте этот код.. Работает для меня

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