Set limited time for messagebox pop up

V

Vincent88

Active Member
Joined
Mar 5, 2021
Messages
382
Office Version
  1. 2019
Platform
  1. Windows
  2. Mobile
Hi Guys, my code is to copy the value of a cell to clipboard and a popup message box will show. I applied a timer to close the message box in 1 second but it does not work. Please review and help me to rectify it. Thanks.

VBA Code: 
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    Dim lrow As Long
    Dim rngAreaC As Range, rngAreaD As Range
    Dim strmgC As String, strmgD As String
    Dim AckTime As Integer, InfoBox As Object
    
    lrow = Range("A1").End(xlDown).Row
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
  
    
    
    If Target.CountLarge > 1 Then Exit Sub
        Set rngAreaC = Range(Cells(2, 3), Cells(lrow, 3))
        Set rngAreaD = Range(Cells(2, 4), Cells(lrow, 4))
    
        If Not Intersect(Target, rngAreaC) Is Nothing Then
            Cancel = True
            Target.Font.Bold = True
            Target.Offset(, -2).Font.Bold = True
            
            
             With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
                 .SetText Target
                 .PutInClipboard
             End With
            
            strmgC = Target.Text & vbNewLine & _
                    vbCrLf & _
                    "Copied"
                
          
                   Set InfoBox = CreateObject("WScript.Shell")
                   AckTime = 1
                   Select Case InfoBox.Popup(strmgC, AckTime, "Notification", 0)
                   Case 1, -1
                   Exit Sub
                   End Select
            
            
            
            Else
            If Not Intersect(Target, rngAreaD) Is Nothing Then
            Cancel = True
            Target.Font.Bold = True
            Target.Offset(, -2).Font.Bold = True
            
            
             With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
                 .SetText Target
                 .PutInClipboard
             End With
            
            strmgD = Target.Text & vbNewLine & _
                    vbCrLf & _
                    "Copied"
                  
          
                    Set InfoBox = CreateObject("WScript.Shell")
                    AckTime = 1
                    Select Case InfoBox.Popup(strmgD, AckTime, "Notification", 0)
                    Case 1, -1
                    Exit Sub
                    End Select
        
        End If
    
        
        
      
    End If
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub
 

Excel Facts

What does custom number format of ;;; mean?
Three semi-colons will hide the value in the cell. Although most people use white font instead.
Sort by date Sort by votes
Greetings Vincent,

My apologies beforehand, as I will not be able to stay logged in and follow through. That said, for any 'answerer', what exactly 'does not work'? Just looking at the critical part of the code (given the question), I checked against:

VBA Code: 
Sub example()
Dim AckTime As Long, InfoBox As Object

Dim lRet          As Long
Dim dblTimerStart As Double
Dim dblTimerEnd   As Double
 
  Set InfoBox = CreateObject("WScript.Shell")
 
  AckTime = 1&
 
  dblTimerStart = Timer
  lRet = InfoBox.Popup("strmgC", AckTime, "Notification", vbOKOnly)
  dblTimerEnd = Timer
 
  Select Case lRet
  Case 1
    MsgBox "lRet = " & lRet
  Case -1
    MsgBox "lRet = " & lRet & vbLf & "Seconds to dismiss: " & IIf(dblTimerEnd < dblTimerStart, (dblTimerEnd + 86400) - dblTimerStart, dblTimerEnd - dblTimerStart)
  End Select
 

End Sub

The Popup returns correct values, and times out (although horribly inconsistent in timeout value), so curious as to what you are experiencing?

Also, and simply commenting, as you have it exiting the procedure (regardless of the return of the Popup Function), the testing would seem unnecessary as the code is currently.

Mark
 
Last edited:
Upvote 0
Hi Mark, my code is working except that the msgbox does not close itself in one second. It is strange that when I applied two columns as one target range (rngArea), the timer works but after I separated two target columns (rngAreaC and rngAreaD), the timer not working any more !
 
Upvote 0
The scripting popup is buggy to say the least and doesn't always work.

Here is an alternative TimedMsgBox, based on the standard vba MsgBox but optionally forced to behave like a timed popup. This custom Msgbox is also more accurate time-wise.


1- Add a new standard module and place in it the following code :
VBA Code: 
Option Explicit

