分享vba sdk 编程子类化控件-加注释

qqhuanxiang

'************************************************************************************
'子类化控件目的是已经有目标控件得窗口类，但是他得功能并不复合你要求，你要么重写窗口类，要么子类化控件，要么超类化控件
'子类化只是把截取窗口类得过程地址，用自己得窗口过程替代他，在自己窗口过程中，可以把原来窗口类地址写在你过程得前或后，如果你
'你子类全局窗口类那么你要注意了，你改变了窗口类函数行为，别得程序引用窗口类时，这个窗口过程就是调用你写得过程，因为代码在系统
'只有注册一份，数据是多份，他不是继承关系，超类才是继承关系，被继承是基类。
'此段代码演示用c语言能做到，同样在vba中也能做到，同时运用vba优势，书写方便，调试简单，提高效率。目的不是写这段代码
'而是抛砖引玉，了解一些底层工作原理，掌握api,可以以不变应万变，所有程序都是调用ring3层或内核得api工作，语言只是手段，不管
'他封装得都完美。可以试试截取excel窗口类改变他得行为
'这段代码截取botton控件得标准过程，输出自己得对话框后，还原默认按钮行为，对无窗口得轻量级控件无效
'***********************************************************************************************************************
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
Public gHwnd As Long, gButtonHwnd As Long, gEditHwnd As Long

Public Sub Main() '标准windows程序 sdk框架
   Dim wMsg As Msg
  
   If RegisterWindowClass = False Then Exit Sub '注册窗口类
   
     
      If CreateWindows Then '创建窗口
        
         Do While GetMessage(wMsg, 0&, 0&, 0&) '消息循环
          
            Call TranslateMessage(wMsg)
          
            Call DispatchMessage(wMsg)
         Loop
      End If
    Call UnregisterClass(gClassName$, Application.hInstance) '销毁窗口类
End Sub
Public Function RegisterWindowClass() As Boolean '注册窗口类
    Dim wc As WNDCLASS
   
    wc.style = CS_HREDRAW Or CS_VREDRAW
    wc.lpfnwndproc = GetAddress(AddressOf WndProc) 'AddressOf只能在函数中用
    wc.hInstance = Application.hInstance
    wc.hIcon = LoadIcon(0&, IDI_APPLICATION)
    wc.hCursor = LoadCursor(0&, IDC_ARROW)
    wc.hbrBackground = COLOR_WINDOW + 1
    wc.lpszClassName = gClassName$
    RegisterWindowClass = RegisterClass(wc) <> 0
   
End Function
Public Function CreateWindows() As Boolean '创建窗口，一个主窗口，一个按钮，一个edit
    gHwnd& = CreateWindowEx(0&, gClassName$, gAppName$, WS_OVERLAPPEDWINDOW, CW_USEDEFAULT, CW_USEDEFAULT, 208, 150, 0&, 0&, Application.hInstance, ByVal 0&)
   
    gButtonHwnd& = CreateWindowEx(0&, "Button", "Click Here", WS_CHILD, 58, 90, 85, 25, gHwnd&, 0&, Application.hInstance, 0&)
   
    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&, Application.hInstance, 0&)
 
    Call ShowWindow(gHwnd&, SW_SHOWNORMAL) '显示窗口
    Call ShowWindow(gButtonHwnd&, SW_SHOWNORMAL)
    Call ShowWindow(gEditHwnd&, SW_SHOWNORMAL)

    gButOldProc& = GetWindowLong(gButtonHwnd&, GWL_WNDPROC) '保留旧窗口过程地址
   

    Call SetWindowLong(gButtonHwnd&, GWL_WNDPROC, GetAddress(AddressOf ButtonWndProc)) '设置新窗口过程地址
    CreateWindows = (gHwnd& <> 0) '返回0失败
   
End Function
'窗口过程：为了简单只有一个
Public Function WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim strTemp As String
 
    Select Case uMsg&
       Case WM_DESTROY:
         
          Call PostQuitMessage(0&)
    End Select
   
 
  WndProc = DefWindowProc(hWnd&, uMsg&, wParam&, lParam&) '其他消息由系统处理
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!", Application.Caption, 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 '应为vbA没有函数指针，所以用函数地址
    GetAddress = lngAddr&
End Function

[此贴子已经被作者于2008-3-17 2:42:37编辑过]

tianying

纯API的编程啊，呵呵。。。

wsri

加上点说明啊！

VB286

有点深,晕呀,API学的不太好,只是前几年为解决一个实际问题粗学了几天,问题解决了,API也都忘光啦,楼主说一下上面代码有什么用好吗?谢谢

fdd

留个记号，很有用！

guojianlin1985

太高深了，慢慢消化。

madlax2008

楼主写的非常好，这么好的帖子坟了真的很可惜，几年我再掘出来，另外标识一下：
  gHwnd& = CreateWindowEx(0&, gClassName$, gAppName$, WS_OVERLAPPEDWINDOW, CW_USEDEFAULT, CW_USEDEFAULT, 208, 150, 0&, 0&, Application.hInstance, ByVal 0&)
   
如果把这句的第一个0&改成8&的话那么弹出的窗口将在所有窗口前边，这样的窗口用作一些包含实时监控功能的VBA宏最合适了，即使你的EXCEL最小化了，即使你的桌面上堆了N个页面都能实时显示出来！