AW: PutInClipboard
26.02.2021 13:14:43
Nepumuk
Hallo Ben,
ein bekanntes Problem. Wenn ein Ordner geöffnet ist, dann passiert das.
Abhilfe schafft:
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("N38:N2000")) Is Nothing Then
If Not IsEmpty(Target.Value) Then
Cancel = True
Call StringToClipboard(Target.Text)
End If
End If
End Sub
In einem Standardmodul1:
Option Explicit
Private Declare PtrSafe Function OpenClipboard Lib "user32.dll" ( _
ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32.dll" () As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare PtrSafe Function SetClipboardData Lib "user32.dll" ( _
ByVal wFormat As Long, _
ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalAlloc Lib "kernel32.dll" ( _
ByVal wFlags As Long, _
ByVal dwBytes As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalFree Lib "kernel32.dll" ( _
ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalLock Lib "kernel32.dll" ( _
ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32.dll" ( _
ByVal hMem As LongPtr) As Long
Private Declare PtrSafe Function lstrcpyA Lib "kernel32.dll" ( _
ByVal lpString1 As Any, _
ByVal lpString2 As Any) As LongPtr
Private Const CF_TEXT As Long = 1&
Private Const GMEM_MOVEABLE As Long = 2
Public Sub StringToClipboard(ByVal pvstrText As String)
Dim lngptrPointer As LongPtr, lngptrHandle As LongPtr
lngptrPointer = GlobalAlloc(GMEM_MOVEABLE, Len(pvstrText) + 1)
lngptrHandle = GlobalLock(lngptrPointer)
Call lstrcpyA(ByVal lngptrHandle, pvstrText)
Call GlobalUnlock(lngptrPointer)
Call OpenClipboard(0)
Call EmptyClipboard
Call SetClipboardData(CF_TEXT, lngptrPointer)
Call CloseClipboard
Call GlobalFree(lngptrPointer)
End Sub
Gruß
Nepumuk