借助Windows Hook,我们可以让MsgBox现实在其的父窗口中间。
新建一个标准EXE工程,加入一个窗体和一个标准模块。
窗体代码如下:
'用户昵称: 留下些什么
'个人简介: 一个会做软件的货代
'CSDN网址:https://blog.csdn.net/zezese
'电子邮箱:31319180@qq.com
Option Explicit
Private Sub Command1_Click()
MsgBox "我在中间了吗?", vbQuestion
End Sub
标准模块代码如下:
'用户昵称: 留下些什么
'个人简介: 一个会做软件的货代
'CSDN网址:https://blog.csdn.net/zezese
'电子邮箱:31319180@qq.com
Option Explicit
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetParent Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function IsIconic Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Private Declare Function GetWindowRect Lib "user32.dll" (ByVal hwnd As Long, ByRef lpRect As RECT) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Const WH_CBT As Long = 5
Private Const HCBT_ACTIVATE As Long = 5
Private Const GW_OWNER As Long = 4
Private m_HookCBT As Long
Private m_HasMoved As Boolean
' 在工程里面加入本模块,就可以让所有的消息框居中,无需修改任何代码。
Public Function MsgBox(ByVal Prompt As String, Optional Buttons As VbMsgBoxStyle = vbOKOnly, Optional Title, Optional HelpFile, Optional Context) As VbMsgBoxResult
m_HasMoved = False
m_HookCBT = SetWindowsHookEx(WH_CBT, AddressOf MsgBoxHook, App.hInstance, GetCurrentThreadId())
'调用VBA模块里面的MsgBox, 要用VBA.MsgBox,否则会递归
MsgBox = VBA.MsgBox(Prompt, Buttons, Title, HelpFile, Context)
End Function
Private Function MsgBoxHook(ByVal ncode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
MsgBoxHook = CallNextHookEx(m_HookCBT, ncode, wParam, lParam)
If HCBT_ACTIVATE = ncode And Not m_HasMoved Then
m_HasMoved = True
MoveDlg wParam
UnhookWindowsHookEx m_HookCBT
End If
End Function
Private Sub MoveDlg(ByVal hDlg As Long)
Dim dRect As RECT
Dim fRect As RECT
Dim dTop As Long, dLeft As Long, dWidth As Long, dHeight As Long
Dim fhWnd As Long
fhWnd = GetWindow(hDlg, GW_OWNER)
If fhWnd = 0 Then Exit Sub
If IsIconic(fhWnd) Then Exit Sub
'获取窗口位置数据
GetWindowRect hDlg, dRect
GetWindowRect fhWnd, fRect
dWidth = dRect.Right - dRect.Left
dHeight = dRect.Bottom - dRect.Top
'计算新的位置
dTop = fRect.Top + (fRect.Bottom - fRect.Top) / 2 - (dHeight) / 2
dLeft = fRect.Left + (fRect.Right - fRect.Left) / 2 - (dWidth) / 2
'判断是否超出屏幕边缘
If dTop < 0 Then dTop = 0
If dLeft < 0 Then dLeft = 0
If dLeft + dWidth > GetScreenWidth Then dLeft = GetScreenWidth - dWidth
If dTop + dHeight > GetScreenHeight - 40 Then dTop = GetScreenHeight - 40 - dHeight
Call MoveWindow(hDlg, dLeft, dTop, dWidth, dHeight, 1)
End Sub
Private Function GetScreenWidth() As Long
GetScreenWidth = VB.Screen.Width / VB.Screen.TwipsPerPixelX
End Function
Private Function GetScreenHeight() As Long
GetScreenHeight = VB.Screen.Height / VB.Screen.TwipsPerPixelY
End Function