[RESOLVED] Center MsgBox to a form created with MessageBoxIndirect

[Mith]

Is it somehow possible to center a MsgBox created with MessageBoxIndirect to the calling form?
Maybe via MSGBOXCALLBACK?

[Elroy]

You have to put a callback address (of a VB6 procedure) in the lpfnMsgBoxCallback item of the MSGBOXPARAMS structure, and then center it in the callback procedure.

[Mith]

You have to put a callback address (of a VB6 procedure) in the lpfnMsgBoxCallback item of the MSGBOXPARAMS structure, and then center it in the callback procedure.

I tried it, but the callback function never triggers.

My code:

Private Type MSGBOXPARAMS
  cbSize As Long             
  hwndOwner As Long          
  hInstance As Long          
  lpszText As Long           
  lpszCaption As Long        
  dwStyle As Long            
  lpszIcon As Long           
  dwContextHelpId As Long    
  lpfnMsgBoxCallback As Long 
  dwLanguageId As Long                           
End Type

Private Type POINT_TYPE
  x As Long
  y As Long
End Type

Private Type HELPINFO
  cbSize As Long
  iContextType As Long
  iCtrlId As Long
  hItemHandle As Long
  dwContextId As Long
  MousePos As POINT_TYPE
End Type

Private Declare Function MessageBoxIndirectW Lib "user32" (lpMsgBoxParams As MSGBOXPARAMS) As Long

Public Function MsgBoxW(...) As VbMsgBoxResult

Dim MsgParams As MSGBOXPARAMS

....

With MsgParams
   .cbSize = Len(MsgParams)
   .hwndOwner = m_hWnd
   .hInstance = App.hInstance
   .lpszText = StrPtr(sText)
   .lpszCaption = StrPtr(m_sMsgBoxCaption)
   .dwStyle = Buttons
   .lpszIcon = StrPtr(sResourceIcon)
   .dwContextHelpId = 0
   .lpfnMsgBoxCallback = DummyFunc(AddressOf MsgBoxCallback)
   .dwLanguageId = 0
End With

MsgBoxW = MessageBoxIndirectW(MsgParams)

End Function

Public Sub MsgBoxCallback(lpHelpInfo As HELPINFO)
   
   Debug.Print lpHelpInfo.hItemHandle
   Debug.Print lpHelpInfo.iCtrlId
   
End Sub

Public Function DummyFunc(ByVal param As Long) As Long
  DummyFunc = param
End Function

Any ideas?

[VanGoghGaming]

The callback function is useless here, it only gets triggered when the user clicks the help button or presses F1. You need to install a CBT hook if you want to alter the position of the message box.

Here's an example of such a CBT Hook used to manipulate an InputBox.

[Elroy]

Ahhh, sorry I didn't get post #2 correct. I've done this before, but I wasn't sitting at my development computer, and I'm still not.

If I remember, I'll post some code later today that does this.

[Mith]

If I remember, I'll post some code later today that does this.

That whould be really nice!

[Elroy]

Here's a post that shows how to get a callback going for a message box (when it's loaded).

I even talk about where you'd put your code in to move it before any user interaction. I know I've actually done the centering before, but I can't find it right now, but this should get you there.

All that's left to do is some GetWindowRect and maybe ScreenToClient and/or ClientToScreen calls to figure out where you actually want to put it. Those API calls aren't difficult to use, but I'll leave that to you.

[Mith]

Here's a post that shows how to get a callback going for a message box (when it's loaded).

Thanks a lot for the example. The MessageBox is now centered with the active Desktop Window!

My "center" code for the hook proc:

