Option Explicit

Private Const sModuleName As String = "Module1"
Private Const sDefaultProcName As String = "CreateTOC"
Private Const sSheetName As String = "Table of Contents"
Private Const DNL As String = vbNewLine & vbNewLine
Private sModuleRename As String
Private sProcName As String
Private bModuleName As Boolean

'/// ***************************************************************************************
'/// MAIN ROUTINE
'/// ***************************************************************************************

Sub CreateTOC()
'---------------------------------------------------------------------------------------
' Procedure : CreateTOC
' Author : Zack Barresse
' Updated : 1/27/2012
' Purpose : Explicitly setting object references, cleaned up variables, added some
' additional error handling, added the handling of Macro and Dialog sheets
' as well, and generally cleaned up code.
'Thanks to : Ken Puls
' Simon Lloyd
' Anne Troy
'---------------------------------------------------------------------------------------
Dim VBComp As VBIDE.VBComponent
Dim CodeMod As VBIDE.CodeModule
Dim LineNum As Long
Dim ProcKind As VBIDE.vbext_ProcKind
Dim WB As Workbook
Dim WS As Worksheet
Dim cb As Shape
Dim iWriteToRow As Long
Dim iLoop As Long
Dim iWsTotalCnt As Long
Dim iWsCnt As Long
Dim iChartCnt As Long
Dim iOtherCnt As Long
Dim iLeft As Long
Dim iTop As Long
Dim iHeight As Long
Dim iWidth As Long
Dim iShade As Long
Dim sMsg As String
Dim sAddy As String
Dim shtName As String
Dim bTrigger As Boolean

'/// Used to get procedure name
bTrigger = True

'/// Check if there is an activeworkbook or not (i.e. this code was dropped into a
'/// workbook which wasn't visible, or an add-in)
If ActiveWorkbook Is Nothing Then
MsgBox "You must have a workbook open first!", vbInformation, "No Open Book"
Exit Sub
End If

'/// Set variables
iShade = 37
iWriteToRow = 3
iWsCnt = 0
Set WB = ActiveWorkbook

'/// Turn off some application settings to make code more efficient and run faster
Call TOGGLEEVENTS(False)

'/// Check if the TOC worksheet already exists in the workbook, and if so question user
If WSEXISTS(sSheetName, WB) = True Then
sMsg = "You already have a Table of Contents page. Would you like to overwrite it?"
If MsgBox(sMsg, vbYesNo + vbQuestion, "Replace TOC page?") = vbYes Then GoTo ExitEarly
WB.Worksheets(sSheetName).Delete
End If

'/// Add a blank worksheet to the far left, rename it
Set WS = WB.Worksheets.Add(before:=WB.Sheets(1))
WS.Name = sSheetName

'/// Ensure the code module is the proper name, as needed for the shape OnAction property
Call ChangeModuleName

'/// Change format of TOC sheet
WS.Cells.Interior.ColorIndex = iShade
WS.Rows("4:" & WS.Rows.Count).RowHeight = 16
WS.Range("A1").Font.Bold = False
WS.Range("A1").Font.Italic = True
WS.Range("A1").Font.Name = "Arial"
WS.Range("A1").Font.Size = "8"
WS.Range("A2").Value = "Table of Contents"
WS.Range("A2").Font.Bold = True
WS.Range("A2").Font.Name = "Arial"
WS.Range("A2").Font.Size = "24"
WS.Range("A4").Select

'/// Add a shape which will act as an update for the TOC sheet
With WS.Range("C1")
Set cb = WS.Shapes.AddShape(msoShapeRoundedRectangle, .Left, .Top, .Width, .Height)
End With
sAddy = "R1C3"
cb.Select
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 0
Selection.ShapeRange.TextFrame.VerticalAlignment = xlCenter
Selection.Font.Underline = xlUnderlineStyleSingle
Selection.Font.ColorIndex = 5
Selection.ShapeRange.Fill.Visible = msoFalse
Selection.ShapeRange.Line.Visible = msoFalse

'/// Get the current routine name
'/// Kindly adapted from Chip Pearson, found at:
'/// http://www.cpearson.com/Excel/vbe.aspx
On Error GoTo ErrHandle
Set VBComp = ThisWorkbook.VBProject.VBComponents(sModuleName)
Set CodeMod = VBComp.CodeModule
LineNum = CodeMod.CountOfDeclarationLines + 1
sProcName = CodeMod.ProcOfLine(LineNum, ProcKind)
GoTo NoCodeModErr

