AW: Fadenkreuz für alle Sheets und neue Datei
19.05.2016 17:32:41
Dieter(Drummer)
Hallo Herbert,
so habe ich es umgesetzt und es klappt. Hoffe Mullit verzeiht mir, dass ich darauf antworte.
In Modul1:
'******** Fadenkreuz *******
'*** Fadenkreuz 1 ***
Sub FKreuz_an()
Dim Bx As Single, By As Single, Ex As Single, Ey As Single
Dim shp As Shape
By = ActiveWindow.VisibleRange.Cells(1).Top
Bx = ActiveWindow.VisibleRange.Cells(1).Left
Ex = Selection.Left + Selection.Width / 2
Ey = Selection.Top + Selection.Height / 2
For Each shp In ActiveSheet.Shapes
If shp.Name = "F_Kreuz_X" Then Exit Sub
Next shp
'Linie in X-Richtung
Set shp = ActiveSheet.Shapes.AddLine(Bx, Ey, Ex, Ey)
With shp
.Name = "F_Kreuz_X"
.Line.Weight = 1 'Linienstärke
.Line.DashStyle = msoLineDash
.Line.ForeColor.SchemeColor = 2 'Linienfarbe
End With
'Linie in Y-Richtung
Set shp = ActiveSheet.Shapes.AddLine(Ex, By, Ex, Ey)
With shp
.Name = "F_Kreuz_Y"
.Line.Weight = 1 'Linienstärke
.Line.DashStyle = msoLineDash
.Line.ForeColor.SchemeColor = 2 'Linienfarbe
End With
End Sub
'*** Fadenkreuz 2 ***
Sub FKreuz_aus()
On Error Resume Next
ActiveSheet.Shapes("f_kreuz_x").Delete
ActiveSheet.Shapes("f_kreuz_y").Delete
On Error GoTo 0
End Sub
'*** Fadenkreuz 3 ***
Sub FKreuz_schieben()
Dim Bx As Single, By As Single, Ex As Single, Ey As Single
Dim shp As Shape
On Error GoTo Ende
By = ActiveWindow.VisibleRange.Cells(1).Top
Bx = ActiveWindow.VisibleRange.Cells(1).Left
Ex = Selection.Left + Selection.Width / 2
Ey = Selection.Top + Selection.Height / 2
With ActiveSheet.Shapes("f_kreuz_x")
.Top = Ey
.Left = Bx
.Width = Abs(Ex - Bx)
.Height = 0
End With
With ActiveSheet.Shapes("f_kreuz_y")
.Top = By
.Left = Ex
.Width = 0
.Height = Abs(Ey - By)
End With
Ende:
End Sub
'***** Ende Fadenkreuz ******
In diese Arbeitsmappe:
' *** Fadenkreuz ******************************************************
' Modul: DieseArbeitsmappe Typ: Klassenmodul der Arbeitsmappe
'Herber: von Mullit am 19.05.2016 16:04:16
' **********************************************************************
Private mobjApplicationClass As clsApplication
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Set mobjApplicationClass = Nothing
End Sub
Private Sub Workbook_Open()
Set mobjApplicationClass = New clsApplication
End Sub
In neues neues Klassenmodul "clsApplication":
Option Explicit
' **********************************************************************
' Modul: clsApplication Typ: Klassenmodul
' **********************************************************************
Private WithEvents mobjApplication As Application
Private Sub Class_Initialize()
Set mobjApplication = Application
End Sub
Private Sub Class_Terminate()
Set mobjApplication = Nothing
End Sub
Private Sub mobjApplication_SheetActivate(ByVal Sh As Object)
Call FKreuz_an
End Sub
Private Sub mobjApplication_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Call FKreuz_schieben
End Sub
Private Sub mobjApplication_WorkbookActivate(ByVal Wb As Workbook)
Call FKreuz_an
End Sub
So habe ich es angelegt nach Rückmeldung von Mullit.
Gruß, Dieter(Drummer)