basemsg.bas

本系统是一个报表分析查询系统

Attribute VB_Name = "BaseMsg"
Private Const WH_CBT = 5
Private Const HCBT_ACTIVATE = 5

Private Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type

'使用API的MessageBox替代VB系统的MsgBox
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
   
Public 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 hHook As Long
Private Const IDOK = 1
Private Const IDCANCEL = 2
Private Const IDABORT = 3
Private Const IDRETRY = 4
Private Const IDIGNORE = 5
Private Const IDYES = 6
Private Const IDNO = 7
Private Const IDPROMPT = &HFFFF&

'----------------------窗体句柄----------------------'
Private hFormhWnd As Long

 


'''''''''''''''''''''''''''
'替代VB中的Msgbox函数
'''''''''''''''''''''''''''
Public Function MsgboxEx(hWnd As Long, sPrompt As String, _
                       Optional dwStyle As Long, _
                       Optional sTitle As String) As Long
  
    Dim hInstance As Long
    Dim hThreadId As Long
    
    hInstance = App.hInstance
    hThreadId = App.ThreadID
    
    If dwStyle = 0 Then dwStyle = vbOKOnly
    If Len(sTitle) = 0 Then sTitle = App.EXEName
       
    '将当前窗口的句柄付给变量
    hFormhWnd = hWnd
    
    '设置钩子
    hHook = SetWindowsHookEx(WH_CBT, _
                            AddressOf CBTProc, _
                            hInstance, hThreadId)
    '调用MessageBox API
    MsgboxEx = MessageBox(hWnd, sPrompt, sTitle, dwStyle)

End Function


'''''''''''''''''''''''''''
'HOOK处理
'''''''''''''''''''''''''''
Public Function CBTProc(ByVal nCode As Long, _
                               ByVal wParam As Long, _
                               ByVal lParam As Long) As Long
      
    '变量声明
    Dim rc As RECT
    Dim rcFrm As RECT
    
    Dim newLeft As Long
    Dim newTop As Long
    Dim dlgWidth As Long
    Dim dlgHeight As Long
    Dim scrWidth As Long
    Dim scrHeight As Long
    Dim frmLeft As Long
    Dim frmTop As Long
    Dim frmWidth As Long
    Dim frmHeight As Long
    Dim hwndMsgBox As Long
    
'    Dim lngHwnd As Long
    '当MessageBox出现时，将Msgbox对话框居中与所在的窗口
    If nCode = HCBT_ACTIVATE Then
        '消息为HCBT_ACTIVATE时，参数wParam包含的是MessageBox的句柄
        hwndMsgBox = wParam
        '得到MessageBox对话框的Rect
        Call GetWindowRect(hwndMsgBox, rc)
        Call GetWindowRect(hFormhWnd, rcFrm)
        '使MessageBox居中
        frmLeft = rcFrm.Left
        frmTop = rcFrm.Top
        frmWidth = rcFrm.Right - rcFrm.Left
        frmHeight = rcFrm.Bottom - rcFrm.Top

        dlgWidth = rc.Right - rc.Left
        dlgHeight = rc.Bottom - rc.Top
      
        scrWidth = Screen.Width \ Screen.TwipsPerPixelX
        scrHeight = Screen.Height \ Screen.TwipsPerPixelY
      
        newLeft = frmLeft + ((frmWidth - dlgWidth) \ 2)
        newTop = frmTop + ((frmHeight - dlgHeight) \ 2)
        '修改确定按钮的文字
        Call SetDlgItemText(hwndMsgBox, IDOK, "0x")
        Call SetDlgItemText(hwndMsgBox, IDABORT, "组列表")
        Call SetDlgItemText(hwndMsgBox, IDRETRY, "组资料")
        Call SetDlgItemText(hwndMsgBox, IDIGNORE, "放弃打印")
        'Msgbox居中
        Call MoveWindow(hwndMsgBox, newLeft, newTop, dlgWidth, dlgHeight, True)
      
        '卸载钩子
        UnhookWindowsHookEx hHook
    End If
    CBTProc = False
End Function