AW: Einsatz eines "Menüsheets"
22.09.2005 10:47:52
u_
Hallo,
sieht schon ganz gut aus. Hier mal als Anregung:
Sub Inhaltsverzeichnis()
Dim x As Integer, y As Integer, h As Integer, b As Integer, Btn As Object, _
sh As Integer, shp As Shape, c As Integer, wshInhalt As Worksheet
'gibt es überhaupt ein Workbook?
If ActiveWorkbook Is Nothing Then Exit Sub
Application.ScreenUpdating = False
h = 20: b = 120: 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
c = 1
'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 Sheets.Count
If Not Sheets(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 = Sheets(sh).Name
End With
'"Zurück"-Button löschen
On Error Resume Next
Sheets(sh).Shapes("btnBack").Delete
On Error GoTo 0
'"Zurück"-Button auf jedes Blatt
Set Btn = Sheets(sh).Buttons.Add(0, 0, 20, 15)
With Btn
.OnAction = "Back"
.Characters.Text = "
.Placement = xlFreeFloating
.Name = "btnBack"
End With
' immer nur 10 Buttons untereinander
If c Mod 10 = 0 Then
x = x + b + 10
y = 40
c = 1
Else
y = y + h + 10
c = c + 1
End If
End If
Sheets(sh).Visible = xlSheetHidden
Next sh
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 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!