这是我最近作为练习时写的一些东东，也算是一些经验和技巧。主要是CWinApp.Cls、CWindows.Cls和WinAppModule.Bas。以上三者共同协作，使你方便地在VB中处理
各种各样的消息，子类化窗口，很容易就能屏蔽掉消息。希望它能为大家提供方便。
也很希望大家指正错误之处，谢谢大家。另外有一些声明是多余的。这是因为有些东西我以后还会在添加的，所以没有清理。如果你认为不必要，大可把它删掉。
************************WinAppModule.Bas*************************
Option Explicit
'-------------------------------------------------------------------------------
'******************************** WinAppModule *********************************
'-------------------------------------------------------------------------------
' 作者：无影无踪
' 时间：2003年5月14日
'-------------------------------------------------------------------------------
' WinAppModule主要为CWinApp提供一些最原始的服务（RawWndProc）。唯一用户
' 必须调用的是InitApp，并且必须在使用CWinApp和CWindow之前。
'--------------------------------------------------------------------------------
'--------------------------------------------------------------------------------
' 例子：
' Private Sub Form1_Load()
' Call InitApp 64
' ...
' End Sub
'--------------------------------------------------------------------------------
Public Const DEF_WINDOWS = 64
Public winapp As CWinApp '整个程序唯一的一个CWinApp 的实例
'初始化必须的函数
Public Sub InitApp(Optional ByVal cbArraySize As Integer = DEF_WINDOWS)
If (winapp Is Nothing) Then
Set winapp = New CWinApp
winapp.OneTimeInit cbArraySize
End If
End Sub
'原始的窗口消息分发入口点函数
Public Function RawWndProc(ByVal hwnd As Long, ByVal umsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
RawWndProc = winapp.ProcessMessage(hwnd, umsg, wParam, lParam)
End Function
'函数地址转换函数
Public Function ConvProcAddr(ByVal TargetProc As Long) As Long
ConvProcAddr = TargetProc
End Function
***************************CWinApp.Cls*************************
Option Explicit
'-------------------------------------------------------------------------------
'******************************** CWinApp Class ********************************
'-------------------------------------------------------------------------------
' 作者：无影无踪
' 时间：2003年5月14日
'-------------------------------------------------------------------------------
' CWinApp类与CWindow类共同协作，管理Windows的消息处理系统。CWinApp主要负责
' 管理消息的，集中处理，初始分派的工作。需要注意每个程序只需要也只能有一个
' CWinApp实例winapp，并且需要一个原始的消息入口函数RawWndProc。因此，需要
' WinAppModule的协作。winapp会保证对每个CWindow对象实例引用和所创建的窗体
' 的唯一性。也就说在winapp中没有重复的引用和没有重复的窗口（句柄为0的除外）。
' 你真正需要理解的是CWindow类。
' OneTimeInit是一次性的初始化方法函数。
'--------------------------------------------------------------------------------
Private 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
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Any, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Const GWL_EXSTYLE = (-20)
Const GWL_HINSTANCE = (-6)
Const GWL_HWNDPARENT = (-8)
Const GWL_ID = (-12)
Const GWL_STYLE = (-16)
Const GWL_USERDATA = (-21)
Const GWL_WNDPROC = (-4)
Private WinArray() As CWindow '用于存放不同的CWindow实例
Private cbCurWin As Long '已拥有的CWindow实例数量
Private preindex As Integer '已注册的准备创建窗口的CWindow实例在WinArray中的索引号
Private cbWinArray As Integer
Private Sub Class_Initialize()
Dim i As Integer
cbCurWin = 0
preindex = -1 '没有任何的注册准备创建的窗口
cbWinArray = 0
End Sub
'一次性的初始化方法函数
Public Function OneTimeInit(ByVal cbArraySize As Integer) As Boolean
Dim i As Integer
i = 0
If (cbWinArray <> 0 Or cbArraySize <= 0) Then
OneTimeInit = False
Exit Function
End If
On Error GoTo ErrHandler
ReDim WinArray(cbArraySize - 1)
cbWinArray = cbArraySize
Do While (i < cbWinArray)
Set WinArray(i) = Nothing
i = i + 1
Loop
OneTimeInit = True
Exit Function
ErrHandler:
OneTimeInit = False
End Function
'向WinArray添加一个CWindow实例的引用
Public Function AddWindow(ByVal win As CWindow) As Boolean
Dim ind As Integer
ind = FindWinHandle(win.hwnd)
If ind <> -1 And win.hwnd <> 0 Then 'One window can not share by 2 CWindow instances.
AddWindow = False
Exit Function
End If
ind = FindWindow(win)
If ind <> -1 Then ' This Object was already added,we will just return.
AddWindow = True
Exit Function
End If
ind = FindFreeBlock() ' Look for a free block to store this object.
If ind <> -1 Then
Set WinArray(ind) = win ' Add a ref to this object.
cbCurWin = cbCurWin + 1 ' Increment the element count.
AddWindow = True
Else
AddWindow = False ' There is no free block now.
End If
End Function
'从WinArray中取消指定的CWindow实例的引用
Public Function RemoveWindow(ByVal win As CWindow) As Boolean
Dim ind As Integer
ind = FindWindow(win)
If (ind <> -1) Then
If (ind = preindex) Then preindex = -1 'This will never be True.But it's not harmful to do this check.
Set WinArray(ind) = Nothing ' Unref to this object.
cbCurWin = cbCurWin - 1 ' Decrement the element count.
RemoveWindow = True
Else
RemoveWindow = False ' We will tell the caller the object is not exist.
End If
End Function
'查找指定CWindow实例在WinArray中的索引号
Private Function FindWindow(ByVal win As CWindow) As Integer
Dim i As Integer, ind As Integer
i = 0
ind = -1 '以防万一，先把结果定为“找不到”。
Do While (i < cbWinArray)
If (WinArray(i) Is win) Then
ind = i 'Get it.
Exit Do
End If
i = i + 1
Loop
FindWindow = ind
End Function
'查找指定窗口句柄在WinArray中的索引号
Private Function FindWinHandle(ByVal hwin As Long) As Integer
Dim i As Integer, ind As Integer
i = 0
ind = -1 '以防万一，先把结果定为“找不到”。
Do While (i < cbWinArray)
If (Not (WinArray(i) Is Nothing)) Then
If (WinArray(i).hwnd = hwin) Then
ind = i ' Get it.
Exit Do
End If
End If
i = i + 1
Loop
FindWinHandle = ind
End Function
'查找是否尚有空间。
Private Function FindFreeBlock() As Integer
Dim i As Integer
Dim ind As Integer
i = 0
ind = -1 '以防万一，先把结果定为“找不到”。
If cbCurWin = cbWinArray Then
FindFreeBlock = -1 ' 没有足够空间了。
Exit Function
End If
Do While (i < cbWinArray)
If (WinArray(i) Is Nothing) Then
ind = i ' 找到空余的地方
Exit Do
End If
i = i + 1
Loop
FindFreeBlock = ind
End Function
Private Sub Class_Terminate()
Dim i As Integer
i = 0
Do While (i < cbWinArray)
If (Not (WinArray(i) Is Nothing)) Then
Set WinArray(i) = Nothing ' Unref all objects so they can be free if there is no more ref counts.
cbCurWin = cbCurWin - 1
End If
i = i + 1
Loop
End Sub
' 进一步的窗口消息分发处理函数
' 该函数先查找是否有存在对应hwnd的CWindow实例的引用。有则把消息分发给该实例。
' 如果找不到，接着检查preindex是否表明有已注册的等待创建的窗口。如果preindex
' 有效则看看WinArray(preindex)是否有效（因为可能这个实例已Remove了）。
' 如果WinArray(preindex)有效则再检查它的hwnd成员是否为0（表明没有窗口），如果
' hwnd成员为0则调用WinArray(preindex)的消息处理入口函数，并且preindex也会被
' reset（preindex = -1）。因为只需一次就可以完成了，WinArray(preindex)在消息
' 处理入口函数中会执行 WinArray(preindex).m_hwnd = hwnd。
' 如果以上的条件都不成立，则会依据情况来执行CallWindowProc或者DefWindowProc的调用。
Public Function ProcessMessage(ByVal hwnd As Long, ByVal umsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim ind As Integer
Dim orgwndproc As Long
ind = FindWinHandle(hwnd)
If (ind <> -1) Then
ProcessMessage = WinArray(ind).WinProc(hwnd, umsg, wParam, lParam)
ElseIf (preindex <> -1 And Not (WinArray(preindex) Is Nothing) And WinArray(preindex).hwnd = 0) Then
ind = preindex
preindex = -1
ProcessMessage = WinArray(ind).WinProc(hwnd, umsg, wParam, lParam)
Else
orgwndproc = GetWindowLong(hwnd, GWL_WNDPROC)
If (orgwndproc <> 0 And orgwndproc <> ConvProcAddr(AddressOf RawWndProc)) Then
'You should know this trueth: Although orgwndproc <> ConvProcAddr(AddressOf ConvProcAddr).
'RawWndProc can be called because orgwndproc can just contain something which is meaningful
'to the CallWindowProc API.So use the RegisterCls and Create(Ex) member function of
'CWindow to create the window.and Make sure use SubClass member function of CWindow
'to subclass a window when you need our service.
ProcessMessage = CallWindowProc(orgwndproc, hwnd, umsg, wParam, lParam)
Else
ProcessMessage = DefWindowProc(hwnd, umsg, wParam, lParam)
End If
End If
End Function
'登记准备创建的窗口对象实例。该实例必须先添加到WinArray中。
Public Function RegisterPreCreateWin(ByVal win As CWindow) As Long
Dim ind As Integer
ind = FindWindow(win)
If (ind <> -1) Then 'Get it
If (preindex <> -1 And ind <> preindex) Then
RegisterPreCreateWin = -1 'Someone else had already registered.
Else
preindex = ind
RegisterPreCreateWin = 1 ' Ok
End If
Else
RegisterPreCreateWin = 0 ' Can't find it.
End If
End Function
'取消原来的登记，请确保此方法的调用者之前曾成功调用RegisterPreCreateWin并且
'还没有调用CreateWindow(Ex)。
Public Function UnRegisterPreCreateWin() As Long
UnRegisterPreCreateWin = preindex
preindex = -1
End Function
*************************CWindow.Cls**************************
Option Explicit
'-------------------------------------------------------------------------------
'******************************** CWindow Class ********************************
'-------------------------------------------------------------------------------
' 作者：无影无踪
' 时间：2003年5月14日
'-------------------------------------------------------------------------------
' CWindow类为你提供方便的窗体子类化、窗体创建方法，并且提供方便快捷的消息
' 映射机制，使你更专注于为你感兴趣的消息的处理工作。该类必须与CWinApp、共
' 同协作。然而该类只要求你调用它的RegisterCls方法注册窗口类。调用Create(Ex)
' 来创建相应窗体。或者你需要子类化某窗体，只需调用SubClass方法，当你不需要
' 时，调用UnSubClass方法。如果你要处理某些消息，则应该在创建或子类化之前通
' 过AddWMHandler、SetFirstHandler、SetDefHandler等设置相应的消息处理函数入
' 口。你务必先调用InitWMMapperSize方法分配足够的空间。另外你需要注意的是，
' 尽量不要跨线程访问该类的实例。因为它是相当于单线程单元的。
' 处理消息的函数的原型如下：
' Public Function WMHandler(ByVal win As CWindow, ByVal umsg As Long,_
' ByVal wParam As Long, ByVal lParam As Long) As Long
' 当你需要原来的或者默认的消息处理的话，请调用DoSubProcessing方法。
'
' *必须说明一下，整个类的巧妙所在就是通过入口地址对入口函数进行回掉。这在
' C或C++等当中本来是轻而易举的事情。但由于VB是不支持指针操作的。因而需要
' 一些技巧。幸好Windows API中又一个CallWindowProc。本来它是用于调用原来的
' Window Proc，并且因应需要做一些字符串的转换。但是它也可以用来调用任何
' 入口地址。同时，它为我们提供了4颗子弹，足够一般的需要了。因此，我们的
' 消息回掉就可以顺利的进行，我们能够通过函数地址来调用函数了。：）*
'
'-------------------------------------------------------------------------------
'-------------------------------------------------------------------------------
' 例子：
'
' Dim Spy As New CWindow
'
' Private Sub Form1_Load()
' Call InitApp 64
' Spy.InitWMMapperSize 2
' End Sub
'
' Private Sub Command1_Click()
' If (Spy.SubClass(Text1.hwnd) = True) Then
' Call Spy.SetFirstHandler(AddressOf MainHandler)
' Call Spy.AddWMHandler(WM_RBUTTONUP, AddressOf OnRBtUp)
' Call Spy.AddWMHandler(WM_CHAR, AddressOf OnChar)
' Else
' MsgBox "SubClass Failed."
' End If
' End Sub
'
' 在另一个模块中定义这些函数
'
' Public Function MainHandler(ByVal win As CWindow, ByVal umsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
' Debug.Print umsg
' win.bContinueProcess = True
' End Function
'
' Public Function OnRBtUp(ByVal win As CWindow, ByVal umsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
' Call ReleaseCapture
' MsgBox "大哥，弹我出来你觉得很有趣吗？ )=<"
' OnRBtUp = 0
' End Function
'
' Public Function OnChar(ByVal win As CWindow, ByVal umsg As Long, ByVal vKeyCode As Long, ByVal lParam As Long) As Long
' If (vKeyCode = 13) Then '判断是否回车键
' OnChar = 0 '讨厌的“叮叮”声没了，整个世界都清静了（用于单行文本）。
' Else
' OnChar = win.DoSubProcessing(umsg, vKeyCode, lParam)
' End If
' End Function
'----------------------------------------------------------------------------------
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Any, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private 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
Private 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, ByVal lpParam As Long) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function SendMessageCallback Lib "user32" Alias "SendMessageCallbackA" (ByVal hwnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal lpResultCallBack As Long, ByVal dwData As Long) As Long
Private Declare Function SendMessageTimeout Lib "user32" Alias "SendMessageTimeoutA" (ByVal hwnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal fuFlags As Long, ByVal uTimeout As Long, lpdwResult As Long) As Long
Private Declare Function SendNotifyMessage Lib "user32" Alias "SendNotifyMessageA" (ByVal hwnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOZORDER = &H4
Private Const SWP_FRAMECHANGED = &H20 ' The frame changed: send WM_NCCALCSIZE
Private Declare Function IsWindow 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 SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function IsChild Lib "user32" (ByVal hWndParent As Long, ByVal hwnd As Long) As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Type MSG
hwnd As Long
message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI
End Type
Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
Private Declare Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As MSG) As Long
Private 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
Private Declare Function RegisterClass Lib "user32" Alias "RegisterClassA" (Class As WNDCLASS) As Long
Const GWL_EXSTYLE = (-20)
Const GWL_HINSTANCE = (-6)
Const GWL_HWNDPARENT = (-8)
Const GWL_ID = (-12)
Const GWL_STYLE = (-16)
Const GWL_USERDATA = (-21)
Const GWL_WNDPROC = (-4)
Const WM_NCDESTROY = &H82
Const WM_USER = &H400
Const COLOR_WINDOW = 5
'Structure of the mapper
Private Type WMMapper
WinMessage As Long 'Message needed to handle.
WMHandler As Long 'Handler to map.
End Type
Private m_hwnd As Long '窗口句柄
Private bSubClassing As Boolean 'Indicates if the window is being subclassed
Private OldWndProc As Long 'If the window is subclassed,this var is the address of the org window proc.
Private winappref As CWinApp 'The ref to the unique CWinApp instance.
Private AWMHandler() As WMMapper 'The array of the message handler mapper.
Private FirstHandler As Long 'The entry point to the first-chance message handler
Private DefHandler As Long 'The entry point to the default message handler.
Public bContinueProcess As Boolean 'Declare if we need to continue processing after the FirstHandler is called.
Private cbWMMapper As Long 'Element count of the handler-mapper array.
Private Sub Class_Initialize()
m_hwnd = 0
OldWndProc = 0
bSubClassing = False
Set winappref = Nothing
bContinueProcess = True
FirstHandler = 0
DefHandler = 0
cbWMMapper = 0
End Sub
Private Sub Class_Terminate()
If m_hwnd <> 0 Then
DestroyWindow m_hwnd 'We will never come here normally,but it's not harmful to write the code.
m_hwnd = 0
End If
If (Not (winappref Is Nothing)) Then
winappref.RemoveWindow Me
Set winappref = Nothing
End If
End Sub
Private Sub Free()
If (bSubClassing = True) Then
Call UnSubClass
End If
m_hwnd = 0
FirstHandler = 0
DefHandler = 0
OldWndProc = 0
bSubClassing = False
bContinueProcess = True
If (Not (winappref Is Nothing)) Then
winappref.RemoveWindow Me
Set winappref = Nothing
End If
' You should remove the message handler-mapper yourself.
End Sub
' The Entry point of the message proc called by winapp.
Public Function WinProc(ByVal hwin As Long, ByVal umsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim result As Long
Dim i As Long
' It's important do this since the hwnd member will be 0 when the window is just created
' and before CreateWindow(Ex) return.So, this time, only hwin is reliable.set it to m_hwnd.
m_hwnd = hwin
'If the FirstHandler was installed,give it the first-chance to handle message.
If (FirstHandler <> 0) Then
' The FirstHandler should set bContinueProcess to make sure if the message
' should be continued to process after it returns.
result = CallWindowProc(FirstHandler, ByVal Me, umsg, wParam, lParam)
If (bContinueProcess = False) Then
If (umsg <> WM_NCDESTROY) Then
WinProc = result
Exit Function
Else ' umsg = WM_NCDESTROY,we will do some work to free.
WinProc = DoSubProcessing(umsg, wParam, lParam)
Call Free
Exit Function
End If
End If
End If
i = FindWMHandler(umsg) 'Check and map.
If (i <> -1) Then
WinProc = CallWindowProc(AWMHandler(i).WMHandler, ByVal Me, umsg, wParam, lParam)
ElseIf (DefHandler <> 0) Then 'No message handler.We will give it to the DefHandler if it is valid.
WinProc = CallWindowProc(DefHandler, ByVal Me, umsg, wParam, lParam)
Else 'No one is intertested of this message? Do sub process now.
WinProc = DoSubProcessing(umsg, wParam, lParam)
End If
If (umsg = WM_NCDESTROY) Then
Call Free ' Do some work to free.
End If
End Function
' Subclass a window
Public Function SubClass(ByVal hwin) As Boolean
If (bSubClassing = True Or m_hwnd <> 0) Then
SubClass = False
Exit Function
End If
If (winappref Is Nothing) Then Set winappref = winapp
m_hwnd = hwin
If (winappref.AddWindow(Me) = True) Then
OldWndProc = SetWindowLong(hwin, GWL_WNDPROC, AddressOf RawWndProc)
If (OldWndProc <> 0) Then
m_hwnd = hwin
bSubClassing = True
SubClass = True
Else
SubClass = False
winappref.RemoveWindow Me
Set winappref = Nothing
End If
Else
m_hwnd = 0
Set winappref = Nothing
SubClass = False
End If
End Function
Public Function UnSubClass() As Boolean
If (bSubClassing = False) Then
UnSubClass = True
Else
SetWindowLong m_hwnd, GWL_WNDPROC, OldWndProc
m_hwnd = 0
bSubClassing = False
winappref.RemoveWindow Me
Set winappref = Nothing
UnSubClass = True
End If
End Function
Public Function Create(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, ByVal lpParam As Long) As Boolean
Create = CreateEx(0, lpClassName, lpWindowName, dwStyle, x, y, nwidth, nheight, hWndParent, hMenu, hinstance, lpParam)
End Function
Public Function CreateEx(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, ByVal lpParam As Long) As Boolean
If (m_hwnd <> 0) Then
CreateEx = False
Exit Function
End If
If (winappref Is Nothing) Then Set winappref = winapp
If (winappref.AddWindow(Me) = False) Then
Set winappref = Nothing
CreateEx = False
Exit Function
End If
' It's important to call RegisterPreCreateWin if you want to
' process WM_NCCREATE、WM_CREATE etc. Because these messages
' will be sent to you before CreateWindow(Ex) return.If you don't
' register,the winapp can not find the reference to this object
' instance because the hwnd menber will be null before any message
' will be sent to the WinProc.
' When you registered,we should call CreateWindow(Ex) imediatelly.
' Because it will prevent others to register their own window.
' Please not to call Create(Ex) if you didn't use RegisterCls member
' function to register the window class.
If (winappref.RegisterPreCreateWin(Me) <= 0) Then
CreateEx = False
winappref.RemoveWindow Me
Set winappref = Nothing
Exit Function
End If
m_hwnd = CreateWindowEx(dwExStyle, lpClassName, lpWindowName, dwStyle, x, y, nwidth, nheight, hWndParent, hMenu, hinstance, lpParam)
If (m_hwnd = 0) Then
CreateEx = False
winappref.RemoveWindow Me
Set winappref = Nothing
Exit Function
Else
CreateEx = True
End If
End Function
Public Function DestroyWin() As Long
DestroyWin = DestroyWindow(m_hwnd)
End Function
Public Function AddWMHandler(ByVal umsg As Long, ByVal WMHandlerProc As Long) As Long
Dim i As Long
If (umsg > 65535 Or umsg < 0) Then
AddWMHandler = -1
Exit Function
End If
i = FindWMHandler(umsg)
If (i <> -1) Then
AWMHandler(i).WinMessage = umsg
AddWMHandler = AWMHandler(i).WMHandler
AWMHandler(i).WMHandler = WMHandlerProc
Else
i = FindFreeWMHandler()
If (i <> -1) Then
AWMHandler(i).WinMessage = umsg
AddWMHandler = AWMHandler(i).WMHandler
AWMHandler(i).WMHandler = WMHandlerProc
Else
AddWMHandler = -1
End If
End If
End Function
Public Function RemoveWMHandler(ByVal umsg As Long) As Long
Dim i As Long
If (umsg > 65535 Or umsg < 0) Then
RemoveWMHandler = -1
Exit Function
End If
i = FindWMHandler(umsg)
If (i <> -1) Then
AWMHandler(i).WinMessage = 1
RemoveWMHandler = AWMHandler(i).WMHandler
AWMHandler(i).WMHandler = 0
Else
RemoveWMHandler = -1
End If
End Function
Public Sub RemoveAllWMHandler()
Dim i As Long
i = 0
Do While (i < cbWMMapper)
AWMHandler(i).WinMessage = -1
AWMHandler(i).WMHandler = 0
i = i + 1
Loop
End Sub
Public Function RegisterCls(ByVal lpszClassName As String, ByVal cstyle As Long, ByVal hinstance As Long, ByVal hbkbrush As Long, ByVal hicon As Long, ByVal hcursor As Long, ByVal lpszMenuName As String) As Boolean
Dim wc As WNDCLASS
wc.cbClsExtra = 0
wc.cbWndExtra2 = 0
wc.hbrBackground = hbkbrush
wc.hcursor = hcursor
wc.hicon = hicon
wc.hinstance = hinstance
wc.lpszClassName = lpszClassName
wc.lpszMenuName = lpszMenuName
wc.lpfnWndProc = ConvProcAddr(AddressOf RawWndProc)
RegisterCls = RegisterClass(wc)
End Function
' Note:The message handler should call this function if they need
' the original processing or the default processing.You needn't to
' say if you should call CallWindowProc or call DefWindowProc because
' this function has enough AI and do this for you. :)
Public Function DoSubProcessing(ByVal umsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If (bSubClassing = True) Then
DoSubProcessing = CallWindowProc(OldWndProc, m_hwnd, umsg, wParam, lParam)
Else
DoSubProcessing = DefWindowProc(m_hwnd, umsg, wParam, lParam)
End If
End Function
Public Function SetFirstHandler(ByVal NewFHProc As Long) As Long
SetFirstHandler = FirstHandler
FirstHandler = NewFHProc
End Function
Public Function RemoveFirstHandler() As Long
RemoveFirstHandler = FirstHandler
FirstHandler = 0
End Function
Public Function SetDefHandler(ByVal NewDHProc As Long) As Long
SetDefHandler = DefHandler
DefHandler = NewDHProc
End Function
Public Function RemoveDefHandler() As Long
RemoveDefHandler = DefHandler
DefHandler = 0
End Function
Public Function SendMsg(ByVal umsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
SendMsg = SendMessage(m_hwnd, umsg, wParam, lParam)
End Function
Public Function PostMsg(ByVal umsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
PostMsg = PostMessage(m_hwnd, umsg, wParam, lParam)
End Function
'You must call this function to allocate or reallocate the handler-mapper array.
'You should also note that when you reallocate the array, all the handler will
'be removed,and you must add them again if you need.
Public Function InitWMMapperSize(ByVal cbSize As Integer) As Boolean
On Error GoTo ErHandler
ReDim AWMHandler(cbSize - 1)
InitWMMapperSize = True
cbWMMapper = cbSize
Call RemoveAllWMHandler
Exit Function
ErHandler:
InitWMMapperSize = False
End Function
Public Function FindWMHandler(ByVal umsg As Long) As Long
Dim ind As Long
Dim i As Long
ind = -1
i = 0
Do While (i < cbWMMapper)
If (AWMHandler(i).WinMessage = umsg) Then
ind = i
Exit Do
End If
i = i + 1
Loop
FindWMHandler = ind
End Function
Public Function FindFreeWMHandler() As Long
Dim ind As Long
Dim i As Long
ind = -1
i = 0
Do While (i < cbWMMapper)
If (AWMHandler(i).WinMessage = -1) Then
ind = i
Exit Do
End If
i = i + 1
Loop
FindFreeWMHandler = ind
End Function
Public Property Let style(ByVal dwNewStyle As Long)
If (IsWindow(m_hwnd) <> 0) Then
SetWindowLong m_hwnd, GWL_STYLE, dwNewStyle
SetWindowPos m_hwnd, 0, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE Or SWP_NOZORDER Or SWP_FRAMECHANGED
End If
End Property
Public Property Get style() As Long
If (IsWindow(m_hwnd) <> 0) Then
style = GetWindowLong(m_hwnd, GWL_STYLE)
Else
style = 0
End If
End Property
Public Property Let exstyle(ByVal dwNewExStyle As Long)
If (IsWindow(m_hwnd) <> 0) Then
SetWindowLong m_hwnd, GWL_EXSTYLE, dwNewExStyle
SetWindowPos m_hwnd, 0, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE Or SWP_NOZORDER Or SWP_FRAMECHANGED
End If
End Property
Public Property Get exstyle() As Long
If (IsWindow(m_hwnd) <> 0) Then
exstyle = GetWindowLong(m_hwnd, GWL_EXSTYLE)
Else
exstyle = 0
End If
End Property
Public Property Let WinTitle(ByVal szTitle As String)
If (IsWindow(m_hwnd) <> 0) Then
SetWindowText m_hwnd, szTitle
End If
End Property
Public Property Get WinTitle() As String
Dim szTitle As String
szTitle = String(256, Chr(0))
If (IsWindow(m_hwnd) <> 0) Then
GetWindowText m_hwnd, szTitle, 255
End If
WinTitle = szTitle
End Property
Public Property Get hwnd() As Long
hwnd = m_hwnd
End Property
Public Property Let Left(ByVal leftpos As Long)
Dim wndrect As RECT
Dim pt As POINTAPI
Dim hparent As Long
Dim x As Long, y As Long
Dim nwidth As Long
Dim nheight As Long
If (IsWindow(m_hwnd) <> 0) Then
Call GetWindowRect(m_hwnd, wndrect)
x = leftpos
y = wndrect.Top
nwidth = wndrect.Right - wndrect.Left
nheight = wndrect.Bottom - y
hparent = GetParent(m_hwnd)
If (hparent <> 0) Then
pt.y = y
ScreenToClient hparent, pt
y = pt.y
End If
MoveWindow m_hwnd, x, y, nwidth, nheight, 1
End If
End Property
Public Property Get Left() As Long
Dim wndrect As RECT
Dim pt As POINTAPI
Dim hparent As Long
If (IsWindow(m_hwnd) <> 0) Then
Call GetWindowRect(m_hwnd, wndrect)
pt.x = wndrect.Left
hparent = GetParent(m_hwnd)
If (hparent <> 0) Then
ScreenToClient hparent, pt
End If
Left = pt.x
Else
Left = 0
End If
End Property
Public Property Let Top(ByVal toppos As Long)
Dim wndrect As RECT
Dim pt As POINTAPI
Dim hparent As Long
Dim x As Long, y As Long
Dim nwidth As Long
Dim nheight As Long
If (IsWindow(m_hwnd) <> 0) Then
Call GetWindowRect(m_hwnd, wndrect)
x = wndrect.Left
y = toppos
nwidth = wndrect.Right - x
nheight = wndrect.Bottom - wndrect.Top
hparent = GetParent(m_hwnd)
If (hparent <> 0) Then
pt.x = x
ScreenToClient hparent, pt
x = pt.x
End If
MoveWindow m_hwnd, x, y, nwidth, nheight, 1
End If
End Property
Public Property Get Top() As Long
Dim wndrect As RECT
Dim pt As POINTAPI
Dim hparent As Long
If (IsWindow(m_hwnd) <> 0) Then
Call GetWindowRect(m_hwnd, wndrect)
pt.y = wndrect.Top
hparent = GetParent(m_hwnd)
If (hparent <> 0) Then
ScreenToClient hparent, pt
End If
Top = pt.y
Else
Top = 0
End If
End Property
Public Property Let Width(ByVal nwidth As Long)
Dim wndrect As RECT
Dim pt As POINTAPI
Dim hparent As Long
Dim x As Long, y As Long
Dim nheight As Long
If (IsWindow(m_hwnd) <> 0) Then
Call GetWindowRect(m_hwnd, wndrect)
x = wndrect.Left
y = wndrect.Top
nheight = wndrect.Bottom - y
hparent = GetParent(m_hwnd)
If (hparent <> 0) Then
pt.x = x
pt.y = y
ScreenToClient hparent, pt
x = pt.x
y = pt.y
End If
MoveWindow m_hwnd, x, y, nwidth, nheight, 1
End If
End Property
Public Property Get Width() As Long
Dim wndrect As RECT
If (IsWindow(m_hwnd) <> 0) Then
Call GetWindowRect(m_hwnd, wndrect)
Width = wndrect.Right - wndrect.Left
Else
Width = 0
End If
End Property
Public Property Let Height(ByVal nheight As Long)
Dim wndrect As RECT
Dim pt As POINTAPI
Dim hparent As Long
Dim x As Long, y As Long
Dim nwidth As Long
If (IsWindow(m_hwnd) <> 0) Then
Call GetWindowRect(m_hwnd, wndrect)
x = wndrect.Left
y = wndrect.Top
nwidth = wndrect.Right - x
hparent = GetParent(m_hwnd)
If (hparent <> 0) Then
pt.x = x
pt.y = y
ScreenToClient hparent, pt
x = pt.x
y = pt.y
End If
MoveWindow m_hwnd, x, y, nwidth, nheight, 1
End If
End Property
Public Property Get Height() As Long
Dim wndrect As RECT
If (IsWindow(m_hwnd) <> 0) Then
Call GetWindowRect(m_hwnd, wndrect)
Height = wndrect.Bottom - wndrect.Top
Else
Height = 0
End If
End Property
__________________
无影者诡异也
无踪者隐逸也
评论