让MsgBox居中

最新推荐文章于 2024-05-31 07:36:50 发布

留下些什么

最新推荐文章于 2024-05-31 07:36:50 发布

阅读量482

点赞数

分类专栏： VB实例源码文章标签： windows

本文链接：https://blog.csdn.net/zezese/article/details/132144318

版权

VB实例源码专栏收录该内容

31 篇文章 2 订阅

订阅专栏

借助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