Public Function MsgBoxHookProc(ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

         Dim rcForm As RECT
         Dim rcMsgBox As RECT
         Dim X As Long
         Dim Y As Long
         Dim FormW As Long
         Dim FormH As Long
         Dim MsgBoxW As Long
         Dim MsgBoxH As Long

         Const HCBT_ACTIVATE = 5
         
10       If uMsg = HCBT_ACTIVATE Then
               
20          GetWindowRect m_hWndForm, rcForm ' GetActiveWindow()
30          GetWindowRect wParam, rcMsgBox
40          FormW = (rcForm.Right - rcForm.Left)
50          FormH = (rcForm.Bottom - rcForm.Top)
            
60          MsgBoxW = (rcMsgBox.Right - rcMsgBox.Left)
70          MsgBoxH = (rcMsgBox.Bottom - rcMsgBox.Top)
            
80          X = rcForm.Left + ((FormW / 2) - (MsgBoxW / 2))
90          Y = rcForm.Top + ((FormH / 2) - (MsgBoxH / 2))
100         SetWindowPos wParam, HWND_TOPMOST, X, Y, 0, 0, SWP_NOZORDER Or SWP_NOSIZE Or SWP_SHOWWINDOW
         
110           UnhookWindowsHookEx MSGHOOK.hHook

120       End If

130       MsgBoxHookProc = False

End Function

[Elroy]

Very nice. The only suggestion I might make is to use integer division (\) rather than floating point division (/) in your X & Y calculations, but I suppose it really doesn't matter that much.

Glad you got it done.

[VanGoghGaming]

And there are twice as many divisions as necessary but who's nitpicking?

[Mith]

i guess you mean this:

80          X = rcForm.Left + ((FormW - MsgBoxW) \ 2)
90          Y = rcForm.Top + ((FormH - MsgBoxH) \ 2)

[VanGoghGaming]

Too many parenthesis now!

[Krool]

Here is another appreach without hooks.
It uses SetClassLongPtr API which is safe as it affects only newly created #32770 dialog boxes and only within this process. (not system-wide)
The original class procedure is restored so that it does not affect any subsequent calls to the native MsgBox function.

Option Explicit
#If (VBA7 = 0) Then
Private Enum LongPtr
[_]
End Enum
#End If
#If Win64 Then
Private Const NULL_PTR As LongPtr = 0
Private Const PTR_SIZE As Long = 8
#Else
Private Const NULL_PTR As Long = 0
Private Const PTR_SIZE As Long = 4
#End If
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type MSGBOXPARAMS
cbSize As Long
hWndOwner As LongPtr
hInstance As LongPtr
lpszText As LongPtr
lpszCaption As LongPtr
dwStyle As Long
lpszIcon As LongPtr
dwContextHelpID As Long
lpfnMsgBoxCallback As LongPtr
dwLanguageId As Long
End Type
#If VBA7 Then
Private Declare PtrSafe Function MessageBoxIndirect Lib "user32" Alias "MessageBoxIndirectW" (ByRef lpMsgBoxParams As MSGBOXPARAMS) As Long
Private Declare PtrSafe Function GetWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal wCmd As Long) As LongPtr
Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function GetForegroundWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, ByRef lpRect As RECT) As Long
Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hWnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal CX As Long, ByVal CY As Long, ByVal wFlags As Long) As Long
#If Win64 Then
Private Declare PtrSafe Function SetClassLongPtr Lib "user32" Alias "SetClassLongPtrW" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
#Else
Private Declare PtrSafe Function SetClassLongPtr Lib "user32" Alias "SetClassLongW" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
#End If
Private Declare PtrSafe Function CreateWindowEx Lib "user32" Alias "CreateWindowExW" (ByVal dwExStyle As Long, ByVal lpClassName As LongPtr, ByVal lpWindowName As LongPtr, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, ByRef lpParam As Any) As LongPtr
Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcW" (ByVal lpPrevWndFunc As LongPtr, ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Private Declare PtrSafe Function DefWindowProc Lib "user32" Alias "DefWindowProcW" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
#Else
Private Declare Function MessageBoxIndirect Lib "user32" Alias "MessageBoxIndirectW" (ByRef lpMsgBoxParams As MSGBOXPARAMS) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, ByRef 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 Declare Function SetClassLongPtr Lib "user32" Alias "SetClassLongW" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExW" (ByVal dwExStyle As Long, ByVal lpClassName As Long, ByVal lpWindowName As Long, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, ByRef lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcW" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcW" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#End If
Private Const GCLP_WNDPROC As Long = (-24)
Private Const WS_POPUP As Long = &H80000000
#If VBA7 Then
Private Const HWND_DESKTOP As LongPtr = &H0
#Else
Private Const HWND_DESKTOP As Long = &H0
#End If
Private Const GW_OWNER As Long = &H4
Private Const SWP_NOSIZE As Long = &H1
Private Const SWP_NOACTIVATE As Long = &H10
Private Const SWP_NOOWNERZORDER As Long = &H200
Private Const SWP_NOZORDER As Long = &H4
Private Const WM_ACTIVATE As Long = &H6, WA_ACTIVE As Long = &H1
Private MsgBoxCenteredOrigProcPtr As LongPtr

