Option Explicit
Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, _
ByVal dwBytes As LongPtr) As LongPtr
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 lstrcpy Lib "kernel32" (ByVal lpString1 As Any, _
ByVal lpString2 As Any) As LongPtr
Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, _
ByVal hMem As LongPtr) As LongPtr
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 EmptyClipboard Lib "user32" () As Long
Dim hMem As LongPtr, lpGMem As LongPtr
Function KopiereinClpbrd(Optional ClpTxt As String) As String
hMem = GlobalAlloc(&H42, Len(ClpTxt) + 1)
lpGMem = GlobalLock(hMem)
lpGMem = lstrcpy(lpGMem, ClpTxt)
If GlobalUnlock(hMem) = 0 Then
If OpenClipboard(0&) <> 0 Then
EmptyClipboard
SetClipboardData 1, hMem
CloseClipboard
End If
End If
End Function
Function KopiereinClpbrd2(Optional ClpTxt As String) As String
On Error Resume Next
With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText (ClpTxt)
.PutInClipboard
End With
End Function
Sub Copytest()
KopiereinClpbrd "Teste mich"
End Sub