VB6 自定义 Msgbox 和 InputBox 消息框

最新推荐文章于 2024-05-11 00:54:11 发布
有虞先生
最新推荐文章于 2024-05-11 00:54:11 发布
阅读量2.8k
点赞数
分类专栏： VB6
本文链接：https://blog.csdn.net/softvip/article/details/83000866
版权
VB6 专栏收录该内容
8 篇文章 1 订阅
订阅专栏
目前有个问题未解决，当使用 MsgboxEx 函数时，图标样式为 vbExclamation 的话，显示的和 vbCritical 一样是个错误图标，而不是警告图标，不知道是什么原因。我的测试环境是 Win7x64，有明白的大神路过请留言告知，不胜感激！
Option Explicit
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Public Enum NinePlace
    '用户自定义
    NP_UserCustom
    NP_TopLeft
    NP_TopCenter
    NP_TopRight
    NP_MiddleLeft
    NP_MiddleCenter
    NP_MiddleRight
    NP_BottomLeft
    NP_BottomCenter
    NP_BottomRight
End Enum
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
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 UnhookWindowsHookEx Lib "user32" (ByVal hHook 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" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function SystemParametersInfo Lib "user32.dll" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long '去掉 lpvParam 的 ByVal 修饰符才可以正常工作
Private Declare Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
Private Declare Function SetDlgItemText Lib "user32" Alias "SetDlgItemTextA" (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal lpString As String) As Long
Private Declare Function GetDlgItemText Lib "user32" Alias "GetDlgItemTextA" (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
Private Const SPI_GETWORKAREA As Long = &H30
Private Const WH_CBT = &H5
Private Const HCBT_ACTIVATE = &H5
Private BoxHook As Long
Private ParentHandle As Long    '消息框父对象容器句柄
Private ButtonName1 As String, ButtonName2 As String, ButtonName3 As String
Private BoxButtonStyle As Long, BoxPlace As NinePlace, BoxPosTop As Long, BoxPosLeft As Long
'==============================================================
'===========      替代 VB6 中的 InputBox 函数       ===========
'==============================================================
'返回值：   [String]
'           由用户输入的字符串
'           如果用户点击了取消，则返回 vbNullChar [Chr(0)]
'--------------------------------------------------------------
'参数：
'TipsText           [String]    [必选]  提示文本        默认值 vbNullString     显示在消息框窗口上的内容。
'Title              [String]    [可选]  标题栏文本      默认值 vbNullString     显示在消息框标题栏上的文字。
'DefaultText        [String]    [可选]  默认输入的文本  默认值 vbNullString     弹出消息框时即在输入框里存在的文字。
'ButtonTextOK       [String]    [可选]  确定按钮文本    默认值 vbNullString     更改“确定”按钮上的文本，不改变按钮文字可忽略此参数。
'ButtonTextCancel   [String]    [可选]  取消按钮文本    默认值 vbNullString     更改“取消”按钮上的文本，不改变按钮文字可忽略此参数。
'ShowPlace          [NinePlace] [可选]  消息框位置      默认值 NP_MiddleCenter  将消息框按九宫位置弹出。当值为 NP_UserCustom(用户自定义) 时，将按照 PosPixX 和 PosPixY 给出的坐标弹出
'PosPixX            [Long]      [可选]  消息框左边距    默认值 0                当 ShowPlace 参数为 NP_UserCustom 时，消息框位置的横坐标。单位：像素
'PosPixY            [Long]      [可选]  消息框顶边距    默认值 0                当 ShowPlace 参数为 NP_UserCustom 时，消息框位置的纵坐标。单位：像素
'hWnd               [Long]      [可选]  消息框归属句柄  默认值 0                如果 hWnd 参数指向一个窗口或其他父对象容器，ShowPlace、PosPixX、PosPixY 等参数按指向的容器区域计算位置，如果果 hWnd 参数为 0，则根据屏幕工作区计算(除去任务栏等空间的可用区域)。
'HelpFile           [String]    [可选]  帮助文件路径    默认值 vbNullString
'Context            [Number]    [可选]  帮助的上下文    默认值 0
'示例：
'Dim ReturnText As String
'ReturnText = InputBoxEx("请输入您要翻译的内容：" & vbNewLine & "(系统将自动判断您输入的语言)", "中英互译", "Please enter", "开始翻译[&T]", "取消翻译[&C]")
'If ReturnText = vbNullChar Then '用户取消了输入
'    '取消输入后的操作
'ElseIf Len(ReturnText) = 0 Then '用户没有输入内容
'    '未输入内容的操作
'Else
'    'Call TranslateAuto(ReturnText)
'End If
'
Public Function InputBoxEx(TipsText As String, Optional Title As String, Optional DefaultText As String, Optional ButtonTextOK As String = vbNullString, Optional ButtonTextCancel As String = vbNullString, Optional ShowPlace As NinePlace = NP_MiddleCenter, Optional PosPixX As Long = 0, Optional PosPixY As Long = 0, Optional hWnd As Long = 0, Optional HelpFile As String = vbNullString, Optional Context As Long = 0) As String
    Dim ReturnText As String
    '参数不为空(仅对字符串参数有效)
    ButtonName1 = IIf(StrPtr(ButtonTextOK), ButtonTextOK, vbNullChar)
    ButtonName2 = IIf(StrPtr(ButtonTextCancel), ButtonTextCancel, vbNullChar)
    BoxButtonStyle = vbRetryCancel
    BoxPlace = ShowPlace
    BoxPosTop = PosPixY
    BoxPosLeft = PosPixX
    '设置钩子
    BoxHook = SetWindowsHookEx(WH_CBT, AddressOf BoxProc, App.hInstance, App.ThreadID)
    ReturnText = InputBox(TipsText, Title, DefaultText, , , HelpFile, Context)
    If StrPtr(ReturnText) = 0 Then
        InputBoxEx = vbNullChar
    Else
        InputBoxEx = ReturnText
    End If
End Function
'==============================================================
'===========      替代 VB6 中的 InputBox 函数       ===========
'==============================================================
'返回值：   [VbMsgBoxResult]
'           点击了第 1 个按钮：vbYes
'           点击了第 2 个按钮：vbNo
'           点击了第 3 个按钮：vbCancel    '带可取消按钮的消息框按下了 Esc
'--------------------------------------------------------------
'参数：
'TipsText       [String]        [可选]  提示文本        默认值 vbNullString     显示在消息框窗口上的内容。
'Title          [String]        [可选]  标题栏文本      默认值 vbNullString     显示在消息框标题栏上的文字。
'ButtonText1    [String]        [可选]  第 1 个按钮名字 默认值 vbNullString     更改第 1 个按钮上的文本
'ButtonText2    [String]        [可选]  第 1 个按钮名字 默认值 vbNullString     更改第 2 个按钮上的文本
'ButtonText3    [String]        [可选]  第 3 个按钮名字 默认值 vbNullString     更改第 3 个按钮上的文本
'                                                                               当 ButtonText1、ButtonText2、ButtonText3 中某参数被忽略时，将减少相应的按钮数量，但至少保留 1 个
'MsgIcon        [VbMsgBoxStyle] [可选]  消息框图标      默认值 vbOKOnly         取值范围：vbCritical、vbQuestion、vbExclamation、vbInformation，不使用图标可置为 vbOKOnly(0)
'MsgDefault     [VbMsgBoxStyle] [可选]  默认按钮        默认值 vbDefaultButton1 拥有默认焦点的按钮。
'PressCancel    [Boolean]       [可选]  使用取消键      默认值 True             是否可以按下 Esc 选择最后一个按钮。
'ShowPlace      [NinePlace]     [可选]  消息框位置      默认值 NP_MiddleCenter  将消息框按九宫位置弹出。当值为 NP_UserCustom(用户自定义) 时，将按照 PosPixX 和 PosPixY 给出的坐标弹出
'PosPixX        [Long]          [可选]  消息框左边距    默认值 0                当 ShowPlace 参数为 NP_UserCustom 时，消息框位置的横坐标。单位：像素
'PosPixY        [Long]          [可选]  消息框顶边距    默认值 0                当 ShowPlace 参数为 NP_UserCustom 时，消息框位置的纵坐标。单位：像素
'hWnd           [Long]          [可选]  消息框归属句柄  默认值 0                如果 hWnd 参数指向一个窗口或其他父对象容器，ShowPlace、PosPixX、PosPixY 等参数按指向的容器区域计算位置，如果果 hWnd 参数为 0，则根据屏幕工作区计算(除去任务栏等空间的可用区域)。
'HelpFile       [String]        [可选]  帮助文件路径    默认值 vbNullString
'Context        [Number]        [可选]  帮助的上下文    默认值 0
'--------------------------------------------------------------
'示例：
'Dim ReturnAction As VbMsgBoxResult
'ReturnAction = MsgboxEx("请问您使用哪种支付方式？", "扫码支付", "支付宝[&Z]", "微信[&W]", "取消支付",vbQuestion, , , NP_Custom,200 ,100,FrmMain.hWnd)
'If ReturnAction = vbYes Then    '选择了支付宝
'    Call ShowQRCodeAlipay
'ElseIf ReturnAction = vbNo Then '选择了微信
'    Call ShowQRCodeWeChat
'Else                            '选择取消支付
'    Call ShowQRCodeCancel
'End If
'
Public Function MsgboxEx(Optional TipsText As String = vbNullString, Optional ByVal MsgTitle As String = vbNullString, Optional ButtonText1 As String = vbNullString, Optional ButtonText2 As String = vbNullString, Optional ButtonText3 As String = vbNullString, Optional MsgIcon As VbMsgBoxStyle = vbOKOnly, Optional MsgDefault As VbMsgBoxStyle = vbDefaultButton1, Optional PressCancel As Boolean = True, Optional ShowPlace As NinePlace = NP_MiddleCenter, Optional PosPixX As Long = 0, Optional PosPixY As Long = 0, Optional hWnd As Long = 0, Optional HelpFile As String = vbNullString, Optional Context As Long = 0) As VbMsgBoxResult
    Dim MsgStyle As VbMsgBoxStyle
    Dim MsgboxIcon As VbMsgBoxStyle, MsgboxDefault As VbMsgBoxStyle
    Dim ButtonNumber As Long
    Dim ButtonName(2) As String
    Dim MessageReturn As Long
    '计算按钮数量
    If StrPtr(ButtonText1) Then '参数不为空(仅对字符串参数有效)
        ButtonNumber = ButtonNumber + 1
        ButtonName(ButtonNumber - 1) = ButtonText1
    End If
    If StrPtr(ButtonText2) Then
        ButtonNumber = ButtonNumber + 1
        ButtonName(ButtonNumber - 1) = ButtonText2
    End If
    If StrPtr(ButtonText3) Then
        ButtonNumber = ButtonNumber + 1
        ButtonName(ButtonNumber - 1) = ButtonText3
    End If
    '计算消息框样式
    If ButtonNumber = 0 Then        ' 未指定按钮
        ButtonName1 = vbNullChar
        BoxButtonStyle = vbOKOnly
    ElseIf ButtonNumber = 1 Then    ' 1 个按钮
        ButtonName1 = ButtonName(0)
        ButtonNumber = vbOKOnly     'vbOK
    ElseIf ButtonNumber = 2 Then    ' 2 个按钮
        ButtonName1 = ButtonName(0)
        ButtonName2 = ButtonName(1)
        BoxButtonStyle = IIf(PressCancel, vbOKCancel, vbYesNo)
    ElseIf ButtonNumber = 3 Then    ' 3 个按钮
        ButtonName1 = ButtonName(0)
        ButtonName2 = ButtonName(1)
        ButtonName3 = ButtonName(2)
        BoxButtonStyle = IIf(PressCancel, vbYesNoCancel, vbAbortRetryIgnore)
    End If
    '单独剔出默认按钮，防止其他样式混乱。
    If (vbDefaultButton2 And MsgDefault) = vbDefaultButton2 Then
        MsgboxDefault = vbDefaultButton2
    ElseIf (vbDefaultButton3 And MsgDefault) = vbDefaultButton3 Then
        MsgboxDefault = vbDefaultButton3
    Else
        MsgboxDefault = vbDefaultButton1
    End If
    '单独剔出消息图标，防止其他样式混乱。
    If (vbCritical And MsgIcon) = vbCritical Then
        MsgboxIcon = vbCritical
    ElseIf (vbQuestion And MsgIcon) = vbQuestion Then
        MsgboxIcon = vbQuestion
    ElseIf (vbExclamation And MsgIcon) = vbExclamation Then
        MsgboxIcon = vbExclamation
    ElseIf (vbInformation And MsgIcon) = vbInformation Then
        MsgboxIcon = vbInformation
    End If
    '整理消息框模式: 样式  图标  默认按钮
    MsgStyle = BoxButtonStyle Or MsgboxIcon Or MsgboxDefault
    '记录消息框弹出位置
    BoxPlace = ShowPlace
    BoxPosTop = PosPixY
    BoxPosLeft = PosPixX
    '标题跟随应用名称
    If MsgTitle = vbNullChar Then MsgTitle = App.EXEName
    '将当前窗口的句柄付给模块级变量
    ParentHandle = hWnd
    '设置钩子
    BoxHook = SetWindowsHookEx(WH_CBT, AddressOf BoxProc, App.hInstance, App.ThreadID)
    '调用 MessageBox API
    'MessageReturn = MessageBox(hWnd, TipsText, MsgTitle, MsgStyle)
    MessageReturn = MsgBox(TipsText, MsgStyle, MsgTitle, HelpFile, Context)
    '处理返回值
    Select Case BoxButtonStyle
    Case vbOKOnly
        MsgboxEx = vbYes
    Case vbOKCancel
        MsgboxEx = IIf(MessageReturn = vbOK, vbYes, vbNo)
    Case vbYesNo
        MsgboxEx = IIf(MessageReturn = vbYes, vbYes, vbNo)
    Case vbYesNoCancel
        If MessageReturn = vbCancel Then
            MsgboxEx = vbCancel
        Else
            MsgboxEx = IIf(MessageReturn = vbYes, vbYes, vbNo)
        End If
    Case vbAbortRetryIgnore
        If MessageReturn = vbIgnore Then
            MsgboxEx = vbCancel
        Else
            MsgboxEx = IIf(MessageReturn = vbAbort, vbYes, vbNo)
        End If
    End Select
End Function
'勾子过程
Public Function BoxProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim ParentArea As RECT
    Dim BoxArea As RECT
    Dim BoxWidth As Long, BoxHeight As Long
    Dim LeftAdjust As Long, TopAdjust As Long
    '当 MessageBox 出现时，改变位置
    If nCode = HCBT_ACTIVATE Then
        '修改按钮的文字
        Select Case BoxButtonStyle '消息为 HCBT_ACTIVATE 时，参数wParam包含的是MessageBox的句柄
        Case vbOKOnly                                                                           '=== MessageBox ===
            If Not ButtonName1 = vbNullChar Then SetDlgItemText wParam, vbOK, ButtonName1       '第 1 个按钮
        Case vbOKCancel
            If Not ButtonName1 = vbNullChar Then SetDlgItemText wParam, vbOK, ButtonName1       '第 1 个按钮
            If Not ButtonName2 = vbNullChar Then SetDlgItemText wParam, vbCancel, ButtonName2   '第 2 个按钮
        Case vbYesNo
            If Not ButtonName1 = vbNullChar Then SetDlgItemText wParam, vbYes, ButtonName1      '第 1 个按钮
            If Not ButtonName2 = vbNullChar Then SetDlgItemText wParam, vbNo, ButtonName2       '第 2 个按钮
        Case vbYesNoCancel
            If Not ButtonName1 = vbNullChar Then SetDlgItemText wParam, vbYes, ButtonName1      '第 1 个按钮
            If Not ButtonName2 = vbNullChar Then SetDlgItemText wParam, vbNo, ButtonName2       '第 2 个按钮
            If Not ButtonName3 = vbNullChar Then SetDlgItemText wParam, vbCancel, ButtonName3   '第 3 个按钮
        Case vbAbortRetryIgnore
            If Not ButtonName1 = vbNullChar Then SetDlgItemText wParam, vbAbort, ButtonName1    '第 1 个按钮
            If Not ButtonName2 = vbNullChar Then SetDlgItemText wParam, vbRetry, ButtonName2    '第 2 个按钮
            If Not ButtonName3 = vbNullChar Then SetDlgItemText wParam, vbIgnore, ButtonName3   '第 3 个按钮
        Case vbRetryCancel                                                                      '===  InputBox  ===
            If Not ButtonName1 = vbNullChar Then SetDlgItemText wParam, vbOK, ButtonName1
            If Not ButtonName2 = vbNullChar Then SetDlgItemText wParam, vbCancel, ButtonName2
        End Select
        '获取消息框的区域
        Call GetWindowRect(wParam, BoxArea)
        '获取父对象区域
        If ParentHandle = 0 Then    '屏幕区域
            Call SystemParametersInfo(SPI_GETWORKAREA, 0, ParentArea, 0)
        Else                        '窗体区域
            Call GetWindowRect(ParentHandle, ParentArea)
        End If
        '计算 MessageBox 尺寸
        BoxWidth = BoxArea.Right - BoxArea.Left
        BoxHeight = BoxArea.Bottom - BoxArea.Top
        If BoxPlace = NP_UserCustom Then    '用户自定义
            TopAdjust = BoxPosTop
            LeftAdjust = BoxPosLeft
        Else
            Select Case BoxPlace    '计算调整后的顶边距
            Case NP_TopLeft, NP_TopCenter, NP_TopRight
                TopAdjust = ParentArea.Top
            Case NP_MiddleLeft, NP_MiddleCenter, NP_MiddleRight
                TopAdjust = CLng((ParentArea.Bottom - ParentArea.Top - BoxHeight) / 2)
            Case NP_BottomLeft, NP_BottomCenter, NP_BottomRight
                TopAdjust = ParentArea.Bottom - BoxHeight
            End Select
            Select Case BoxPlace    '计算调整后的左边距
            Case NP_TopLeft, NP_MiddleLeft, NP_BottomLeft
                LeftAdjust = ParentArea.Left
            Case NP_TopCenter, NP_MiddleCenter, NP_BottomCenter
                LeftAdjust = CLng((ParentArea.Right - ParentArea.Left - BoxWidth) / 2)
            Case NP_TopRight, NP_MiddleRight, NP_BottomRight
                LeftAdjust = ParentArea.Right - BoxWidth
            End Select
        End If
        'Msgbox 位置调整
        Call MoveWindow(wParam, LeftAdjust, TopAdjust, BoxWidth, BoxHeight, True)
        '卸载钩子
        UnhookWindowsHookEx BoxHook
    End If
    BoxProc = False
End Function