Hallo Ole,
nachfolgender code sollte auch unter Win7 32 Bit laufen...
Bei den neueren Excel kommt VBA7 zum Tragen, das sowohl als 32 Bit wie auch als 64 Bit betrieben werden können. Deshalb passen die Declares auch für 32 Bit (VBA7)
Das alte Excel arbeitet mit VBA6, hier müssen die alten Declares angewendet werden. Insbesondere gibt es hier kein PtrSafe und alle Handle sind Long statt LongPtr.
Option Explicit
#If VBA7 Then
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
#Else
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, _
ByVal dwBytes 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 lstrcpy Lib "kernel32" (ByVal lpString1 As Any, _
ByVal lpString2 As Any) As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, _
ByVal hMem 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 EmptyClipboard Lib "user32" () As Long
Dim hMem As Long, lpGMem As Long
#End If
Function KopiereinClpbrd(Optional ClpTxt As String) As String
'Kopieren über die API (alternativ)
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 '1=CF_TEXT
CloseClipboard
End If
End If
End Function
Sub Copytest()
KopiereinClpbrd "Teste mich"
End Sub
viele Grüße
Karl-Heinz
|