AW: Zwischenablage auslesen mit VBA
29.07.2017 20:21:12
MatthiasG
Hallo Thorsten,
ich hab jetzt eine "Lösung" gefunden, ein ziemlich schmutziges Gefrickel zwar,... aber es funktioniert :-)
Die Zwischenablage wird i.d.R. von einer anderen Mappe (evtl. auch anderer Instanz) gefüllt. Hier können eben auch verbundene Zellen dabei sein. In der Zielmappe habe ich die Ausrichtung "uber Markierung zentriert", also ohne verbundene Zellen.
"geopfert" habe ich die Anführungszeichen; sollten welche im Quellbereich vorhanden gewesen sein, werden die entfernt... egal, kommt eh nicht vor.
Das Makro soll in der fertigen Version mit Rechtsklick (benutzerdefiniertem Menü) aufgerufen werden. Zum Testen muss man dem Makro eine Tastenkombi oder eine Schaltfläche zuweisen, sonst geht der Inhalt der Zwischenablage verloren (bei Alt+F8).
Außerdem braucht man einen Verweis auf die MS Forms 2.0 Library (z.B. durch Erstellen eines Userform-Elements).
Na gut, hier der Code (in ein allg. Modul):
Option Explicit
Public Const trZ = "¬"
Public Function HoleTextVonZwischenablage() As String
Dim oData As New DataObject, tmp, i
On Error Resume Next ' Brutal um falsche Formate abzuwürgen, gibt dann einen Leerstring
oData.GetFromClipboard
tmp = oData.GetText
HoleTextVonZwischenablage = tmp
End Function
Sub Inhalte_Einfuegen()
Dim tmp As String, i As Long, j As Long
Dim tmp2 As String
Dim zArr As Variant, sArr As Variant, ArrGes As Variant
Dim AnzZeilen As Long
Dim AnzSpalten As Long
'Zwischenablage nach tmp
tmp = HoleTextVonZwischenablage()
If tmp = "" Then
MsgBox "Nichts markiert!", vbExclamation
Exit Sub
End If
'Zeilenumbruch innerhalb von Zellen codieren
tmp2 = tausche10(tmp)
'Zeilen in ZArr()
zArr = Split(tmp2, vbNewLine)
AnzZeilen = UBound(zArr) + 1
AnzSpalten = UBound(Split(zArr(0), vbTab)) + 1
If AnzSpalten = 0 Then AnzSpalten = 1
'MsgBox AnzZeilen & "," & AnzSpalten
ReDim ArrGes(AnzZeilen - 1, AnzSpalten - 1)
'Array befüllen:
For i = 0 To AnzZeilen - 1
sArr = Split(zArr(i), vbTab)
For j = 0 To AnzSpalten - 1
'Debug.Print j & ":";
If UBound(sArr) = -1 Then
ArrGes(i, j) = ""
Else
ArrGes(i, j) = Replace(sArr(j), trZ, Chr(10))
End If
'Debug.Print sArr(j),
Next j
'Debug.Print
Next i
meinArraySchreiben ArrGes, ActiveCell
End Sub
'ersetze vbNewLine (13+10) und Chr(10) innerhalb Anführungszeichen durch (trZ)
Function tausche10(ByVal sx As String) As String
Dim bol_AZ As Boolean
Dim i As Long, l0 As Long, tmp As String, t0 As String
l0 = Len(sx)
bol_AZ = False
tmp = sx
Do
i = i + 1
t0 = Mid(tmp, i, 1)
If t0 = "" Then Exit Do ' Abbruch bei Überlauf oder Leerstring
If Asc(t0) = 34 Then bol_AZ = Not bol_AZ: 'Debug.Print i, bol_AZ
'vbNewline (13+10) tauschen (Sonderfall):
If Mid(tmp, i, 2) = vbNewLine Then
If bol_AZ Then
' i-tes und (i+1)tes Zeichen austauschen durch (trZ)
tmp = Left(tmp, i - 1) & trZ & Mid(tmp, i + 2)
l0 = l0 - 1: i = i + 1
End If
End If
'Chr(10) tauschen (Normalfall):
If Mid(tmp, i, 1) = Chr(10) Then
If bol_AZ Then
' i-tes Zeichen austauschen durch (trZ)
tmp = Left(tmp, i - 1) & trZ & Mid(tmp, i + 1)
End If
End If
Loop While i