AW: Bitte um hilfe, makro in personl ?
10.06.2005 12:53:32
niki
Hallo hajo,
folgenden code hab ich in ein modul der arbeitsmappe eingefügt, die ich versenden möchte...auch unter extras makro steht das makro "inhaltsverzeichnis" unter "diese arbeitsmappe und nicht personal....auch im projekt explorer sehe ich, das es wirklich im modul der neuen arbeitsmappe und nicht der persönlichen ist...
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
Sub ActivateSheet()
Dim shNum As Integer
shNum = CInt(Right(ActiveSheet.Shapes(Application.Caller).OLEFormat.Object.Name, 3))
Sheets(shNum).Select
End Sub
Sub back()
Sheets("_Inhalt_").Select
End Sub
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