AW: Fadenkreuzmakro
02.05.2008 09:29:54
Hanses
Hast Recht.
hier der Code:
'**************************************************
'* H. Ziplies *
'* 24.07.07 komplette Überarbeitung des Code *
'* erstellt von Hajo.Ziplies@web.de *
'* http://Hajo-Excel.de/
*
'**************************************************
' gesamte Zeile markieren
' alte Farbe wieder zurückstellen bei wechsel und schliessen
' farbveränderungen im markiertem Bereich werden nicht zurück gestellt, außer Rot
' Abschalten durch Doppelklick
'
' Modifiziert von JFreudens
' Durch Auswertung von Activewindow.ActivePane.VisibleRange
' wird der Aufwand deutlich reduziert. Es wird jetzt ein "Fadenkreuz" eingefärbt
' Merker ob Markierung eingeschaltet, geschieht durch Doppelklick
' Dimensionierung erfolgt später in Abhängigkeit der Anzahl der sichtbaren
' Zellen des Fadenkreuzes
Dim BoMenue As Boolean
Private Sub Workbook_Activate()
'Application.CommandBars("Worksheet Menu Bar").Enabled = False
'Application.CommandBars("Formatting").Visible = False
'Application.CommandBars("Standard").Visible = False
If BoMenue = False Then KontextmenueErgaenzen
' Damit keine Markierung beim öffnen
If InI = 32000 Then Exit Sub
If TypeName(ActiveSheet) "Worksheet" Then Exit Sub ' keine Tabelle
If BoZustand = False Then Auslesen ' Farbe Fadenkreuz _
auslesen
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If BoZustand Then Exit Sub ' Markierung aus
' nach Hinweis von Peter Haserodt Vergleich eingefügt ob Tabelle
If TypeName(ActiveSheet) = "Worksheet" Then Zurück ' Farben zurückstellen
End Sub
Private Sub Workbook_Deactivate()
Application.CommandBars("Worksheet Menu Bar").Enabled = True
Application.CommandBars("Formatting").Visible = True
Application.CommandBars("Standard").Visible = True
BoMenue = False
KontextmenueZuruecksetzen
If BoZustand Then Exit Sub ' Markierung aus
' nach Hinweis von Peter Haserodt Vergleich eingefügt ob Tabelle
If TypeName(ActiveSheet) = "Worksheet" Then Zurück ' Farben zurückstellen
End Sub
Private Sub Workbook_Open()
KontextmenueErgaenzen
BoMenue = True
' Variable setzen damit keine Kennzeichnung bei Open
InI = 32000
' Markierung nicht beim öffnen
' If Selection.Cells.Count > 1 Then Exit Sub ' mehr als eine _
Zelle markiert
'' nach Hinweis von Peter Haserodt Vergleich eingefügt ob Tabelle
' If TypeName(ActiveSheet) = "Worksheet" Then Auslesen ' Farben des Fadenkreuzes _
auslesen
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If BoZustand Then Exit Sub ' Markierung aus
Zurück ' Farben zurückstellen
If Target.Count > 1 Then Exit Sub ' mehr als eine Zelle _
markiert
' nach Hinweis von Peter Haserodt Vergleich eingefügt ob Tabelle
If TypeName(ActiveSheet) = "Worksheet" Then
Auslesen ' Farben des Fadenkreuzes auslesen
End If
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.CommandBars("Worksheet Menu Bar").Enabled = True
Application.CommandBars("Formatting").Visible = True
Application.CommandBars("Standard").Visible = True
KontextmenueZuruecksetzen
If BoZustand Then Exit Sub ' Markierung aus
' nach Hinweis von Peter Haserodt Vergleich eingefügt ob Tabelle
If TypeName(ActiveSheet) = "Worksheet" Then Zurück ' Farben zurückstellen
End Sub
Private Sub Workbook_BeforePrint(Cancel As Boolean)
' falls Farbe beim Druck wieder zurückgestellt werden soll
' nach Druck ist die aktuelle Zelle nicht markiert
If BoZustand Then Exit Sub ' Markierug aus
' nach Hinweis von Peter Haserodt Vergleich eingefügt
If TypeName(ActiveSheet) = "Worksheet" Then Zurück ' Farbe zurückstellen
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
' nach Hinweis von Peter Haserodt Vergleich eingefügt
If TypeName(ActiveSheet) = "Worksheet" Then
If Selection.Cells.Count > 1 Then Exit Sub ' mehr als eine Zelle _
markiert
Auslesen ' Farben des Fadenkreuzes auslesen
End If
End Sub
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
If BoZustand Then Exit Sub ' Markierung aus
' nach Hinweis von Peter Haserodt Vergleich eingefügt
If TypeName(ActiveSheet) = "Worksheet" Then Zurück ' Farbe zurückstellen
End Sub