Public Enum VbTimedMsgBoxResult
    TM_OK = 1
    TM_Cancel = 2
    TM_Abort = 3
    TM_Retry = 4
    TM_Ignore = 5
    TM_Yes = 6
    TM_No = 7
    TM_TimeOut = 8
End Enum

Private Type MENUITEMINFO
    cbSize As Long
    fMask As Long
    fType As Long
    fState As Long
    wID As Long
    #If Win64 Then
        hSubMenu As LongLong
        hbmpChecked As LongLong
        hbmpUnchecked As LongLong
        dwItemData As LongLong
    #Else
        hSubMenu As Long
        hbmpChecked As Long
        hbmpUnchecked As Long
        dwItemData As Long
    #End If
    dwTypeData As String
    cch As Long
    '#if(WINVER >= 0x0500)
    #If Win64 Then
        hbmpItem As LongLong
    #Else
        hbmpItem As Long
    #End If
    '#endif /* WINVER >= 0x0500 */
End Type

#If VBA7 Then
    #If Win64 Then
        Public Declare PtrSafe Function GetTickCount Lib "kernel32" Alias "GetTickCount64" () As LongLong
    #Else
        Public Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long
    #End If
    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
    Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
    Private Declare PtrSafe Function GetForegroundWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function GetSystemMenu Lib "user32" (ByVal hwnd As LongPtr, ByVal bRevert As Long) As LongPtr
    Private Declare PtrSafe Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" (ByVal hMenu As LongPtr, ByVal un As Long, ByVal b As Long, lpMenuItemInfo As MENUITEMINFO) As Long
    Private Declare PtrSafe Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
#Else
    Public Declare Function GetTickCount Lib "kernel32" () As Long
    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 PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function GetForegroundWindow Lib "user32" () As Long
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
    Private Declare Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal b As Long, lpMenuItemInfo As MENUITEMINFO) As Long
    Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
 #End If


Public Function TimedMsgBox( _
    ByVal Prompt As String, _
    Optional ByVal Buttons As VbMsgBoxStyle = vbOKOnly, _
    Optional ByVal Title As String, _
    Optional ByVal SecondsToTimeOut As Single = -1 _
) As VbTimedMsgBoxResult


    Call RemoveProp(Application.hwnd, "TimeOut")
    Call SetTimer(Application.hwnd, 0, SecondsToTimeOut * 1000, AddressOf TimerProc)
    TimedMsgBox = MsgBox(Prompt, Buttons, Title)
    Call KillTimer(Application.hwnd, 0)
    If GetProp(Application.hwnd, "TimeOut") Then
        TimedMsgBox = VbTimedMsgBoxResult.TM_TimeOut
    End If
    Call RemoveProp(Application.hwnd, "TimeOut")

End Function

Private Sub TimerProc()

    Const WM_SYSCOMMAND = &H112
    Const SC_CLOSE = &HF060&
    Const MIIM_STATE = &H1
    Const BM_CLICK = &HF5
   
    Dim ItemInfo As MENUITEMINFO

    Call KillTimer(Application.hwnd, 0)
    If FindWindow("#32770", vbNullString) = GetForegroundWindow Then
        Call SetProp(Application.hwnd, "TimeOut", VbTimedMsgBoxResult.TM_TimeOut)
        ItemInfo.fMask = MIIM_STATE
        ItemInfo.cbSize = LenB(ItemInfo)
        If GetMenuItemInfo(GetSystemMenu(GetForegroundWindow, False), SC_CLOSE, False, ItemInfo) = 0 Then
            Call SendDlgItemMessage(GetForegroundWindow, TM_Ignore, BM_CLICK, 0, 0)
            Call SendDlgItemMessage(GetForegroundWindow, TM_No, BM_CLICK, 0, 0)
        Else
            Call PostMessage(GetForegroundWindow, WM_SYSCOMMAND, SC_CLOSE, ByVal 0)
        End If
    End If

End Sub



