Hook运用之个性化Excel

当你编制了一个小程序，希不希望当别人使用你的程序时给Excel的程序留下一点印记。下面我们就来个性化Excel的关于对话框。在对话框中添加自己的LOGO和关于你小程序的介绍。
运行后效果如下：

代码：

'**********************************************************************************************************
'**********************************************************************************************************
'//用来产生TIMER控件的效果。
Private Declare Function SetTimer _
    Lib "user32" ( _
        ByVal hwnd As Long, _
        ByVal nIDEvent As Long, _
        ByVal uElapse As Long, _
        ByVal lpTimerfunc As Long) _
As Long
'//将文本描绘到指定的矩形中
Private Declare Function DrawTextEx _
    Lib "user32" Alias "DrawTextExA" ( _
        ByVal hdc As Long, _
        ByVal lpsz As String, _
        ByVal n As Long, _
        lpRect As RECT, _
        ByVal un As Long, _
        lpDrawTextParams As Any) _
As Long
'//设置指定矩形的内容
Declare Function SetRect _
    Lib "user32" ( _
        lpRect As RECT, _
        ByVal X1 As Long, _
        ByVal Y1 As Long, _
        ByVal X2 As Long, _
        ByVal Y2 As Long) _
As Long
'//结束Settimer过程
Public Declare Function KillTimer _
    Lib "user32" ( _
        ByVal hwnd As Long, _
        ByVal nIDEvent As Long) _
As Long
'//从指定的模块或应用程序实例中载入一个图标
Private Declare Function LoadIcon _
    Lib "user32" _
    Alias "LoadIconA" ( _
        ByVal hInstance As Long, _
        ByVal lpIconName As Any) _
As Long
'//清除图标
Private Declare Function DestroyIcon _
    Lib "user32" ( _
        ByVal hIcon As Long) _
As Long
'//释放设备环境
Private Declare Function ReleaseDC _
    Lib "user32" ( _
        ByVal hwnd As Long, _
        ByVal hdc As Long) _
As Long
'//取得窗体设备环境
Private Declare Function GetDC _
    Lib "user32" ( _
        ByVal hwnd As Long) _
As Long
'//取得系统颜色刷
Private Declare Function GetSysColorBrush _
    Lib "user32" ( _
    ByVal nIndex As Long) _
As Long
'//绘制图标
Private Declare Function DrawIconEx _
    Lib "user32" ( _
        ByVal hdc As Long, _
        ByVal xLeft As Long, _
        ByVal yTop As Long, _
        ByVal hIcon As Long, _
        ByVal cxWidth As Long, _
        ByVal cyWidth As Long, _
        ByVal istepIfAniCur As Long, _
        ByVal hbrFlickerFreeDraw As Long, _
        ByVal diFlags As Long) _
As Long
'//设置钩子函数
Public 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
'//结束钩子
Public Declare Function UnhookWindowsHookEx _
    Lib "user32" ( _
        ByVal hHook As Long) _
As Long
'//下一个钩子
Public Declare Function CallNextHookEx _
    Lib "user32" ( _
        ByVal hHook As Long, _
        ByVal nCode As Long, _
        ByVal wParam As Long, _
        lParam As Any) _
As Long
'//取得当前线程的ID
Public Declare Function GetCurrentThreadId _
    Lib "kernel32" () _
As Long
'//取得窗体标题或控件内容
Public Declare Function GetWindowText _
    Lib "user32" _
    Alias "GetWindowTextA" ( _
    ByVal hwnd As Long, _
    ByVal lpString As String, _
    ByVal cch As Long) _
As Long
'---类型---
Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
'---常量---
Public Const DT_CALCRECT = &H400
Public Const DI_NORMAL = &H3
Public Const DT_LEFT = &H0                                       '左对齐
Public Const IDI_EXCLAMATION = 32515&                            '惊叹图标
Public Const COLOR_BTNFACE = 15                                  '按钮表面色
Public Const HCBT_ACTIVATE = 5
Public Const WH_CBT = 5
'---变量---
Public IHook As Long
Public IThreadId As Long
Public WindowText As String
Public IText As String, Mhwnd As Long, MyTid As Long
'---回调---
Public Function HookProc_Excel(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    If nCode < 0 Then
        HookProc_Excel = CallNextHookEx(IHook, nCode, wParam, lParam)
        Exit Function
    End If
    If nCode = HCBT_ACTIVATE Then
        WindowText = String(255, Chr(0))
        GetWindowText wParam, WindowText, 255
        IText = Left(WindowText, InStr(WindowText, vbNullChar) - 1)
        If IText = "关于 Microsoft Excel" Then
            Mhwnd = wParam
            MyTid = SetTimer(0, 0, 10, AddressOf pMsgOutProc)
        Else
            KillTimer 0, MyTid
        End If
    End If
    HookProc_Excel = CallNextHookEx(IHook, nCode, wParam, lParam)
End Function
'********************************************************************************************
'********************************************************************************************
'-------设置钩子-----------
Sub EnableHook()
    If IHook = 0 Then
        IThreadId = GetCurrentThreadId
        IHook = SetWindowsHookEx(WH_CBT, AddressOf HookProc_Excel, Application.hInstance, IThreadId)
    End If
End Sub
'-------取消钩子-----------
Sub FreeHook()
    If IHook <> 0 Then
        Call UnhookWindowsHookEx(IHook)
        IHook = 0
        KillTimer 0, MyTid
    End If
End Sub
'//****************************************************************************************************************************************
'//回调函数
'//****************************************************************************************************************************************
Private Function pMsgOutProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal SysTime As Long) As Long
    Dim MyDC As Long, myIcon As Long, R As RECT, Mstr As String, IconRush As Long
    Mstr = "Hook应用之个性化你的Excel(Code by wangminbai)"
    '取得按钮颜色刷
    IconRush = GetSysColorBrush(COLOR_BTNFACE)
    '取得对话框场景
    MyDC = GetDC(Mhwnd)
    '载入图标
    myIcon = LoadIcon(0, IDI_EXCLAMATION)
    '在指定位置绘制图标，在这里最好用DrawIconEx函数。而不用DrawIcon函数，不然绘制图标时闪烁的厉害
    DrawIconEx MyDC, 80, 110, myIcon, 0, 0, 0, IconRush, DI_NORMAL
    '清除图标
    DestroyIcon myIcon
    '取得字符串的高度和宽度区域
    DrawTextEx MyDC, Mstr, -1&, R, DT_CALCRECT, ByVal 0&
    '设置矩形区域
    SetRect R, R.Left + 120, R.Top + 130, R.Right + 120, R.Bottom + 130
    '描绘文本
    DrawTextEx MyDC, Mstr, -1&, R, DT_LEFT, ByVal 0&
    '释放设备环境
    ReleaseDC Mhwnd, MyDC
End Function

详见附件：
点击下载