ErrHandle:
'/// Code module was not found, use default
sProcName = sDefaultProcName

NoCodeModErr:
If sProcName = vbNullString Then sProcName = sDefaultProcName
Selection.OnAction = IIf(Len(sModuleRename) > 0, sModuleRename, sModuleName) & "." & sProcName

'/// Set heading text for TOC
WS.Range("C1").Value = "Update TOC"
WS.Range("C1").Interior.ColorIndex = iShade
WS.Range("C1").Font.Bold = True
WS.Range("C1").Font.Italic = True
WS.Range("C1").Font.Name = "Arial"
WS.Range("C1").Font.Size = "10"
WS.Range("C1").Font.Underline = xlUnderlineStyleSingle

'/// Get a total of the sheets
'/// NB: We do not use "WB.Worksheets.Count" as that will only count 'worksheets', which
'/// does not include chart sheets
iWsTotalCnt = WB.Sheets.Count

'/// Loop through all sheets, excluding the first (TOC) worksheet
For iLoop = 2 To iWsTotalCnt

'/// Set the write row, increment by 1 every iteration
iWriteToRow = iWriteToRow + 1

'/// Check if the sheet iteration is a chart sheet or not
If IsChart(WB.Sheets(iLoop).Name) Then

'///////////////////////////
'/// Sheet is a chart sheet
'///////////////////////////

'/// Get a total count of chart sheets, set variables
iChartCnt = iChartCnt + 1
shtName = WB.Charts(iChartCnt).Name
WS.Range("C" & iWriteToRow).Value = shtName
WS.Range("C" & iWriteToRow).Font.ColorIndex = iShade

'/// Get dimensions of write cell to apply button to it
iLeft = WS.Range("C" & iWriteToRow).Left
iTop = WS.Range("C" & iWriteToRow).Top
iWidth = WS.Range("C" & iWriteToRow).Width
iHeight = WS.Range("C" & iWriteToRow).RowHeight
sAddy = "R" & iWriteToRow & "C3"

'/// Add the shape to the correct cell, add text to it and assign macro "GotoChart"
Set cb = WS.Shapes.AddShape(msoShapeRoundedRectangle, iLeft, iTop, iWidth, iHeight)
cb.Select
ExecuteExcel4Macro "FORMULA(""=" & sAddy & """)"
Selection.ShapeRange.TextFrame.VerticalAlignment = xlCenter
Selection.ShapeRange.TextFrame.HorizontalAlignment = xlLeft
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 0
Selection.Font.Underline = xlUnderlineStyleSingle
Selection.Font.ColorIndex = 5
Selection.ShapeRange.Fill.Visible = msoFalse
Selection.ShapeRange.Line.Visible = msoFalse
Selection.OnAction = IIf(Len(sModuleRename) > 0, sModuleRename, sModuleName) & ".GotoOther"

'/// Write number to TOC index
WS.Range("B" & iWriteToRow).Value = iLoop

ElseIf IsWorksheet(WB.Sheets(iLoop).Name, WB) = True Then

'/////////////////////////
'/// Sheet is a Worksheet
'/////////////////////////

'/// Grab count
iWsCnt = iWsCnt + 1

'/// Sheet is a regular worksheet
shtName = WB.Sheets(iLoop).Name
WS.Range("C" & iWriteToRow).Hyperlinks.Add Anchor:=WS.Range("C" & iWriteToRow), _
Address:="#'" & shtName & "'!A1", _
SubAddress:="#'" & shtName & "'!A1", _
TextToDisplay:=shtName
WS.Range("C" & iWriteToRow).HorizontalAlignment = xlLeft

'/// Write number to TOC index
WS.Range("B" & iWriteToRow).Value = iLoop

Else

'////////////////////////////////////
'/// Sheet is a dialog or macro sheet
'////////////////////////////////////

'/// Grab count
' iWsCnt = iWsCnt + 1

'/// Get a total count of chart sheets, set variables
iOtherCnt = iOtherCnt + 1
shtName = WB.Sheets(iLoop).Name
WS.Range("C" & iWriteToRow).Value = shtName
WS.Range("C" & iWriteToRow).Font.ColorIndex = iShade

'/// Get dimensions of write cell to apply button to it
iLeft = WS.Range("C" & iWriteToRow).Left
iTop = WS.Range("C" & iWriteToRow).Top
iWidth = WS.Range("C" & iWriteToRow).Width
iHeight = WS.Range("C" & iWriteToRow).RowHeight
sAddy = "R" & iWriteToRow & "C3"

'/// Add the shape to the correct cell, add text to it and assign macro "GotoChart"
Set cb = WS.Shapes.AddShape(msoShapeRoundedRectangle, iLeft, iTop, iWidth, iHeight)
cb.Select
ExecuteExcel4Macro "FORMULA(""=" & sAddy & """)"
Selection.ShapeRange.TextFrame.VerticalAlignment = xlCenter
Selection.ShapeRange.TextFrame.HorizontalAlignment = xlLeft
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 0
Selection.Font.Underline = xlUnderlineStyleSingle
Selection.Font.ColorIndex = 5
Selection.ShapeRange.Fill.Visible = msoFalse
Selection.ShapeRange.Line.Visible = msoFalse
Selection.OnAction = IIf(Len(sModuleRename) > 0, sModuleRename, sModuleName) & ".GotoOther"