2- USAGE EXAMPLE: similar to the example posted by @GTO
VBA Code: 
Sub example()

    Const SECS_TIME_OUT = 3 'Secs <== change timeout const to suit.
   
    #If Win64 Then
        Dim lTimerStart As LongLong, lTimerEnd   As LongLong
    #Else
        Dim lTimerStart As Long, lTimerEnd   As Long
    #End If
   
    Dim lRet As VbTimedMsgBoxResult
   
    lTimerStart = GetTickCount
   
    lRet = TimedMsgBox( _
                    "Do you wish to Log Off and get a life ? ", _
                    vbYesNo, _
                    "Notification", _
                    SecondsToTimeOut:=SECS_TIME_OUT)
       
    lTimerEnd = GetTickCount
   
    If lRet = TM_TimeOut Then
        MsgBox "lRet = " & lRet & vbLf & "Seconds to timeout: " & (lTimerEnd - lTimerStart) / 1000
    Else
        MsgBox "lRet = " & lRet
    End If

End Sub
 
Upvote 0
Solution
GTO said:
Greetings Vincent,

My apologies beforehand, as I will not be able to stay logged in and follow through. That said, for any 'answerer', what exactly 'does not work'? Just looking at the critical part of the code (given the question), I checked against:

VBA Code: 
Sub example()
Dim AckTime As Long, InfoBox As Object

Dim lRet          As Long
Dim dblTimerStart As Double
Dim dblTimerEnd   As Double
 
  Set InfoBox = CreateObject("WScript.Shell")
 
  AckTime = 1&
 
  dblTimerStart = Timer
  lRet = InfoBox.Popup("strmgC", AckTime, "Notification", vbOKOnly)
  dblTimerEnd = Timer
 
  Select Case lRet
  Case 1
    MsgBox "lRet = " & lRet
  Case -1
    MsgBox "lRet = " & lRet & vbLf & "Seconds to dismiss: " & IIf(dblTimerEnd < dblTimerStart, (dblTimerEnd + 86400) - dblTimerStart, dblTimerEnd - dblTimerStart)
  End Select
 

End Sub

The Popup returns correct values, and times out (although horribly inconsistent in timeout value), so curious as to what you are experiencing?

Also, and simply commenting, as you have it exiting the procedure (regardless of the return of the Popup Function), the testing would seem unnecessary as the code is currently.

Mark
Click to expand...
Hi Mark, The code works on Excel 2019 (may be other old versions as well) but not 2021 version. It is strange. Thx any way.
 
Upvote 0
Jaafar Tribak said:
The scripting popup is buggy to say the least and doesn't always work.

Here is an alternative TimedMsgBox, based on the standard vba MsgBox but optionally forced to behave like a timed popup. This custom Msgbox is also more accurate time-wise.


1- Add a new standard module and place in it the following code :
VBA Code: 
Option Explicit

Public Enum VbTimedMsgBoxResult
    TM_OK = 1
    TM_Cancel = 2
    TM_Abort = 3
    TM_Retry = 4
    TM_Ignore = 5
    TM_Yes = 6
    TM_No = 7
    TM_TimeOut = 8
End Enum

Private Type MENUITEMINFO
    cbSize As Long
    fMask As Long
    fType As Long
    fState As Long
    wID As Long
    #If Win64 Then
        hSubMenu As LongLong
        hbmpChecked As LongLong
        hbmpUnchecked As LongLong
        dwItemData As LongLong
    #Else
        hSubMenu As Long
        hbmpChecked As Long
        hbmpUnchecked As Long
        dwItemData As Long
    #End If
    dwTypeData As String
    cch As Long
    '#if(WINVER >= 0x0500)
    #If Win64 Then
        hbmpItem As LongLong
    #Else
        hbmpItem As Long
    #End If
    '#endif /* WINVER >= 0x0500 */
End Type

#If VBA7 Then
    #If Win64 Then
        Public Declare PtrSafe Function GetTickCount Lib "kernel32" Alias "GetTickCount64" () As LongLong
    #Else
        Public Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long
    #End If
    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
    Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
    Private Declare PtrSafe Function GetForegroundWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function GetSystemMenu Lib "user32" (ByVal hwnd As LongPtr, ByVal bRevert As Long) As LongPtr
    Private Declare PtrSafe Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" (ByVal hMenu As LongPtr, ByVal un As Long, ByVal b As Long, lpMenuItemInfo As MENUITEMINFO) As Long
    Private Declare PtrSafe Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
