CopytoClipboard will nicht

Hallöchen,
ich hätte da noch einmal eine Frage.
Ich möchte aus einer Textbox den Inhalt in die Zwischenablage durch einen Button kopieren. In meinem Fall eine E-Mailadresse.
Lt der Excel VBA Seite muss ich das so machen:

Private Sub CommandButtonCopyMail_Click()
Set copyEmail = New DataObject
copyEmail.SetText TextBoxEmail.Text
copyEmail.PutInClipboard
End Sub

Dazu habe ich noch ein Modul angelegt.


Option Explicit
Public copyEmail As DataObject

Theoretisch funktioniert das. Aber, wenn ich kurz danach etwas anderes kopiere, zb im Browser einen Text oder wo auch immer und danach dann wieder den Button drücke, gibt er mir nur zwei Leerzeichen aus.
Jetzt hab ich gedacht, okay, dann ist sicher der Zwischenspeicher belegt und muss vorher geleert werden. Da habe ich auch schon gesehen, dass es eine Funktion gibt. (Application.CutCopyMode = false)
Wenn ich es jedoch vorranstelle, klappt es nicht. Bzw weiß ich nicht so recht, wo ich ansetzen muss.
Für einen Hinweis wäre ich dankbar :)

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Private Declare Function OpenClipboard Lib "user32.dll" ( _ ByVal hwnd As Long) As Long Private Declare Function CloseClipboard Lib "user32.dll" () As Long Private Declare Function EmptyClipboard Lib "user32.dll" () As Long Private Declare Function SetClipboardData Lib "user32.dll" ( _ ByVal wFormat As Long, _ ByVal hMem As Long) As Long Private Declare Function GlobalAlloc Lib "kernel32.dll" ( _ ByVal wFlags As Long, _ ByVal dwBytes 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 GlobalFree Lib "kernel32.dll" ( _ ByVal hMem As Long) As Long Private Declare Function lstrcpy Lib "kernel32.dll" ( _ ByVal lpStr1 As Any, _ ByVal lpStr2 As Any) As Long Private Const CF_TEXT As Long = 1& Private Const GMEM_MOVEABLE As Long = 2& Public Sub copy_to_clip() Dim strText As String strText = UserForm1.TextBoxEmail.Text 'den Namen deiner Userform aendern oder des sheets, _ wo die Textbox ist Call StringToClipboard(strText) End Sub Private Sub StringToClipboard(strText As String) Dim lngIdentifier As Long, lngPointer As Long lngIdentifier = GlobalAlloc(GMEM_MOVEABLE, Len(strText) + 1) lngPointer = GlobalLock(lngIdentifier) Call lstrcpy(ByVal lngPointer, strText) Call GlobalUnlock(lngIdentifier) Call OpenClipboard(0&) Call EmptyClipboard Call SetClipboardData(CF_TEXT, lngIdentifier) Call CloseClipboard Call GlobalFree(lngIdentifier) End Sub

Option Explicit Private Declare PtrSafe Function OpenClipboard Lib "user32.dll" ( _ ByVal hwnd As Long) 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 Long) As Long Private Declare PtrSafe Function GlobalAlloc Lib "kernel32.dll" ( _ ByVal wFlags As Long, _ ByVal dwBytes As Long) As Long Private Declare PtrSafe Function GlobalLock Lib "kernel32.dll" ( _ ByVal hMem As Long) As Long Private Declare PtrSafe Function GlobalUnlock Lib "kernel32.dll" ( _ ByVal hMem As Long) As Long Private Declare PtrSafe Function GlobalFree Lib "kernel32.dll" ( _ ByVal hMem As Long) As Long Private Declare PtrSafe Function lstrcpy Lib "kernel32.dll" ( _ ByVal lpStr1 As Any, _ ByVal lpStr2 As Any) As Long Private Const CF_TEXT As Long = 1& Private Const GMEM_MOVEABLE As Long = 2&

