DANKE, hier der code
03.06.2005 11:06:05
ulrich
Der hier ist eingefügt in "diese Arbeitsmappe"
Private Sub Workbook_Open()
Set MenüLeiste = Application.CommandBars.ActiveMenuBar
Set pop1 = MenüLeiste.Controls.Add(Type:=msoControlPopup, temporary:=True)
pop1.Caption = "Fadenkreuz"
pop1.TooltipText = "Fadenkreuz ein/aus"
pop1.BeginGroup = True
Set st = pop1.Controls.Add(Type:=msoControlButton, Id:=1)
st.Caption = "ein"
st.Style = msoButtonCaption
st.OnAction = "FKreuz_an"
Set st = pop1.Controls.Add(Type:=msoControlButton, Id:=1)
st.Caption = "aus"
st.Style = msoButtonCaption
st.OnAction = "FKreuz_aus"
End Sub
und der hier in nem modul:
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
.Line.DashStyle = msoLineDash
.Line.ForeColor.SchemeColor = 12
End With
'Linie in Y-Richtung
Set shp = ActiveSheet.Shapes.AddLine(Ex, By, Ex, Ey)
With shp
.Name = "F_Kreuz_Y"
.Line.Weight = 1
.Line.DashStyle = msoLineDash
.Line.ForeColor.SchemeColor = 12
End With
End Sub
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
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