wer kann mir helfen, Makro ändern!?!..danke
12.07.2005 12:36:54
niki
Ich nütze das unten eingefügte Makro gern und oft um mappen eine inhaltsverzeichnis einzufügen...bei mappen bis 30 blätter sieht das sehr gut aus, nun hab ich eine mit fast 200 blättern, das ist nun nicht mehr passend.
Kann mir jemand den part des codes ändern, sodass sich die größe und die schrift der erzeugten buttons um 30% reduziert? (egal, einfach kleiner)
Ich habs schon versucht, aber ich kenn mich so gut wie nicht aus...
Oder gibts überhaupt ne bessere lösung für ein "elegantes" inhaltsverzeichnis?
Vielen dank an alle !
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
Application.ScreenUpdating = False
h = 25: b = 85: 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
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
Next sh
wshInhalt.Range("A1").Select
Application.ScreenUpdating = True
End Sub
Private Sub ActivateSheet()
Dim shNum As Integer
shNum = CInt(Right(ActiveSheet.Shapes(Application.Caller).OLEFormat.Object.Name, 3))
Sheets(shNum).Select
End Sub
Private Sub back()
Sheets("_Inhalt_").Select
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