Option Explicit Private Declare PtrSafe Function OpenClipboard Lib "user32.dll" ( _ ByVal hwnd As LongPtr) As LongPtr Private Declare PtrSafe Function CloseClipboard Lib "user32.dll" () As LongPtr Private Declare PtrSafe Function EmptyClipboard Lib "user32.dll" () As LongPtr Private Declare PtrSafe Function SetClipboardData Lib "user32.dll" ( _ ByVal wFormat As LongPtr, _ ByVal hMem As LongPtr) As LongPtr Private Declare PtrSafe Function GlobalAlloc Lib "kernel32.dll" ( _ ByVal wFlags As LongPtr, _ ByVal dwBytes 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 LongPtr Private Declare PtrSafe Function GlobalFree Lib "kernel32.dll" ( _ ByVal hMem As LongPtr) As LongPtr Private Declare PtrSafe Function lstrcpy Lib "kernel32.dll" ( _ ByVal lpStr1 As Any, _ ByVal lpStr2 As Any) As LongPtr Private Const CF_TEXT As LongPtr = 1& Private Const GMEM_MOVEABLE As LongPtr = 2& Public Sub copy_to_clip() Dim strText As String strText = Userform1.TextBoxEmail.Text 'den Namen deiner Userform aendern oder des sheets, _ _ wo die Textbox ist Call StringToClipboard(strText) End Sub Private Sub StringToClipboard(strText As String) Dim lngIdentifier As LongPtr, lngPointer As LongPtr lngIdentifier = GlobalAlloc(GMEM_MOVEABLE, Len(strText) + 1) lngPointer = GlobalLock(lngIdentifier) Call lstrcpy(ByVal lngPointer, strText) Call GlobalUnlock(lngIdentifier) Call OpenClipboard(0&) Call EmptyClipboard Call SetClipboardData(CF_TEXT, lngIdentifier) Call CloseClipboard Call GlobalFree(lngIdentifier) End Sub

Also soweit ich es überblicken kann funktioniert alles.
Für alle die an einem Ähnlichen Problem hängen, anbei der Code:
Die Prozedur für den Button:

Private Sub CommandButtonCopyMail_Click()
copy_to_clip
End Sub

Hier die copby_to_clip Sub in einem eigenen Modul:

Option Explicit
Private Declare PtrSafe Function OpenClipboard Lib "user32.dll" ( _
ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function CloseClipboard Lib "user32.dll" () As LongPtr
Private Declare PtrSafe Function EmptyClipboard Lib "user32.dll" () As LongPtr
Private Declare PtrSafe Function SetClipboardData Lib "user32.dll" ( _
ByVal wFormat As LongPtr, _
ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalAlloc Lib "kernel32.dll" ( _
ByVal wFlags As LongPtr, _
ByVal dwBytes 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 LongPtr
Private Declare PtrSafe Function GlobalFree Lib "kernel32.dll" ( _
ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function lstrcpy Lib "kernel32.dll" ( _
ByVal lpStr1 As Any, _
ByVal lpStr2 As Any) As LongPtr
Private Const CF_TEXT As LongPtr = 1&
Private Const GMEM_MOVEABLE As LongPtr = 2&
Public Sub copy_to_clip()
Dim strText As String
strText = Userform1.TextBoxEmail.Text
Call StringToClipboard(strText)
End Sub
Private Sub StringToClipboard(strText As String)
Dim lngIdentifier As LongPtr, lngPointer As LongPtr
lngIdentifier = GlobalAlloc(GMEM_MOVEABLE, Len(strText) + 1)
lngPointer = GlobalLock(lngIdentifier)
Call lstrcpy(ByVal lngPointer, strText)
Call GlobalUnlock(lngIdentifier)
Call OpenClipboard(0&)
Call EmptyClipboard
Call SetClipboardData(CF_TEXT, lngIdentifier)
Call CloseClipboard
Call GlobalFree(lngIdentifier)
End Sub

Wichtig an dieser Stelle, der Code ist so umgestellt, das er sowohl in einer 32bit als auch einer 64bit Umgebung arbeiten kann. Mehr Infos findet Ihr auf der Hilfeseite:
https://docs.microsoft.com/de-de/office/vba/language/concepts/getting-started/64-bit-visual-basic-for-applications-overview

Beliebteste Forumthreads (12 Monate)

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

CopytoClipboard will nicht

14 Beiträge zum Forumthread Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread