Making a Message Box appear on top of all other windows

[Atreides]

Hi,

I am trying to set up a reminder box to pop-up via excel. This is currently
working using OnTime. However, it only pops-up in Excel. I'd like to make it
appear on top of all my windows so I can see it (otherwise it's not a very
good reminder is it?) Any help on this?

Also, how can I get the timer to start once I open the workbook? The
Workbook_Open() command doesn't seem to do it.

My code so far is below.

Thanks
Atreides




Public RunWhen As Double
Public Const cRunIntervalSeconds = 1800
Public Const cRunWhat = "The_Sub"

Private Sub Workbook_Open()
StartTimer
End Sub


Sub StartTimer()

RunWhen = Now + TimeSerial(0, 0, cRunIntervalSeconds)
Application.OnTime earliesttime:=RunWhen, procedure:=cRunWhat, _
schedule:=True
End Sub

Sub The_Sub()

MsgBox "Fill in timesheet"
StartTimer

End Sub

 

[NickHK]

Atreides,
Using the MsgBox in VBA is tied to the Excel window, so it cannot appear in
front of other windows.
There's the API route:
http://vbnet.mvps.org/code/comdlg/messageboxex.htm

Or possibly NetSend, if the Messaging service is available:
http://vbnet.mvps.org/code/network/netmessagebuffersend.htm

NickHK

 

[Atreides]

Hi NickHK,

I see what you are getting at, but those demos are far too complex for a VBA
newbie such as myself. Do you have anything simpler?

Thanks
Atreides

 

[NickHK]

Not if you want it work outside of the Excel window; you have to work with
the Windows system some way or other.
See here for some explanation, see the end of this article:
http://www.angelfire.com/biz/rhaminisys/support.html

Here's a stripped down API version. You can play with the flags indicated in
the above article, to get the appearance/style you want. This does take the
user to Excel when the msgbox is dismissed. Maybe playing with the flags can
prevent this, if required.
I have wrapped the call in a function, so you can use it similar to VBA
MsgBox.

Remember that you have to declare any additional const that you use, similar
to those below :

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal
lpClassName As String, _
ByVal
lpWindowName As String) _
As Long


Private Declare Function MessageBox Lib "user32" Alias "MessageBoxA" (ByVal
HWnd As Long, _
ByVal
lpText As String, _
ByVal
lpCaption As String, _
ByVal
wType As Long) _
As Long

'Flags
'Ensure the MsgBox is seen on top of all others
Private Const MB_SETFOREGROUND As Long = &H10000
Private Const MB_TOPMOST As Long = &H40000

'Determines if the app (Excel) is blocked until the msgbox is dismissed
Private Const MB_TASKMODAL As Long = &H2000&
'Default
Private Const MB_APPLMODAL As Long = &H0&
'Doubt you want this one
Private Const MB_SYSTEMMODAL As Long = &H1000&

'Which buttons/icon to display
Private Const MB_OK As Long = &H0&
Private Const MB_ICONINFORMATION As Long = &H40&


Private Sub CommandButton1_Click()
Dim RetVal As Long
Dim Flags As Long

Call MyMsgBox("Your attention is required", "Message from Excel", True)

End Sub

Public Function MyMsgBox(MsgText As String, _
MsgCaption As String, _
Optional ShowOnTop As Boolean = True, _
Optional ByVal Flags As Long = MB_OK Or
MB_ICONINFORMATION)
Dim HWnd As Long

HWnd = FindWindow("XLMAIN", Application.Caption)
'If only XL2002 and up, you can this instead
'HWnd = Application.HWnd

If ShowOnTop = True Then Flags = Flags Or MB_TOPMOST

Call MessageBox(HWnd, MsgText, MsgCaption, Flags)

End Function

NickHK

 

[NickHK]

And a simplified example using Net Send. Note that the Messaging service
need to enabled for this to work. Some admins disable this, so check if that
if this does not work.
As this API uses Unicode, you need to use byte arrays in the actual call.
Again the API is wrapped in a simple function call.
You can get help with these API call by using the API-Guide from the link
provided.

'Adapted from the example found the API-Guide
http://www.allapi.net/agnet/apiguide.shtml
Private Declare Function NetMessageBufferSend Lib "NETAPI32.DLL" (yServer As
Any, _
yToName As Byte,
_
yFromName As
Any, _
yMsg As Byte, _
ByVal lSize As
Long) _
As Long

'Error return values
Private Const ERROR_ACCESS_DENIED As Long = 5
Private Const ERROR_BAD_NETPATH As Long = 53
Private Const ERROR_INVALID_PARAMETER As Long = 87
Private Const ERROR_NOT_SUPPORTED As Long = 50
Private Const ERROR_INVALID_NAME As Long = 123
Private Const NERR_BASE As Long = 2100
Private Const NERR_SUCCESS As Long = 0
Private Const NERR_NetworkError As Long = (NERR_BASE + 36)
Private Const NERR_NameNotFound As Long = (NERR_BASE + 173)
Private Const NERR_UseNotFound As Long = (NERR_BASE + 150)

Private Sub CommandButton1_Click()
Dim RetVal As Boolean

RetVal = NetSendMsgBox("You are required in Excel")

End Sub

Public Function NetSendMsgBox(MsgText As String) _
As Boolean
Dim RcptTo() As Byte
Dim From() As Byte
Dim Body() As Byte
Dim RetVal As Long

RcptTo = Environ("UserName") & vbNullChar
From = Environ("UserName") & vbNullChar
Body = MsgText & vbNullChar

RetVal = NetMessageBufferSend(ByVal 0&, RcptTo(0), ByVal 0&, Body(0),
UBound(Body))
If RetVal = NERR_SUCCESS Then
NetSendMsgBox = True
Else
Debug.Print RetVal
NetSendMsgBox = False
End If

End Function

NickHK

 

[NickHK]

That should read "Messenger" service, not "Messaging".

NickHK
Isn't "Messaging" to do with MS Instant Messenger, or whatever the latest
incarnation is called ?