这是我最近作为练习时写的一些东东，也算是一些经验和技巧。主要是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 IfEnd 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 = TargetProcEnd 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 LongPrivate Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As LongPrivate 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 LongConst 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 IntegercbCurWin = 0preindex = -1    '没有任何的注册准备创建的窗口cbWinArray = 0End 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 FunctionErrHandler:    OneTimeInit = FalseEnd 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 IfEnd 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 = indEnd 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 = indEnd 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 = indEnd 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    LoopEnd 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 IfEnd 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 IfEnd Function '取消原来的登记，请确保此方法的调用者之前曾成功调用RegisterPreCreateWin并且'还没有调用CreateWindow(Ex)。Public Function UnRegisterPreCreateWin() As Long    UnRegisterPreCreateWin = preindex    preindex = -1End 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 LongPrivate Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As LongPrivate 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 LongPrivate Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As LongPrivate 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 LongPrivate Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As LongPrivate Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As LongPrivate 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 LongPrivate 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 LongPrivate Declare Function SendNotifyMessage Lib "user32" Alias "SendNotifyMessageA" (ByVal hwnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As LongPrivate Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As LongPrivate 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 LongPrivate Const SWP_NOMOVE = &H2Private Const SWP_NOSIZE = &H1Private Const SWP_NOZORDER = &H4Private Const SWP_FRAMECHANGED = &H20        '  The frame changed: send WM_NCCALCSIZE Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As LongPrivate 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 LongPrivate Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As LongPrivate Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As LongPrivate Declare Function ReleaseCapture Lib "user32" () As Long Private Type RECT        Left As Long        Top As Long        Right As Long        Bottom As LongEnd TypePrivate Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As LongPrivate Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As LongPrivate Declare Function IsChild Lib "user32" (ByVal hWndParent As Long, ByVal hwnd As Long) As LongPrivate Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long Private Type POINTAPI        x As Long        y As LongEnd 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 POINTAPIEnd TypePrivate 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 LongPrivate 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 StringEnd 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 = &H82Const WM_USER = &H400 Const COLOR_WINDOW = 5 'Structure of the mapperPrivate 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 subclassedPrivate 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 handlerPrivate 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 = 0OldWndProc = 0bSubClassing = FalseSet winappref = NothingbContinueProcess = TrueFirstHandler = 0DefHandler = 0cbWMMapper = 0End 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 = 0End IfIf (Not (winappref Is Nothing)) Then    winappref.RemoveWindow Me    Set winappref = NothingEnd IfEnd 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 IfEnd Function ' Subclass a windowPublic 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 IfEnd 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 IfEnd 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 IfEnd 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 IfEnd 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 IfEnd 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    LoopEnd 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 IfEnd Function Public Function SetFirstHandler(ByVal NewFHProc As Long) As Long    SetFirstHandler = FirstHandler    FirstHandler = NewFHProcEnd Function Public Function RemoveFirstHandler() As Long    RemoveFirstHandler = FirstHandler    FirstHandler = 0End Function Public Function SetDefHandler(ByVal NewDHProc As Long) As Long    SetDefHandler = DefHandler    DefHandler = NewDHProcEnd Function Public Function RemoveDefHandler() As Long    RemoveDefHandler = DefHandler    DefHandler = 0End 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 FunctionErHandler:    InitWMMapperSize = FalseEnd 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 = indEnd 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 = indEnd 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 IfEnd Property Public Property Get style() As Long    If (IsWindow(m_hwnd) <> 0) Then        style = GetWindowLong(m_hwnd, GWL_STYLE)    Else        style = 0    End IfEnd 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 IfEnd Property Public Property Get exstyle() As Long    If (IsWindow(m_hwnd) <> 0) Then        exstyle = GetWindowLong(m_hwnd, GWL_EXSTYLE)    Else        exstyle = 0    End IfEnd Property Public Property Let WinTitle(ByVal szTitle As String)    If (IsWindow(m_hwnd) <> 0) Then        SetWindowText m_hwnd, szTitle    End IfEnd 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 = szTitleEnd Property Public Property Get hwnd() As Long    hwnd = m_hwndEnd 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 IfEnd 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 IfEnd 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 IfEnd 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 IfEnd 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 IfEnd 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 IfEnd 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 IfEnd 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 IfEnd Property__________________无影者诡异也无踪者隐逸也

评论