Option Explicit
#If VBA7 Then
#If Win64 Then
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongLong, ByVal nIndex As Long, ByVal dwNewLong As LongLong) As LongLong
#Else
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
#End If
Private Declare PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As LongPtr, ByVal hwnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Private Declare PtrSafe 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 LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr
Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Private Declare PtrSafe Function GetClipboardSequenceNumber Lib "user32" () As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function AddClipboardFormatListener Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function RemoveClipboardFormatListener Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
Private Declare PtrSafe Function lstrlenW Lib "kernel32.dll" (ByVal lpString As LongPtr) As Long
Private Declare PtrSafe Function lstrcpyW Lib "kernel32.dll" (ByVal lpString1 As LongPtr, ByVal lpString2 As LongPtr) As Long
Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
#Else
Private Declare Function SetWindowLong Lib "user32" 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 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
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function GetClipboardSequenceNumber Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function AddClipboardFormatListener Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function RemoveClipboardFormatListener Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function lstrlenW Lib "kernel32.dll" (ByVal lpString As Long) As Long
Private Declare Function lstrcpyW Lib "kernel32.dll" (ByVal lpString1 As Long, ByVal lpString2 As Long) 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 GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
#End If
Private Const TARGET_SHEET = "Sheet1" '<<== change sheet as required.
Sub Start()
Call CreateClipWindow
End Sub
Sub Finish()
Call CleanUp
End Sub
'_______________________________________ PRIVATE ROUTINES __________________________________________________
Private Sub CreateClipWindow()
#If Win64 Then
Dim lHiddenWnd As LongLong
#Else
Dim lHiddenWnd As Long
#End If
If GetProp(Application.hwnd, "HiddenWnd") = 0 Then
lHiddenWnd = CreateWindowEx(0, "Static", vbNullString, 0, 0, 0, 0, 0, 0, 0, 0, 0)
Call SetProp(Application.hwnd, "HiddenWnd", lHiddenWnd)
Call AddClipboardFormatListener(lHiddenWnd)
Call SubClassClipBoardWatcherWindow(lHiddenWnd)
End If
End Sub
Private Sub CleanUp()
Call RemoveClipboardFormatListener(GetProp(Application.hwnd, "HiddenWnd"))
Call SubClassClipBoardWatcherWindow(GetProp(Application.hwnd, "HiddenWnd"), False)
Call DestroyWindow(GetProp(Application.hwnd, "HiddenWnd"))
Call RemoveProp(Application.hwnd, "HiddenWnd")
End Sub
#If Win64 Then
Private Sub SubClassClipBoardWatcherWindow(ByVal hwnd As LongLong, Optional ByVal bSubclass As Boolean = True)
#Else
Private Sub SubClassClipBoardWatcherWindow(ByVal hwnd As Long, Optional ByVal bSubclass As Boolean = True)
#End If
Const GWL_WNDPROC = (-4)
If bSubclass Then
If GetProp(Application.hwnd, "PrevProcAddr") = 0 Then
Call SetProp(Application.hwnd, "PrevProcAddr", _
SetWindowLong(hwnd, GWL_WNDPROC, AddressOf ClipBoardWindowCallback))
End If
Else
If GetProp(Application.hwnd, "PrevProcAddr") Then
Call SetWindowLong(hwnd, GWL_WNDPROC, GetProp(Application.hwnd, "PrevProcAddr"))
Call RemoveProp(Application.hwnd, "PrevProcAddr")
End If
End If
End Sub
#If Win64 Then
Private Function ClipBoardWindowCallback( _
ByVal hwnd As LongLong, _
ByVal uMsg As Long, _
ByVal wParam As LongLong, _
ByVal lParam As LongLong _
) As LongLong
#Else
Private Function ClipBoardWindowCallback( _
ByVal hwnd As Long, _
ByVal uMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long _
) As Long
#End If
Const WM_CLIPBOARDUPDATE = &H31D
Static lPrevSerial As Long
Dim sCurClipText As String
Call SubClassClipBoardWatcherWindow(hwnd, False)
If uMsg = WM_CLIPBOARDUPDATE Then
If lPrevSerial <> GetClipboardSequenceNumber Then
sCurClipText = GetClipText
If Len(sCurClipText) Then
If SheetExistes(TARGET_SHEET) Then
Call AddClipContentToSheet(Worksheets(TARGET_SHEET), sCurClipText)
End If
End If
lPrevSerial = GetClipboardSequenceNumber
End If
End If
Call SubClassClipBoardWatcherWindow(hwnd, True)
ClipBoardWindowCallback = CallWindowProc(GetProp(Application.hwnd, "PrevProcAddr"), hwnd, uMsg, wParam, lParam)
End Function
Private Sub AddClipContentToSheet(ByVal Sh As Worksheet, ByVal sClipContent As String)
With Sheet1.Cells(Rows.Count, 1).End(xlUp)
.Offset(1) = .Offset(1).Row - 5
.Offset(1, 1) = sClipContent
.Offset(1, 2) = Format(Now, "hh:mm:ss")
End With
End Sub
Private Function GetClipTextAPI() As String
'Doesn't work if data is copied from within excel.
'Func not used here ...kept for the record only.
Const CF_UNICODETEXT = &HD&
#If Win64 Then
Dim lStrPtr As LongLong
#Else
Dim lStrPtr As Long
#End If
On Error GoTo errHandler
Call OpenClipboard(0&)
If IsClipboardFormatAvailable(CF_UNICODETEXT) Then
lStrPtr = GetClipboardData(CF_UNICODETEXT)
If lStrPtr Then
GetClipTextAPI = String$(lstrlenW(lStrPtr), vbNullChar)
lstrcpyW StrPtr(GetClipTextAPI), GlobalLock(lStrPtr)
Call GlobalUnlock(lStrPtr)
End If
End If
errHandler:
Call CloseClipboard
End Function
Private Function GetClipText() As String
On Error Resume Next
With CreateObject("htmlfile")
With .ParentWindow.ClipboardData
GetClipText = .GetData("Text")
End With
End With
End Function
Private Function SheetExistes(ByVal ShName As String) As Boolean
On Error Resume Next
SheetExistes = Not IsError(ThisWorkbook.Worksheets(ShName))
End Function
Private Sub Auto_Close()
Call CleanUp
End Sub