#Else
    Public Declare Function GetTickCount Lib "kernel32" () As Long
    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 PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function GetForegroundWindow Lib "user32" () As Long
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
    Private Declare Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal b As Long, lpMenuItemInfo As MENUITEMINFO) As Long
    Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
 #End If


Public Function TimedMsgBox( _
    ByVal Prompt As String, _
    Optional ByVal Buttons As VbMsgBoxStyle = vbOKOnly, _
    Optional ByVal Title As String, _
    Optional ByVal SecondsToTimeOut As Single = -1 _
) As VbTimedMsgBoxResult


    Call RemoveProp(Application.hwnd, "TimeOut")
    Call SetTimer(Application.hwnd, 0, SecondsToTimeOut * 1000, AddressOf TimerProc)
    TimedMsgBox = MsgBox(Prompt, Buttons, Title)
    Call KillTimer(Application.hwnd, 0)
    If GetProp(Application.hwnd, "TimeOut") Then
        TimedMsgBox = VbTimedMsgBoxResult.TM_TimeOut
    End If
    Call RemoveProp(Application.hwnd, "TimeOut")

End Function

Private Sub TimerProc()

    Const WM_SYSCOMMAND = &H112
    Const SC_CLOSE = &HF060&
    Const MIIM_STATE = &H1
    Const BM_CLICK = &HF5
 
    Dim ItemInfo As MENUITEMINFO

    Call KillTimer(Application.hwnd, 0)
    If FindWindow("#32770", vbNullString) = GetForegroundWindow Then
        Call SetProp(Application.hwnd, "TimeOut", VbTimedMsgBoxResult.TM_TimeOut)
        ItemInfo.fMask = MIIM_STATE
        ItemInfo.cbSize = LenB(ItemInfo)
        If GetMenuItemInfo(GetSystemMenu(GetForegroundWindow, False), SC_CLOSE, False, ItemInfo) = 0 Then
            Call SendDlgItemMessage(GetForegroundWindow, TM_Ignore, BM_CLICK, 0, 0)
            Call SendDlgItemMessage(GetForegroundWindow, TM_No, BM_CLICK, 0, 0)
        Else
            Call PostMessage(GetForegroundWindow, WM_SYSCOMMAND, SC_CLOSE, ByVal 0)
        End If
    End If

End Sub



2- USAGE EXAMPLE: similar to the example posted by @GTO
VBA Code: 
Sub example()

    Const SECS_TIME_OUT = 3 'Secs <== change timeout const to suit.
 
    #If Win64 Then
        Dim lTimerStart As LongLong, lTimerEnd   As LongLong
    #Else
        Dim lTimerStart As Long, lTimerEnd   As Long
    #End If
 
    Dim lRet As VbTimedMsgBoxResult
 
    lTimerStart = GetTickCount
 
    lRet = TimedMsgBox( _
                    "Do you wish to Log Off and get a life ? ", _
                    vbYesNo, _
                    "Notification", _
                    SecondsToTimeOut:=SECS_TIME_OUT)
     
    lTimerEnd = GetTickCount
 
    If lRet = TM_TimeOut Then
        MsgBox "lRet = " & lRet & vbLf & "Seconds to timeout: " & (lTimerEnd - lTimerStart) / 1000
    Else
        MsgBox "lRet = " & lRet
    End If

End Sub
Click to expand...
Hi Jaafar,
Can't image this small function which needs to create lots of codes. Anyway your code works even in Excel 2021 version. Thanks a lot.
 
Upvote 0
Vincent88 said:
Hi Jaafar,
Can't image this small function which needs to create lots of codes. Anyway your code works even in Excel 2021 version. Thanks a lot.
Click to expand...
Thanks for the feedback and happy it worked for you ?
 
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Solved
copying specific info from a cell in Excel to Word
Replies
7
Views
519
Fluff
Fluff
C
  • Question
Message box when opening, show for a set time
Replies
3
Views
3K
dmt32
D
M
  • Question
Run-time error ‘91’: Object variable or With block variable not set
Replies
3
Views
5K
Joe4
Joe4
V
  • Solved
Create New sheet VBA code not working
Replies
6
Views
2K
Zot
Z
J
  • Question
Time a MsgBox
Replies
3
Views
647
Fluff
Fluff

Forum statistics

Threads
1,214,897
Messages
6,122,141
Members
449,066
Latest member
Andyg666

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top