AW: Buttons ueber makro erzeugen
20.06.2006 15:15:07
u_
Hallo,
musst du ein bisschen anpassen.
In ein Modul:
Sub Inhaltsverzeichnis()
Dim x As Integer, y As Integer, h As Integer, b As Integer, Btn As Object, _
sh As Integer, shp As Shape, wshInhalt As Worksheet
If ActiveWorkbook Is Nothing Then Exit Sub
Application.ScreenUpdating = False
h = 20: b = 100: x = 60: y = 40
'alte Button löschen
If InhaltExists = False Then
Set wshInhalt = Worksheets.Add
With wshInhalt
.Move before:=Sheets(1)
.Name = "_Inhalt_"
End With
End If
Set wshInhalt = Worksheets("_Inhalt_")
On Error Resume Next
For Each shp In Sheets(1).Shapes
If shp.Name Like "btn_*" Then shp.Delete
Next shp
On Error GoTo 0
'neue Buttons einfügen
'button für Aktualisierung
Set Btn = wshInhalt.Buttons.Add(0, 0, b, h)
With Btn
.Name = "btn_refresh"
.OnAction = "Inhaltsverzeichnis"
.Placement = xlFreeFloating
.PrintObject = False
.Characters.Text = "Auffrischen"
End With
For sh = 2 To Worksheets.Count
If Not Worksheets(sh).Visible = xlSheetVeryHidden Then
Set Btn = wshInhalt.Buttons.Add(x, y, b, h)
With Btn
.Name = "btn_" & Format(sh, "000")
.OnAction = "activatesheet"
.Placement = xlFreeFloating
.PrintObject = True
.Characters.Text = Worksheets(sh).Name
End With
'"Zurück"-Button löschen
On Error Resume Next
Worksheets(sh).Shapes("btnBack").Delete
On Error GoTo 0
'"Zurück"-Button auf jedes Blatt
Set Btn = Worksheets(sh).Buttons.Add(0, 0, 20, 15)
With Btn
.OnAction = "Back"
.Characters.Text = "<<"
.Placement = xlFreeFloating
.Name = "btnBack"
End With
y = y + h + 10
End If
Worksheets(sh).Visible = xlSheetHidden
Next sh
x = wshInhalt.Range("e1").Left
y = 40
For sh = 1 To Charts.Count
If Not Charts(sh).Visible = xlSheetVeryHidden Then
Set Btn = wshInhalt.Buttons.Add(x, y, b, h)
With Btn
.Name = "btn_" & Format(sh, "000") + Worksheets.Count
.OnAction = "activatesheet"
.Placement = xlFreeFloating
.PrintObject = True
.Characters.Text = Charts(sh).Name
End With
'"Zurück"-Button löschen
On Error Resume Next
Charts(sh).Shapes("btnBack").Delete
On Error GoTo 0
'"Zurück"-Button auf jedes Blatt
Set Btn = Charts(sh).Buttons.Add(0, 0, 20, 15)
With Btn
.OnAction = "Back"
.Characters.Text = "<<"
.Placement = xlFreeFloating
.Name = "btnBack"
End With
y = y + h + 10
End If
Charts(sh).Visible = xlSheetHidden
Next sh
Set Btn = wshInhalt.Buttons.Add(b + 10, 0, b, h)
With Btn
.Name = "btn_all"
.OnAction = "ShowAll"
.Placement = xlFreeFloating
.PrintObject = True
.Characters.Text = "Alle zeigen"
End With
Application.ScreenUpdating = True
End Sub
Private Sub ActivateSheet()
Dim strNum As String
strNum = ActiveSheet.Shapes(Application.Caller).OLEFormat.Object.Caption
Sheets(strNum).Visible = True
Sheets("_Inhalt_").Visible = False
End Sub
Private Sub back()
Sheets("_Inhalt_").Visible = True
ActiveSheet.Visible = False
End Sub
Private Sub ShowAll()
Dim sh As Object
For Each sh In Sheets
sh.Visible = True
Next
End Sub
Private Function InhaltExists() As Boolean
Dim iCounter As Integer
For iCounter = 1 To Worksheets.Count
If Worksheets(iCounter).Name = "_Inhalt_" Then
Worksheets(iCounter).Move before:=Sheets(1)
InhaltExists = True
Exit Function
End If
Next iCounter
InhaltExists = False
End Function
Gruß
Geist ist geil!
(Dies ist ein allgemeines Statement und nicht an bestimmte Personen gerichtet.)