'/// Write number to TOC index
WS.Range("B" & iWriteToRow).Value = iLoop

End If

continueLoop:
Next iLoop

'/// Set viewing options
Sheets(sSheetName).Range("C:C").EntireColumn.ColumnWidth = 30
Sheets(sSheetName).Range("A4").Activate

'/// Add string to message prompt if there were any chart sheets added
If iChartCnt > 0 Then
sMsg = DNL & Space(13) & iChartCnt & " Chart sheets have been added"
End If

'/// Add string to message prompt if there were any dialog or macro sheets added
If iOtherCnt > 0 Then
sMsg = sMsg & DNL & Space(13) & iOtherCnt
sMsg = sMsg & " Other sheet" & IIf(iOtherCnt > 1, "s have", " has") & " been added (i.e. Dialog & Macro sheets)"
End If

'/// Append string to message prompt for how many worksheets were added
sMsg = sMsg & DNL & Space(13) & iWsCnt & " Worksheets have been added"

'/// If module name was changed, add that in the message prompt text
If bModuleName = True Then
MsgBox "Complete!" & vbNewLine & "The code module name was changed." & sMsg, vbInformation, "Complete!"
Else
MsgBox "Complete!" & sMsg, vbInformation, "Complete!"
End If

ExitEarly:
'/// Reset application settings back to default
Call TOGGLEEVENTS(True)

End Sub

'/// ***************************************************************************************
'/// SUPPORTIVE FUNCTIONS
'/// ***************************************************************************************

Public Sub TOGGLEEVENTS(blnState As Boolean)
'---------------------------------------------------------------------------------------
' Procedure : TOGGLEEVENTS
' Author : Zack Barresse
' Date : 1/27/2012
' Purpose : Quickly toggle application Properties instead of calling them in each procedure
' Variables : blnState - pass a true/false value indicated the property state desired
'---------------------------------------------------------------------------------------
If Not blnState Then Application.Calculation = xlCalculationManual
Application.DisplayAlerts = blnState
Application.EnableEvents = blnState
Application.ScreenUpdating = blnState
If blnState Then Application.CutCopyMode = False
If blnState Then Application.StatusBar = False
If blnState Then Application.Calculation = xlCalculationAutomatic
End Sub

Public Function WSEXISTS(wksName As String, Optional WKB As Workbook) As Boolean
'---------------------------------------------------------------------------------------
' Procedure : WSEXISTS
' Author : Zack Barresse
' Date : 1/27/2012
' Purpose : To test whether a worksheet exists in a workbook or not
' Variables : wksName - pass a string name for a sheet to test for
' WKB - optionally pass a workbook to test the sheet in, if not specified
' the active workbook will be used
'---------------------------------------------------------------------------------------
If WKB Is Nothing Then
If ActiveWorkbook Is Nothing Then Exit Function
Set WKB = ActiveWorkbook
End If
On Error Resume Next
WSEXISTS = CBool(WKB.Sheets(wksName).Name <> "")
On Error GoTo 0
End Function

