AW: Inhalt und Formatierung per Mausklick kopieren
01.01.2011 21:43:27
Josef
Hallo Christan,
das erstellen des Code hat 15-20 Min gedauert.
Ich habe den Code och etwas verändert und mit Kommentaren versehen.
"wie lernt man das?" In den Foren mitlesen und vor allem probieren, probieren, probieren, ...
' **********************************************************************
' Modul: DieseArbeitsmappe Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************
Option Explicit
'API-Fuktion um den Tastaturstatus abzufragen
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
'Constante für die [ESC]-Taste
Private Const VK_ESCAPE = &H1B
Dim rng() As Object 'Objektvariable, nimmt die Doppelklick-Zellen auf
Dim lngIndex As Long 'Zählvariable
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
Cancel = True 'Cancel = True ist nötig um nicht in den Bearbeitungsmodus zu wechseln
If GetAsyncKeyState(VK_ESCAPE) <> 0 Then 'Tastatur abfragen und wenn ESC gedrückt, dann
Erase rng 'Objectvariable leeren
lngIndex = 0 'Zähler auf 0 stellen
Else 'ESC NICHT gedrückt
If VarType(rng) > 0 Then 'wenn schon eine Zelle hinzugefügt wurde, dann
Redim Preserve rng(UBound(rng) + 1) 'Ojekt-Array neu dimnionieren
Set rng(UBound(rng)) = Target 'Neue Zelle in Array aufnehmen
Else 'sonst
Set rng(0) = Target 'Zelle dem Array hinzufügen
End If
lngIndex = 0 'Zähler auf 0 stellen
End If
End Sub
Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
Cancel = True 'Cancel = True ist nötig um nicht das Kontextmenü zu öffnen
If VarType(rng) > 0 Then 'wenn Objekt-Array nicht leer, dann
If lngIndex > UBound(rng) Then 'wenn Zähler größer als Obergrenze-Objektarray, dann
Target(1, 1).Clear 'Zelle leeren
Else 'sonst
rng(lngIndex).Copy Target(1, 1) 'Eintrag aus Objekt(Zähler) einfügen
Target(1, 1) = Target(1, 1).Value 'evtl. Formeln in Werte umwandeln
End If
lngIndex = lngIndex + 1 'Zähler hochzählen
'wenn Zähler größer Obergrenze-Objektarray + 1, dann Zähler auf 0 stellen
If lngIndex > UBound(rng) + 1 Then lngIndex = 0
End If
End Sub
Gruß Sepp