Option Explicit
Sub TEST_CreateTOC1()
Call CreateTOC(False, False)
End Sub
Sub TEST_CreateTOC2()
Call CreateTOC(True, True)
End Sub
Sub TEST_CreateTOC3()
Call CreateTOC(False, True)
End Sub
Sub TEST_CreateTOC4()
Call CreateTOC(True, False)
End Sub
Sub CreateTOC(Optional ByVal IncludeHiddenSheets As Boolean = False, _
Optional ByVal AddHomeLinkOnSheets As Boolean = False)
Dim TOCBook As Workbook
Dim CheckSheet As Worksheet
Dim TOC As Worksheet
Dim ChartButton As Shape
Dim NewRow As Long
Dim SheetCount As Long
Dim CellLeft
Dim CellTop
Dim CellHeight
Dim CellWidth
Dim SheetName As String
Dim Prompt As String
Dim CellR1C1Address As String
Const TOCName As String = "TOC"
Const HomeCell As String = "A1"
Const StartRow As Long = 5
If ActiveWorkbook Is Nothing Then
MsgBox "You must have a workbook open first!", vbInformation, "No Open Book"
Exit Sub
End If
Set TOCBook = ActiveWorkbook
On Error Resume Next
Set TOC = TOCBook.Worksheets("TOC")
On Error GoTo 0
If Not TOC Is Nothing Then
If MsgBox("Table of contents already exists. Overwrite?", vbYesNo + vbDefaultButton2, "Overwrite TOC?") <> vbYes Then Exit Sub
Application.DisplayAlerts = False
TOC.Delete
Set TOC = Nothing
End If
Set TOC = TOCBook.Worksheets.Add(Before:=TOCBook.Sheets(1))
TOC.Name = TOCName
TOC.Columns(1).ColumnWidth = 1
TOC.Cells(StartRow - 3, "B").Value = "TABLE OF CONTENTS"
If IncludeHiddenSheets Then
TOC.Cells(StartRow - 2, "B").Value = "Hidden sheets are italicized"
TOC.Cells(StartRow - 2, "B").Font.Size = 10
NewRow = StartRow
Else
NewRow = StartRow - 1
End If
For SheetCount = 1 To TOCBook.Sheets.Count
SheetName = TOCBook.Sheets(SheetCount).Name
If TOCBook.Sheets(SheetName).Name = TOCName Then GoTo SkipSheet
If Not IncludeHiddenSheets And TOCBook.Sheets(SheetName).Visible <> xlSheetVisible Then GoTo SkipSheet
If IsChart(SheetName) Then
CellLeft = TOC.Range("B" & NewRow).Left
CellTop = TOC.Range("B" & NewRow).Top
CellWidth = TOC.Range("B" & NewRow).Width
CellHeight = TOC.Range("B" & NewRow).RowHeight
CellR1C1Address = "R" & NewRow & "C3"
Set ChartButton = TOC.Shapes.AddShape(msoShapeRoundedRectangle, CellLeft, CellTop, CellWidth, CellHeight)
ChartButton.Select
ExecuteExcel4Macro "FORMULA(""=" & CellR1C1Address & """)"
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 0
Selection.Font.Underline = xlUnderlineStyleSingle
Selection.Font.ColorIndex = 0
Selection.ShapeRange.Fill.Visible = msoFalse
Selection.ShapeRange.Line.Visible = msoFalse
Selection.OnAction = "GotoChart"
Selection.Name = SheetName
Else
TOC.Range("B" & NewRow).Hyperlinks.Add Anchor:=TOC.Range("B" & NewRow), Address:="#'" & SheetName & "'!A1", TextToDisplay:=SheetName
If AddHomeLinkOnSheets Then
If TOCBook.Sheets(SheetName).Type = xlWorksheet Then
If TOCBook.Sheets(SheetName).ProtectContents = False Then
TOCBook.Sheets(SheetName).Range(HomeCell).Value = "TOC"
TOCBook.Sheets(SheetName).Range(HomeCell).Hyperlinks.Add Anchor:=TOCBook.Sheets(SheetName).Range("A1"), Address:="#'" & TOCName & "'!A1", TextToDisplay:=TOCName
End If
End If
End If
End If
TOC.Range("B" & NewRow).Value = SheetName
TOC.Range("B" & NewRow).HorizontalAlignment = xlLeft
TOC.Range("B" & NewRow).Font.Italic = CBool(TOCBook.Sheets(SheetName).Visible <> xlSheetVisible)
TOC.Range("B" & NewRow).Font.ColorIndex = 5
NewRow = NewRow + 1
SkipSheet:
Next SheetCount
TOC.Activate
TOC.Cells(1, 1).Select
End Sub
Public Function IsChart(cName As String, Optional ChartBook As Workbook) As Boolean
Dim tmpChart As Chart
If ChartBook Is Nothing Then
If ActiveWorkbook Is Nothing Then Exit Function
Set ChartBook = ActiveWorkbook
End If
On Error Resume Next
IsChart = IIf(ChartBook.Charts(cName) Is Nothing, False, True)
On Error GoTo 0
End Function
Sub GotoChart(Optional Placebo As String = "")
On Error Resume Next
ActiveWorkbook.Charts(Application.Caller).Activate
On Error GoTo 0
If Err.Number <> 0 Then Exit Sub
ActiveWindow.Zoom = 80
End Sub
|