ic8h914X

1Option Explicit
2 
3Sub TEST_CreateTOC1_noHidden_noOnwards()
4    Call CreateTOC(False, False)
5End Sub
6 
7Sub TEST_CreateTOC2_withHidden_tocOnwards()
8    Call CreateTOC(True, True)
9End Sub
10 
11Sub TEST_CreateTOC3_noHidden_tocOnwards()
12    Call CreateTOC(False, True)
13End Sub
14 
15Sub TEST_CreateTOC4_withHidden_noOnwards()
16    Call CreateTOC(True, False)
17End Sub
18 
19Sub CreateTOC(Optional ByVal IncludeHiddenSheets As Boolean = False, _
20    Optional ByVal AddHomeLinkOnSheets As Boolean = False)
21     '
22     ' IncludeHiddenSheets
23     '   Boolean
24     '   Specifies whether or not hidden sheets should be included in the Table of Contents
25     '
26     ' AddHomeLinkOnSheets
27     '   Boolean
28     '   Specifies whether or not a link should be placed in each sheet linking back to the
29     '   Table of Contents. This will only be placed on worksheets (i.e. not chart sheets),
30     '   will not work with a protected sheet, and will overwrite anything in the cell
31     '   specified in the destination [address] constant below (under declared variables).
32     '
33     'Use cases:
34     'Call CreateTOC(False, False)
35     '   This will create a Table of Contents which excludes hidden sheets and does not add a link
36     '   back to itself
37     '
38     'Call CreateTOC(True, True)
39     '   This will create a Table of Contents which includes hidden sheets and also includes a link
40     '   back to itself.
41     '*** CAUTION: Specifying a cell in each sheet will 1) only work on worksheets (i.e. not chart sheets),
42     '               overwrite anything in the destination cell (unless worksheet is protected)
43     '
44     'Call CreateTOC(False, True)
45     '   This will create a Table of Contents which excludes hidden sheets and also includes a link
46     '   back to itself.
47     '*** CAUTION: Specifying a cell in each sheet will 1) only work on worksheets (i.e. not chart sheets),
48     '               overwrite anything in the destination cell (unless worksheet is protected)
49     '
50     'Call CreateTOC(True, False)
51     '   This will create a Table of Contents which includes hidden sheets and does not add a link
52     '   back to itself
53     '
54     'Declare all variables
55    Dim TOCBook As Workbook
56    Dim CheckSheet As Worksheet
57    Dim TOC As Worksheet
58    Dim ChartButton As Shape
59    Dim NewRow As Long
60    Dim SheetCount As Long
61    Dim CellLeft
62    Dim CellTop
63    Dim CellHeight
64    Dim CellWidth
65    Dim SheetName As String
66    Dim Prompt As String
67    Dim CellR1C1Address As String
68     
69     'Set a constant to the name of the Table of Contents
70    Const TOCName As String = "TOC"
71    Const HomeCell As String = "A1"
72    Const StartRow As Long = 5
73     
74     'Check if a workbook is open or not.  If no workbook is open, quit.
75    If ActiveWorkbook Is Nothing Then
76        MsgBox "You must have a workbook open first!", vbInformation, "No Open Book"
77        Exit Sub
78    End If
79    Set TOCBook = ActiveWorkbook
80     
81    On Error Resume Next
82    Set TOC = TOCBook.Worksheets("TOC")
83    On Error GoTo 0
84    If Not TOC Is Nothing Then
85        If MsgBox("Table of contents already exists. Overwrite?", vbYesNo + vbDefaultButton2, "Overwrite TOC?") <> vbYes Then Exit Sub
86        Application.DisplayAlerts = False
87        TOC.Delete
88        Set TOC = Nothing
89    End If
90    Set TOC = TOCBook.Worksheets.Add(Before:=TOCBook.Sheets(1))
91    TOC.Name = TOCName
92    TOC.Columns(1).ColumnWidth = 1
93     
94    TOC.Cells(StartRow - 3, "B").Value = "TABLE OF CONTENTS"
95    If IncludeHiddenSheets Then
96        TOC.Cells(StartRow - 2, "B").Value = "Hidden sheets are italicized"
97        TOC.Cells(StartRow - 2, "B").Font.Size = 10
98        NewRow = StartRow
99    Else
100        NewRow = StartRow - 1
101    End If
102     
103    For SheetCount = 1 To TOCBook.Sheets.Count
104        SheetName = TOCBook.Sheets(SheetCount).Name
105        If TOCBook.Sheets(SheetName).Name = TOCName Then GoTo SkipSheet
106        If Not IncludeHiddenSheets And TOCBook.Sheets(SheetName).Visible <> xlSheetVisible Then GoTo SkipSheet
107        If IsChart(SheetName) Then
108             '** Sheet IS a Chart Sheet
109             'Set variables for button dimensions.
110            CellLeft = TOC.Range("B" & NewRow).Left
111            CellTop = TOC.Range("B" & NewRow).Top
112            CellWidth = TOC.Range("B" & NewRow).Width
113            CellHeight = TOC.Range("B" & NewRow).RowHeight
114            CellR1C1Address = "R" & NewRow & "C3"
115             'Add button to cell dimensions.
116            Set ChartButton = TOC.Shapes.AddShape(msoShapeRoundedRectangle, CellLeft, CellTop, CellWidth, CellHeight)
117            ChartButton.Select
118             'Use older technique to add Chart sheet name to button text.
119            ExecuteExcel4Macro "FORMULA(""=" & CellR1C1Address & """)"
120             'Format shape to look like hyperlink and match background color (transparent).
121            Selection.ShapeRange.Fill.ForeColor.SchemeColor = 0
122            Selection.Font.Underline = xlUnderlineStyleSingle
123            Selection.Font.ColorIndex = 0
124            Selection.ShapeRange.Fill.Visible = msoFalse
125            Selection.ShapeRange.Line.Visible = msoFalse
126            Selection.OnAction = "GotoChart"
127            Selection.Name = SheetName
128        Else
129             '** Sheet is NOT a Chart sheet. Add a hyperlink to A1 of each sheet.
130            TOC.Range("B" & NewRow).Hyperlinks.Add Anchor:=TOC.Range("B" & NewRow), Address:="#'" & SheetName & "'!A1", TextToDisplay:=SheetName
131            If AddHomeLinkOnSheets Then
132                If TOCBook.Sheets(SheetName).Type = xlWorksheet Then
133                    If TOCBook.Sheets(SheetName).ProtectContents = False Then
134                        TOCBook.Sheets(SheetName).Range(HomeCell).Value = "TOC"
135                        TOCBook.Sheets(SheetName).Range(HomeCell).Hyperlinks.Add Anchor:=TOCBook.Sheets(SheetName).Range("A1"), Address:="#'" & TOCName & "'!A1", TextToDisplay:=TOCName
136                    End If
137                End If
138            End If
139        End If
140         'Add name and format sheet name on TOC
141        TOC.Range("B" & NewRow).Value = SheetName
142        TOC.Range("B" & NewRow).HorizontalAlignment = xlLeft
143        TOC.Range("B" & NewRow).Font.Italic = CBool(TOCBook.Sheets(SheetName).Visible <> xlSheetVisible)
144        TOC.Range("B" & NewRow).Font.ColorIndex = 5
145         'Increment row
146        NewRow = NewRow + 1
147SkipSheet:
148    Next SheetCount
149     
150    TOC.Activate
151    TOC.Cells(1, 1).Select
152     
153End Sub
154 
155Public Function IsChart(cName As String, Optional ChartBook As Workbook) As Boolean
156     
157     'Will return True or False if sheet is a Chart sheet object or not.
158     'Can be used as a worksheet function.
159    Dim tmpChart As Chart
160    If ChartBook Is Nothing Then
161        If ActiveWorkbook Is Nothing Then Exit Function
162        Set ChartBook = ActiveWorkbook
163    End If
164     
165     'Function will be determined if the object is not errored
166    On Error Resume Next
167    IsChart = IIf(ChartBook.Charts(cName) Is Nothing, False, True)
168    On Error GoTo 0
169     
170End Function
171 
172Sub GotoChart(Optional Placebo As String = "")
173     
174     'This routine is to be assigned to button Object for Chart sheets only
175     'as Chart sheets don't have cell references to hyperlink to.
176     
177    On Error Resume Next
178    ActiveWorkbook.Charts(Application.Caller).Activate
179    On Error GoTo 0
180    If Err.Number <> 0 Then Exit Sub
181     
182     'Optional: zoom Chart sheet to fit screen.
183     'Depending on screen resolution, this may need adjustment(s).
184    ActiveWindow.Zoom = 80
185     
186End Sub