Public Function IsWorksheet(shNameTemp As String, Optional WKB As Workbook) As Boolean
'---------------------------------------------------------------------------------------
' Procedure : IsWorksheet
' Author : Zack Barresse
' Date : 1/27/2012
' Purpose : To discern whether or not a sheet in a given workbook is an actual
' worksheet, as opposed to a macro, dialog or chart sheet.
' Variables : shNameTemp - pass a string name for a sheet to test for
' WKB - optionally pass a workbook to test the sheet in, if not specified
' the active workbook will be used
'---------------------------------------------------------------------------------------
Dim wksTemp As Worksheet
If WKB Is Nothing Then
If ActiveWorkbook Is Nothing Then Exit Function
Set WKB = ActiveWorkbook
End If
On Error GoTo ErrFound
'/// Macro and Dialog sheets will throw an error in one of the next two lines
Set wksTemp = WKB.Sheets(shNameTemp)
If wksTemp.Name = wksTemp.CodeName Then
IsWorksheet = TypeName(WKB.Sheets(shNameTemp)) = "Worksheet"
End If
ErrFound:
On Error GoTo 0
End Function

Public Function IsChart(chtName As String) As Boolean
'---------------------------------------------------------------------------------------
' Procedure : IsChart
' Author : Zack Barresse
' Updated : 1/27/2012
' Purpose : Check if the name passed is a Chart sheet or not
'---------------------------------------------------------------------------------------
On Error Resume Next
IsChart = CBool(ActiveWorkbook.Charts(chtName).Name <> "")
On Error GoTo 0
End Function

Private Sub GotoOther()
'---------------------------------------------------------------------------------------
' Procedure : GotoOther
' Author : Zack Barresse
' Date : 1/27/2012
' Purpose : Attached to a shape to allow for hyperlinking to other sheets
'---------------------------------------------------------------------------------------
Dim obj As Shape
Dim objName As String
On Error Resume Next
Set obj = ActiveSheet.Shapes(Application.Caller)
objName = obj.TopLeftCell.Value
ActiveWorkbook.Sheets(objName).Activate
On Error GoTo 0
End Sub

Sub ChangeModuleName()
'---------------------------------------------------------------------------------------
' Procedure : ChangeModuleName
' Author : Simon Lloyd
' Date : 4/20/2011
' Purpose : Check if a code module name already exists, if not, create it
'---------------------------------------------------------------------------------------
Dim vbModule As VBIDE.VBComponent
bModuleName = False
If VBComponentExists(sModuleName, ThisWorkbook.VBProject) = False Then
Call fxModuleNameChange(sModuleName, ThisWorkbook)
bModuleName = True
End If
End Sub

Public Sub fxModuleNameChange(newMacro As String, Optional WB As Workbook)
'---------------------------------------------------------------------------------------
' Procedure : fxModuleNameChange
' Author : Simon Lloyd
' Date : 4/20/2011
' Purpose : Change a module name
' Variables : newMacro - pass a string name for a module name to change to
' : WB - optionally pass a workbook to look in
'---------------------------------------------------------------------------------------
Dim VBC As VBIDE.VBComponent, modCode As String
If WB Is Nothing Then Set WB = ThisWorkbook
For Each VBC In WB.VBProject.VBComponents
If VBC.CodeModule.CountOfLines > 0 Then
modCode = VBC.CodeModule.Lines(1, VBC.CodeModule.CountOfLines)
If InStr(1, modCode, newMacro, vbTextCompare) > 0 Then
VBC.Name = sModuleName
Exit For
End If
End If
Next VBC
End Sub

Sub SentEmailToRecipients()
'Table structure:
'Table name: tblEmails
'Column A - Name, expressed as full name
'Column B - Email Address, expressed as a valid email address
'Column C - Email Sent, expressed as a date

'Declare variables
Dim WS As Worksheet
Dim tblEmails As ListObject
Dim c As Range

'Set variables
Set WS = ThisWorkbook.Sheets("Sheet1")
Set tblEmails = WS.ListObjects("tblEmails")

'/// The following loop goes through the table column C
'/// Excellent information on coding to Tables can be found here:
'/// http://www.jkp-ads.com/Articles/Excel2007TablesVBA.asp?AllComments=True

'Turn off some application properties to speed up code
Call TOGGLEEVENTS(False)

'Loop through table column C, if no email sent, send one now, set reminder
For Each c In WS.Range("tblEmails[Email Sent]")

'Check if an email was sent to this person
If Len(c.Value) = 0 Then

