Тестирование полезных кодов и примеров

Private Sub Form_Load()
    Call HookSet(Me.hwnd)
End Sub
 
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    Call HookClear
End Sub
 
Public Sub Callback_ClipboardChange()
    CheckClipboard
End Sub
 
Public Sub CheckClipboard()
    Dim sClip As String
    sClip = GetClipboardW(me.hwnd)
    debug.? sClip
End Sub

Option Explicit
 
Private Declare Function SetWindowSubclass Lib "comctl32" Alias "#410" (ByVal hwnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, Optional ByVal dwRefData As Long) As Long
Private Declare Function GetWindowSubclass Lib "comctl32" Alias "#411" (ByVal hwnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, pdwRefData As Long) As Long
Private Declare Function RemoveWindowSubclass Lib "comctl32" Alias "#412" (ByVal hwnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long
Private Declare Function DefSubclassProc Lib "comctl32" Alias "#413" (ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) 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 Declare Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal Format As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Declare Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function lstrcpyn Lib "kernel32.dll" Alias "lstrcpynW" (ByVal lpString1 As Long, ByVal lpString2 As Long, ByVal iMaxLength As Long) As Long
 
Private m_hWnd As Long
Private h_NextClipBoardViewer As Long
Private m_iSubclassed As Long
 
Private Const WM_DRAWCLIPBOARD As Long = &H308&
Private Const WM_CHANGECBCHAIN As Long = &H30D&
Private Const WM_CLIPBOARDUPDATE As Long = &H31D&
Private Const WM_DESTROYCLIPBOARD As Long = &H307&
Private Const WM_NCDESTROY As Long = &H82
Private Const WM_UAHDESTROYWINDOW As Long = &H90&
Private Const CF_UNICODETEXT    As Long = 13&
 
 
Public Sub HookSet(hWindow As Long)
    If m_iSubclassed = 0 Then
        m_hWnd = hWindow
        m_iSubclassed = SetWindowSubclass(m_hWnd, AddressOf WndProc, 0&)
        h_NextClipBoardViewer = SetClipboardViewer(m_hWnd)
    End If
End Sub
 
Public Sub HookClear()
    If m_iSubclassed Then
        RemoveWindowSubclass m_hWnd, AddressOf WndProc, 0&: m_iSubclassed = 0
        ChangeClipboardChain m_hWnd, h_NextClipBoardViewer
        m_hWnd = 0
    End If
End Sub
 
Private Function WndProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
    
    Dim bProcessed As Boolean
    'Debug.Print "msg: " & uMsg
    
    Select Case uMsg
    
        Case WM_NCDESTROY, WM_UAHDESTROYWINDOW
            HookClear
            
        Case WM_DRAWCLIPBOARD
            SendMessage h_NextClipBoardViewer, uMsg, wParam, lParam
            Form1.Callback_ClipboardChange
            bProcessed = True
        
        Case WM_CLIPBOARDUPDATE
            SendMessage h_NextClipBoardViewer, uMsg, wParam, lParam
            Form1.Callback_ClipboardChange
            bProcessed = True
        
        Case WM_CHANGECBCHAIN
           If wParam = h_NextClipBoardViewer Then
                h_NextClipBoardViewer = lParam
           Else
               SendMessage h_NextClipBoardViewer, uMsg, wParam, lParam
           End If
           bProcessed = True
    End Select
    
    If Not bProcessed Then
        WndProc = DefSubclassProc(hwnd, uMsg, wParam, lParam)
    End If
End Function
 
Public Function GetClipboardW(hWindow As Long) As String
    Dim hMem As Long
    Dim Ptr  As Long
    Dim Size As Long
    Dim txt  As String
    If OpenClipboard(hWindow) Then
        If IsClipboardFormatAvailable(CF_UNICODETEXT) Then
            hMem = GetClipboardData(CF_UNICODETEXT)
            If hMem Then
                Size = GlobalSize(hMem)
                If Size Then
                    txt = Space$(Size \ 2 - 1)
                    Ptr = GlobalLock(hMem)
                    lstrcpyn ByVal StrPtr(txt), ByVal Ptr, Size
                    GlobalUnlock hMem
                    GetClipboardW = txt
                End If
            End If
        End If
        CloseClipboard
    End If
End Function