Реализовать UnSubclassing для Excel

'CopyRights:
'Ross Donald (VB.NET) code of SetClipboardViewer - [url]http://www.radsoftware.com.au/articles/clipboardmonitor.aspx[/url]
'Jaafar Tribak - Code of Excel Subclassing - [url]http://www.mrexcel.com/forum/general-excel-discussion-other-questions/420673-challenging-problem-how-make-excel-subclassing-safe-stable.html#post2082195[/url]
 
Option Explicit
 
Private Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private 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
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetDesktopWindow Lib "user32.dll" () As Long
Private Declare Function ShowWindow Lib "user32.dll" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Function PostMessage Lib "user32.dll" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetTimer Lib "user32.dll" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32.dll" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function LockWindowUpdate Lib "user32.dll" (ByVal hwndLock As Long) As Long
Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function SetClipboardViewer Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ChangeClipboardChain Lib "user32" (ByVal hwnd As Long, ByVal hWndNext As Long) As Long
 
Private Const GWL_WNDPROC As Long = -4
Private Const WM_USER As Long = &H400
Private Const WM_NCMOUSEMOVE As Long = &HA0
Private Const WM_SETREDRAW As Long = &HB
'Constants for Clipboard API Calls...
Private Const WM_DRAWCLIPBOARD As Integer = &H308
Private Const WM_CHANGECBCHAIN As Integer = &H30D
'UnSubClass
Private Const WM_NCDESTROY As Long = &H82
Private Const WM_DESTROY As Long = &H2
 
Private Const VBE_CLASS_NAME As String = "wndclass_desked_gsk"
Private Const EXCEL_CLASS_NAME As String = "XLMAIN"
 
Private lOldWinProc As Long
Private lVBEhwnd As Long
'Handle for next clipboard viewer...
Private mNextClipBoardViewerHWnd As Long
'flag for sublassing accomplishing
Public flag As Boolean
 
Sub Safe_Subclass(hwnd As Long)
 
    'don't subclass the window twice !
    If GetProp(GetDesktopWindow, "HWND") <> 0 Then
        MsgBox "The Window is already Subclassed.", vbInformation
        Exit Sub
    End If
 
    'store the target window hwnd as a desktop
    'window for later use property.
     SetProp GetDesktopWindow, "HWND", hwnd
 
    'retrieve the VBE hwnd.
     lVBEhwnd = FindWindow(VBE_CLASS_NAME, vbNullString)
 
    'prevent flickering of the screen
    'before posting messages to reset
    'the VBE window.
    LockWindowUpdate lVBEhwnd
 
    'do the same with the desktop in the background.
    SendMessage GetDesktopWindow, ByVal WM_SETREDRAW, ByVal 0&, 0&
 
    'stop and reset the VBE first to safely
    'proceed with our subclassing of xl.
    PostMessage lVBEhwnd, ByVal WM_USER + &HC44, ByVal &H30, ByVal 0&
    PostMessage lVBEhwnd, ByVal WM_USER + &HC44, ByVal &H33, ByVal 0&
    PostMessage lVBEhwnd, ByVal WM_USER + &HC44, ByVal &H83, ByVal 0&
 
    'run a one time timer and subclass xl
    'from the timer callback function.
    'if subclassing is not installed within
    'the timer callback,xl will crash !
    flag = True
    SetTimer GetProp(GetDesktopWindow, "HWND"), 0&, 1, AddressOf TimerProc
End Sub
 
Sub UnSubClassExcel(hwnd As Long)
    'Tear down
    ChangeClipboardChain GetProp(GetDesktopWindow, "HWND"), GetProp(GetDesktopWindow, "NextClipBoardViewerHWnd")
    'remove the subclass and cleanup.
    SetWindowLong hwnd, GWL_WNDPROC, lOldWinProc
    RemoveProp GetDesktopWindow, "HWND"
    RemoveProp GetDesktopWindow, "NextClipBoardViewerHWnd"
    lOldWinProc = 0
End Sub
 
Private Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    On Error Resume Next
    
    Select Case uMsg
        Case WM_DRAWCLIPBOARD 'The clipboard has changed...
            MsgBox "The clipboard has changed..."
            SendMessage GetProp(GetDesktopWindow, "NextClipBoardViewerHWnd"), uMsg, wParam, lParam
 
        Case WM_CHANGECBCHAIN 'Another clipboard viewer has removed itself...
            If wParam = GetProp(GetDesktopWindow, "NextClipBoardViewerHWnd") Then
                SetProp GetDesktopWindow, "NextClipBoardViewerHWnd", lParam
            Else
                SendMessage GetProp(GetDesktopWindow, "NextClipBoardViewerHWnd"), uMsg, wParam, lParam
            End If
            
        'Try UnSubClass
        Case WM_NCDESTROY
            Call UnSubClassExcel(Application.hwnd)
            'Exit Function
            
        Case WM_DESTROY
            Call UnSubClassExcel(Application.hwnd)
            'Exit Function
   End Select
 
   'allow other msgs default processing.
    If flag Then WindowProc = CallWindowProc(lOldWinProc, hwnd, uMsg, wParam, lParam)
End Function
 
 
Sub TimerProc(ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long)
    'we lost the hwnd stored in the lVBEhwnd var
    'after reseting the VBE so let's retrieve it again.
    lVBEhwnd = FindWindow(VBE_CLASS_NAME, vbNullString)
 
    'we no longer need the timer.
    KillTimer GetProp(GetDesktopWindow, "HWND"), 0&
 
    'allow back drawing on the desktop.
    SendMessage GetDesktopWindow, WM_SETREDRAW, ByVal 1, 0&
 
    'hide the VBE.
    ShowWindow lVBEhwnd, 0&
 
    'unlock the window update.
    LockWindowUpdate 0&
 
    'add VBE window hwnd to the Clipboard Chain and save Next ClipBoardViewer handle in the desktop property
    SetProp GetDesktopWindow, "NextClipBoardViewerHWnd", SetClipboardViewer(GetProp(GetDesktopWindow, "HWND"))
    
    'and at last we can now safely
    'subclass our target window.
    lOldWinProc = SetWindowLong(GetProp(GetDesktopWindow, "HWND"), GWL_WNDPROC, AddressOf WindowProc)
End Sub

'UnSubClass
Private Const WM_SYSCOMMAND As Long = &H112&
Private Const SC_CLOSE As Long = &HF060&
....
Private Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Select Case uMsg
        Case WM_DRAWCLIPBOARD 'The clipboard has changed...
            MsgBox "The clipboard has changed..."
            SendMessage GetProp(GetDesktopWindow, "NextClipBoardViewerHWnd"), uMsg, wParam, lParam
 
        Case WM_CHANGECBCHAIN 'Another clipboard viewer has removed itself...
            If wParam = GetProp(GetDesktopWindow, "NextClipBoardViewerHWnd") Then
                SetProp GetDesktopWindow, "NextClipBoardViewerHWnd", lParam
            Else
                SendMessage GetProp(GetDesktopWindow, "NextClipBoardViewerHWnd"), uMsg, wParam, lParam
            End If
        Case WM_SYSCOMMAND
            If wParam = SC_CLOSE Then
                Call UnSubClassExcel(Application.hwnd)
                WindowProc = 0
                PostMessage hwnd, WM_SYSCOMMAND, SC_CLOSE, lParam
            End If
   End Select
   If flag Then WindowProc = CallWindowProc(lOldWinProc, hwnd, uMsg, wParam, lParam)
End Function