'Create email
'/// We minus one from the current loop row in lieu of the Table header row
Call CreateEmail(tblEmails.DataBodyRange(c.Row - 1, 2), "SUBJECT", "BODY")
Call CreateAppointment(VBA.Date(), VBA.Date(), True, "Emailed " & tblEmails.DataBodyRange(c.Row - 1, 1), _
"Created email for this person.", False)

'Add the date to the Table
c.Value = VBA.Date()

End If

Next c

'Turn application properties back to default state
Call TOGGLEEVENTS(True)

Public Sub TOGGLEEVENTS(blnState As Boolean)
'Originally written by Zack Barresse
'/// Used to easily toggle on/off application properties to speed up coding
With Application
If Not blnState And Not ActiveWorkbook Is Nothing Then .Calculation = xlCalculationManual
.DisplayAlerts = blnState
.EnableEvents = blnState
.ScreenUpdating = blnState
If blnState Then .CutCopyMode = False
If blnState Then .StatusBar = False
If blnState And Not ActiveWorkbook Is Nothing Then .Calculation = xlCalculationAutomatic
End With
End Sub

Public Function GetOL(Optional Plaebo As Variant) As Object
'/// Used to set an Outlook object by late binding
On Error Resume Next
Set GetOL = GetObject(, "Outlook.Application")
If GetOL Is Nothing Then
Set GetOL = CreateObject("Outlook.Application")
End If
On Error GoTo 0
End Function

Public OL As Object
Public NS As Object

Private olMail As Object
Private olFolder As Object
Private olAppt As Object
Private olItem As Object

Sub CreateAppointment(ByVal dtStart As Date, _
ByVal dtEnd As Date, _
ByVal bAllDay As Boolean, _
ByVal sSubject As String, _
ByVal sBody As String, _
Optional ByVal bReminder As Boolean, _
Optional ByVal iReminderInMinutes As Long)

'Set Outlook variables
Set OL = GetOL()
Set NS = GetNS(OL)

'Check if variables were able to be set
If NS Is Nothing Then
'no Outlook found
Exit Sub
End If

'Set folder as default calendar constant
Set olFolder = NS.GetDefaultFolder(9) 'olFolderCalendar - default calendar

'Create a new appointment item
Set olAppt = olFolder.Items.Add("IPM.Appointment")

'Set start date (& time)
olAppt.Start = dtStart

'Set whether all day event or not
olAppt.AllDayEvent = bAllDay

'If start date is same as end date, no time is given, AND an all day event, make the same
If bAllDay = True And Int(dtStart) Int(dtEnd) Then
olAppt.End = dtEnd
End If

'Set subject
olAppt.Subject = sSubject

'Set body of item
olAppt.Body = sBody

'Check if reminder added, if so set it
If bReminder = True Then

'Set minutes of reminder
olAppt.ReminderMinutesBeforeStart = iReminderInMinutes

End If

'Set reminder status
olAppt.ReminderSet = bReminder

'Save the item
olAppt.Save

'Close the item and save (zero constant is for saving)
olAppt.Close 0 'olSave

'/// Please note we are NOT closing Outlook when we're done

End Sub

Sub CreateEmail(ByVal sTo As String, _
ByVal sSubject As String, _
ByVal sBody As String, _
Optional ByVal sCC As String, _
Optional ByVal sBCC As String)

'Set Outlook variables
Set OL = GetOL()
Set NS = GetNS(OL)

'Check if variables were able to be set
If NS Is Nothing Then
'no Outlook found
Exit Sub
End If

'Create email item
Set olMail = OL.CreateItem(0)

'Set email To field
olMail.To = sTo

'If a CC was set, enter it
If Len(sCC) > 0 Then olMail.Cc = sCC

'If a BCC was set, enter it
If Len(sBCC) > 0 Then olMail.Bcc = sBCC

'Set subject
olMail.Subject = sSubject

'Set body
olMail.Body = sBody

'Display email
olMail.Display
'/// NOTE:
'/// It is quite possible to send an email (via command "olMail.Send") although by default this
'/// action is not performed immediately, rather there is a security message one will encounter
'/// due to this being a possible security breach, as VBA code should never be truly be
'/// considered 'secure'. As such, there are multiple workarounds for this.
'///
'/// For more information check out these websites:
'/// http://www.rondebruin.nl/sendmail.htm
'/// http://forums.techguy.org/business-applications/925513-excel-send-emails-automatically-without.html
'/// http://www.excelguru.ca/content.php?174

'/// Please note we are NOT closing Outlook when we're done