VBA Fehlermenldung
09.03.2008 09:15:53
Lemmi
ich habe von Euch vor einiger Zeit das nachfolgende Marko bekommen! Dies hat auch bis jetzt Prima funktioniert!
Siehe---Zeile inaktiv gesetzt 03.2008; Komilierungsfehler---
Sub Update_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 = 26: b = 150: x = 80: 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
'Registerfarbe löschen
shp.TopLeftCell.Offset(0, -1).Interior.ColorIndex = 15
shp.Delete
End If
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 = "Update_Inhaltsverzeichnis"
.Placement = xlFreeFloating
.PrintObject = False
.Characters.Text = "Update_Inhalt"
End With
For sh = 3 To Sheets.Count
Set Btn = wshInhalt.Buttons.Add(x, y, b, h)
With Btn
.Name = "btn_" & Format(sh, "000") 'Zeile inaktiv gesetzt 03.2008; Komilierungsfehler
.OnAction = "activatesheet"
.Placement = xlFreeFloating
.PrintObject = True
.Characters.Text = Sheets(sh).Name
End With
'Registerfarbe auslesen
Btn.TopLeftCell.Offset(0, -1).Interior.Color = Sheets(sh).Tab.Color
'"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, 23, 70, 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 + 55
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
Gruß
Lemmi