AW: Nur Text in die Zwischenablage (mehrere Zellen)
31.07.2024 19:38:04
volti
Hallo Stefan,
Dein Anliegen ist ja durch Daniels Vorschlag und auch durch meine Version wohl gelöst.
Da ich das Thema aber schon oft gelesen habe, habe ich mich entschlossen, mal eine entsprechende API-Version zu programmieren.
Diese stelle ich allen Interessierten hier zur Verfügung.
Die API-Version dürfte bei größeren Datenmengen deutlich schneller sein, als meine Schleifenversion.
Außerdem hat sie nicht das "Zwei Sonderzeichen"-Problem. Forenkenner wissen was ich damit meine. :-)
Der etwas längere Code ist m.E. unerheblich, da er ja kopiert werden kann und nicht abgeschrieben werden muss.
PS: Ich habe es nur kurz getestet, hoffe aber, dass es allen Situationen standhält.
Code:
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 GlobalSize 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 IsClipboardFormatAvailable Lib "user32" ( _
ByVal wFormat As Long) As Long
Private Declare PtrSafe Function SetClipboardData Lib "user32" ( _
ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GetClipboardData Lib "user32" ( _
ByVal wFormat As Long) 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
Function KopiereRangeAlsText(Rng As Range) As String
' Kopiert eine Excelrange in die Zwischenablage und hält sie dort als Text
Dim hMem As LongPtr, lpGMem As LongPtr, sCliptext As String, i As Long
Const CF_TEXT As Long = 1
Rng.Copy
DoEvents
If IsClipboardFormatAvailable(CF_TEXT) > 0 Then ' Daten vorhanden?
For i = 1 To 2
OpenClipboard 0& ' Zwischenablage öffnen
If i = 1 Then hMem = GetClipboardData(CF_TEXT) ' TEXT aus Zwischenablage
If i = 2 Then hMem = GlobalAlloc(&H42, Len(sCliptext)) ' Speicher reservieren
If hMem > 0 Then
lpGMem = GlobalLock(hMem) ' Speicher blockieren
If i = 1 Then
sCliptext = Space(CLng(GlobalSize(hMem))) ' Platz reservieren
lstrcpy sCliptext, lpGMem ' Daten kopieren
GlobalUnlock hMem ' Speicher freigeben
EmptyClipboard ' Zwischenablage leeren
Else
lpGMem = lstrcpy(lpGMem, sCliptext) ' Daten kopieren
If GlobalUnlock(hMem) = 0 Then _
SetClipboardData CF_TEXT, hMem ' TEXT in Zwischenablage
End If
End If
CloseClipboard ' Zwischenablage schließen
Next i
End If
End Function
' ###############################################
Sub Test()
KopiereRangeAlsText Range("A1:C100")
End Sub
_________________________
viele Grüße aus Freigericht 😊
Karl-Heinz