'API生成窗体
Option Explicit
Public Declare Function RegisterClass Lib "user32" Alias "RegisterClassA" (Class As WNDCLASS) As Long
Public Declare Function UnregisterClass Lib "user32" Alias "UnregisterClassA" (ByVal lpClassName As String, ByVal hInstance As Long) As Long
Public Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As Msg, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long
Public Declare Function TranslateMessage Lib "user32" (lpMsg As Msg) As Long
Public Declare Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As Msg) As Long
Public Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Public Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Any) As Long
Public Declare Function LoadIcon Lib "user32" Alias "LoadIconA" (ByVal hInstance As Long, ByVal lpIconName As String) As Long
Public Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, 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, lpParam As Any) As Long
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public 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
Public Declare Sub PostQuitMessage Lib "user32" (ByVal nExitCode As Long)
Public Type WNDCLASS
style As Long
lpfnwndproc As Long
cbClsextra As Long
cbWndExtra2 As Long
hInstance As Long
hIcon As Long
hCursor As Long
hbrBackground As Long
lpszMenuName As String
lpszClassName As String
End Type
Public Type POINTAPI
x As Long
y As Long
End Type
Public Type Msg
hwnd As Long
message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI
End Type
Public Const CS_VREDRAW = &H1
Public Const CS_HREDRAW = &H2
Public Const CW_USEDEFAULT = &H80000000
Public Const ES_MULTILINE = &H4&
Public Const WS_BORDER = &H800000
Public Const WS_CHILD = &H40000000
Public Const WS_OVERLAPPED = &H0&
Public Const WS_CAPTION = &HC00000 ' WS_BORDER Or WS_DLGFRAME
Public Const WS_SYSMENU = &H80000
Public Const WS_THICKFRAME = &H40000
Public Const WS_MINIMIZEBOX = &H20000
Public Const WS_MAXIMIZEBOX = &H10000
Public Const WS_OVERLAPPEDWINDOW = (WS_OVERLAPPED Or WS_CAPTION Or WS_SYSMENU Or WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX)
Public Const WS_EX_CLIENTEDGE = &H200&
Public Const COLOR_WINDOW = 5
Public Const WM_DESTROY = &H2
Public Const WM_LBUTTONDOWN = &H201
Public Const WM_LBUTTONUP = &H202
Public Const IDC_ARROW = 32512&
Public Const IDI_APPLICATION = 32512&
Public Const GWL_WNDPROC = (-4)
Public Const SW_SHOWNORMAL = 1
Public Const MB_OK = &H0&
Public Const MB_ICONEXCLAMATION = &H30&
Public Const gClassName = "MyClassName"
Public Const gAppName = "My Window Caption"
Public gButOldProc As Long ''Will hold address of the old window proc for the button
Public gHwnd As Long, gButtonHwnd As Long, gEditHwnd As Long ''You don't necessarily need globals, but if you're planning to gettext and stuff, then you're gona have to store the hwnds.
Public Sub Main()
Dim wMsg As Msg
''Call procedure to register window classname. If false, then exit.
If RegisterWindowClass = False Then Exit Sub
''Create window
If CreateWindows Then
''Loop will exit when WM_QUIT is sent to the window.
Do While GetMessage(wMsg, 0&, 0&, 0&)
''TranslateMessage takes keyboard messages and converts
''them to WM_CHAR for easier processing.
Call TranslateMessage(wMsg)
''Dispatchmessage calls the default window procedure
''to process the window message. (WndProc)
Call DispatchMessage(wMsg)
Loop
End If
Call UnregisterClass(gClassName$, App.hInstance)
End Sub
Public Function RegisterWindowClass() As Boolean
Dim wc As WNDCLASS
''Registers our new window with windows so we
''can use our classname.
wc.style = CS_HREDRAW Or CS_VREDRAW
wc.lpfnwndproc = GetAddress(AddressOf WndProc) ''Address in memory of default window procedure.
wc.hInstance = App.hInstance
wc.hIcon = LoadIcon(0&, IDI_APPLICATION) ''Default application icon
wc.hCursor = LoadCursor(0&, IDC_ARROW) ''Default arrow
wc.hbrBackground = COLOR_WINDOW ''Default a color for window.
wc.lpszClassName = gClassName$
RegisterWindowClass = RegisterClass(wc) <> 0
End Function
Public Function CreateWindows() As Boolean
''Create actual window.
gHwnd& = CreateWindowEx(0&, gClassName$, gAppName$, WS_OVERLAPPEDWINDOW, CW_USEDEFAULT, CW_USEDEFAULT, 208, 150, 0&, 0&, App.hInstance, ByVal 0&)
''Create button
gButtonHwnd& = CreateWindowEx(0&, "Button", "Click Here", WS_CHILD, 58, 90, 85, 25, gHwnd&, 0&, App.hInstance, 0&)
''Create textbox with a border (WS_EX_CLIENTEDGE) and make it multi-line (ES_MULTILINE)
gEditHwnd& = CreateWindowEx(WS_EX_CLIENTEDGE, "Edit", "This is the edit control." & vbCrLf & "As you can see, it's multiline.", WS_CHILD Or ES_MULTILINE, 0&, 0&, 200, 80, gHwnd&, 0&, App.hInstance, 0&)
End Function
Public Function ButtonWndProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case uMsg&
Case WM_LBUTTONUP:
Call MessageBox(gHwnd&, "You clicked the button!", App.Title, MB_OK Or MB_ICONEXCLAMATION)
End Select
ButtonWndProc = CallWindowProc(gButOldProc&, hwnd&, uMsg&, wParam&, lParam&)
End Function
Public Function GetAddress(ByVal lngAddr As Long) As Long
GetAddress = lngAddr&
End Function
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 hFormhWnd As Long
'''''''''''''''''''''''''''''''''''''''''''''''''''''
'替代VB中的Msgbox函数
'''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function Msgbox(hWnd As Long, sPrompt As String, _
Optional dwStyle As Long, _
Optional sTitle As String) As Long
'''''''''''''''''''''''''''''''''''''''''''''''''''''
'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
'卸载钩子
UnhookWindowsHookEx hHook
End If
CBTProc = False
End Function
2·窗体中的代码:
Form1中的-----
Option Explicit
Private Sub Command1_Click()
'变量声明
Dim strTitle As String
Dim strPrompt As String
Dim lngStyle As Long
'MessageBox的标题
strTitle = "我的应用"
'MessageBox的内容
strPrompt = "这是 hook MessageBox 的演示" & vbCrLf & vbCrLf & _
"MessageBox的对话框将会居中在Form中"
'MessageBox样式
lngStyle = vbAbortRetryIgnore Or vbInformation
Select Case Msgbox(hWnd, strPrompt, lngStyle, strTitle)
Case vbRetry: Text1.Text = "Retry button 按下"
Case vbAbort: Text1.Text = "Abort button 按下"
Case vbIgnore: Text1.Text = "Ignore button 按下"
End Select
End Sub
Private Sub Command2_Click()
Form2.Show
End Sub
Form2中的-----
Option Explicit
Private Sub Command1_Click()
Call Msgbox(Me.hWnd, "确定按钮展示!", 0, "")
End Sub