Public Function MsgBoxCentered(ByVal Prompt As String, Optional ByVal Buttons As VbMsgBoxStyle = vbOKOnly, Optional ByVal Title As String) As VbMsgBoxResult
Dim hWndClass As LongPtr
hWndClass = CreateWindowEx(0, StrPtr("#32770"), NULL_PTR, WS_POPUP, 0, 0, 0, 0, HWND_DESKTOP, NULL_PTR, App.hInstance, ByVal NULL_PTR)
If hWndClass <> NULL_PTR Then
    If MsgBoxCenteredOrigProcPtr = NULL_PTR Then MsgBoxCenteredOrigProcPtr = SetClassLongPtr(hWndClass, GCLP_WNDPROC, AddressOf MsgBoxCenteredWndProc)
End If
Dim MSGBOXP As MSGBOXPARAMS
With MSGBOXP
.cbSize = LenB(MSGBOXP)
If (Buttons And vbSystemModal) = 0 Then
    If Not Screen.ActiveForm Is Nothing Then
        .hWndOwner = Screen.ActiveForm.hWnd
    Else
        .hWndOwner = GetActiveWindow()
    End If
Else
    .hWndOwner = GetForegroundWindow()
End If
.hInstance = App.hInstance
.lpszText = StrPtr(Prompt)
If Title = vbNullString Then Title = App.Title
.lpszCaption = StrPtr(Title)
.dwStyle = Buttons
End With
MsgBoxCentered = MessageBoxIndirect(MSGBOXP)
If MsgBoxCenteredOrigProcPtr <> NULL_PTR Then
    SetClassLongPtr hWndClass, GCLP_WNDPROC, MsgBoxCenteredOrigProcPtr
    MsgBoxCenteredOrigProcPtr = NULL_PTR
End If
If hWndClass <> NULL_PTR Then DestroyWindow hWndClass
End Function

Private Function MsgBoxCenteredWndProc(ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
If wMsg = WM_ACTIVATE And wParam = WA_ACTIVE Then
    Dim hWndOwner As LongPtr
    hWndOwner = GetWindow(hWnd, GW_OWNER)
    Dim RC(0 To 1) As RECT, X As Long, Y As Long
    GetWindowRect hWnd, RC(0)
    GetWindowRect hWndOwner, RC(1)
    X = RC(1).Left + (((RC(1).Right - RC(1).Left) \ 2) - ((RC(0).Right - RC(0).Left) \ 2))
    Y = RC(1).Top + (((RC(1).Bottom - RC(1).Top) \ 2) - ((RC(0).Bottom - RC(0).Top) \ 2))
    SetWindowPos hWnd, NULL_PTR, X, Y, 0, 0, SWP_NOSIZE Or SWP_NOOWNERZORDER Or SWP_NOZORDER Or SWP_NOACTIVATE
End If
If MsgBoxCenteredOrigProcPtr <> NULL_PTR Then
    MsgBoxCenteredWndProc = CallWindowProc(MsgBoxCenteredOrigProcPtr, hWnd, wMsg, wParam, lParam)
Else
    MsgBoxCenteredWndProc = DefWindowProc(hWnd, wMsg, wParam, lParam)
End If
End Function

[VanGoghGaming]

I remember trying superclassing a long time ago and it was definitely systemwide. Things may have changed since then...