Hallo Thomas
Post by Thomas SchulzeBei Word funktioniert es tatellos, leider jedoch nicht bei excel. Der
Rahmen ist aktive, aber im clipboardobjekt sind die daten nicht enthalten.
Das Clipboard kann man ohne Probleme mit ein paar API-Funktionen
auslesen. Indem man dann Split mit dem Trennzeichen vbCrLf benutzt,
kann man die einzelnen Zeilen in ein Array umwandeln. Die einzelnen
Zeilen kann man wiederum mit Split und dem Zeichen vbTab in
weitere Arrays zerlegen.
Man könnte auch vbCrLf mit Replace oder Substitute durch vbTab ersetzen
und enthält mit Split dann ein Array mit allen Elementen.
Beide Verfahren haben aber den Nachteil, dass man alle Elemente in das
(wahrscheinlich) gewünschte zweidimensionale Array umkopieren muss. Das
kann bei größeren Arrays schon etwas dauern.
Wenn es aber auf die Anordnung der Daten nicht so genau ankommt (Spalten
und Zeilen vertauscht), kann man mit ein paar Manipulationen der
Safearraystruktur aus einem eindimensionalen ein zweidimensionales Array
machen, ohne dass man umkopieren muss.
So wird die Funktionalität benutzt (In ein Tabellenblatt mit einem
Button mit Namen cmdCopyFromClip):
Private Sub cmdCopyFromClip_Click()
Dim varClip As Variant
Range("A1:C13").Select
Selection.Copy
varClip = ArrayFromClip
If Not (IsArray(varClip)) Then Exit Sub
' In das Tabellenblatt einfügen
Me.Range( _
Me.Cells(5, 5), _
Me.Cells( _
5 + UBound(varClip, 1), _
5 + UBound(varClip, 2)) _
) = varClip
End Sub
Und folgendes in ein Modul:
Private Declare Sub CopyMemory _
Lib "kernel32" Alias "RtlMoveMemory" ( _
Destination As Any, _
Source As Any, _
ByVal Length As Long)
Private Declare Function CloseClipboard _
Lib "user32" () As Long
Private Declare Function OpenClipboard _
Lib "user32" ( _
ByVal hWnd As Long _
) As Long
Private Declare Function GetClipboardData _
Lib "user32" ( _
ByVal wFormat As Long _
) As Long
Private Declare Function lstrlen _
Lib "kernel32" ( _
ByVal str As Long _
) As Long
Private Declare Function IsClipboardFormatAvailable _
Lib "user32" ( _
ByVal wFormat 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
Public Const CF_TEXT = 1
Public Function ArrayFromClip()
Dim lngPointer As Long
Dim lngMemoryText As Long
Dim strList As String
Dim lngLen As Long
Dim lngDimension1 As Long
Dim lngDimension2 As Long
Dim varDummy As Variant
If IsClipboardFormatAvailable(CF_TEXT) Then
' Wenn Text im Clipboard ist,
' Clipboard öffnen
OpenClipboard 0&
' Handle auf den Datenblock holen
lngPointer = GetClipboardData(CF_TEXT)
' Zeiger holen Block und zur Bearbeitung sperren
lngMemoryText = GlobalLock(lngPointer)
' Textlänge ermitteln
lngLen = lstrlen(lngMemoryText)
' Puffer initialisieren
strList = String(lngLen, 0)
' Text in Puffer Kopieren
CopyMemory ByVal strList, ByVal lngMemoryText, lngLen
' Sperrung aufheben
GlobalUnlock lngMemoryText
' Clipboard schließen
CloseClipboard
If Right(strList, 2) <> vbCrLf Then
MsgBox "Kein Excel-Array"
Exit Function
End If
If InStr(1, strList, vbTab) = 0 Then
MsgBox "Kein Array"
Exit Function
End If
' Abschließendes vbCrLf entfernen
strList = Left(strList, Len(strList) - 2)
' Dimensionen ermitteln
varDummy = Split(strList, vbCrLf)
If IsArray(varDummy) Then
' Zwei Dimesionen
lngDimension2 = UBound(varDummy)
varDummy = Split(varDummy(0), vbTab)
lngDimension1 = UBound(varDummy)
Else
' Eine Dimension
varDummy = Split(strList, vbTab)
lngDimension1 = UBound(varDummy)
End If
strList = Replace(strList, vbCrLf, vbTab)
' XL 97
' strList = Application.Substitute(strList, vbCrLf, vbTab)
' In ein eindimensionales Array
varDummy = Split(strList, vbTab)
' In ein zweidimensionales Array umwandeln
varDummy = MakeTwoDimensionsFromOne( _
varDummy, lngDimension1, lngDimension2)
ArrayFromClip = varDummy
End If
End Function
Public Function MakeTwoDimensionsFromOne( _
myArray As Variant, _
lngDimension1 As Long, _
lngDimension2 As Long _
) As Variant
Dim lngPtrSafearray As Long
Dim lngLboundX As Long
Dim lngLboundY As Long
If Not (IsArray(myArray)) Then Exit Function
' Zeiger auf die Safearraystruktur ermitteln
CopyMemory lngPtrSafearray, ByVal (VarPtr(myArray) + 8), 4
' Ab jetzt wird gelogen!!
' Dimensionen auf zwei
CopyMemory ByVal lngPtrSafearray, 2, 2
' Anzahl Elemente in Dimension 2
CopyMemory ByVal lngPtrSafearray + 16, lngDimension2 + 1, 4
' LBound Dimension 2
CopyMemory ByVal lngPtrSafearray + 20, lngLboundY, 4
' Anzahl Elemente in Dimension 1
CopyMemory ByVal lngPtrSafearray + 24, lngDimension1 + 1, 4
' LBound Dimension 1
CopyMemory ByVal lngPtrSafearray + 28, lngLboundX, 4
MakeTwoDimensionsFromOne = myArray
End Function
Auf meiner Homepage kannst du dir die Beispieldatei zum Probieren mal
herunterladen.
MfG
Michael
--
-------------------------------------------
Michael Schwimmer
Home : http://michael-schwimmer.de