PutInClipboard

Forumthread: PutInClipboard

PutInClipboard

26.02.2021 13:02:45

Ben

Hallo zusammen,
ich habe folgenden Code um mit einem Doppelklick auf eine Zelle, den Inhalt in die Zwischenablage zu kopieren. Das hat auch Jahre lang funktioniert und ein paar Tagen ist in der Zwischenablage immer nur das:

Hat das Problem noch jemand?
Oder kann mir irgendwer sagen woran das liegt und wie ich das beheben kann?
Gruß
Ben
Excel 2010
Code:


Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Range("N38:N2000")) Is Nothing Or IsEmpty(Target) Then Exit Sub
Cancel = True
Set MyData = New DataObject
MyData.SetText ActiveCell.Text
MyData.PutInClipboard
End Sub

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: PutInClipboard

26.02.2021 13:14:43

Nepumuk
AW: PutInClipboard

26.02.2021 13:22:44

Ben

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

AW: PutInClipboard

26.02.2021 13:22:44

Ben

Super, funktioniert. Vielen Dank.

Beliebteste Forumthreads (12 Monate)

Forumthread: PutInClipboard

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread