Option Explicit
Private Declare Function GetSystemMetrics _
Lib "user32" (ByVal nIndex As Long) 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 FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowRect Lib "user32" _
(ByVal hwnd As Long, lpRect As RECT) 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 Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_NOZORDER = &H4
Private dXpos As Variant
Private dYpos As Variant
Private lTimerID As Long
Private Sub TimerProc()
Dim uMsgBoxRect As RECT
Dim dMsgboxWidth As Double
Dim dMsgboxHeight As Double
Dim lMsgboxhwnd As Long
Dim lScreenWidth As Long
Dim lScreenHeight As Long
'timer no longer required
KillTimer 0, lTimerID
'get the screen dims
lScreenWidth = GetSystemMetrics(SM_CXSCREEN)
lScreenHeight = GetSystemMetrics(SM_CYSCREEN)
'get the msgbox handle
lMsgboxhwnd = FindWindow("#32770", vbNullString)
'get the msgbox rect
GetWindowRect lMsgboxhwnd, uMsgBoxRect
'get the msgbox width and height
With uMsgBoxRect
dMsgboxWidth = (.Right - .Left)
dMsgboxHeight = (.Bottom - .Top)
End With
'if the XPos , YPos are ignored, center the Msgbox
If IsNull(dXpos) Then dXpos = (lScreenWidth - dMsgboxWidth) / 2
If IsNull(dYpos) Then dYpos = (lScreenHeight - dMsgboxHeight) / 2
'ensure Msgbox is never offscreen
If dXpos + dMsgboxWidth > lScreenWidth Then dXpos = _
lScreenWidth - dMsgboxWidth
If dYpos + dMsgboxHeight > lScreenHeight Then dYpos = _
lScreenHeight - dMsgboxHeight - 50 'takes into account the approx Taskbar height
dXpos = WorksheetFunction.Max(dXpos, 0)
dYpos = WorksheetFunction.Max(dYpos, 0)
'postion the msgbox
SetWindowPos lMsgboxhwnd, 0, dXpos _
, dYpos, 0, 0, SWP_NOSIZE Or SWP_NOZORDER Or SWP_NOACTIVATE
End Sub
Private Function MsgBoxEx(Prompt As String, Optional Buttons As VbMsgBoxStyle = vbOKOnly, _
Optional Title As String, Optional HelpFile, _
Optional Context, Optional XPos, Optional YPos) As VbMsgBoxResult
If IsMissing(XPos) Then XPos = Null
If IsMissing(YPos) Then YPos = Null
'pass the x,y params to a module level var
dXpos = XPos
dYpos = YPos
'start a timer to position the msgbox
lTimerID = SetTimer(0, 0, 1, AddressOf TimerProc)
'display the msgbox and gets its return
MsgBoxEx = MsgBox(Prompt, Buttons, Title, HelpFile, Context)
End Function
Sub Test()
MsgBoxEx Prompt:="hello from the screen TopLeft!", Buttons:=vbInformation, _
Title:="Positioning of Msgbox Demo.", XPos:=0, YPos:=0
MsgBoxEx Prompt:="hello from the screen BottomRight!", Buttons:=vbInformation, _
Title:="Positioning of Msgbox Demo.", XPos:=100000, YPos:=100000
MsgBoxEx Prompt:="hello from the screen Center!", Buttons:=vbInformation, _
Title:="Positioning of Msgbox Demo."
End Sub
