Create a Table of Contents in Excel
There has always been a need for a good Table of Contents in Excel. While Word features this natively with its built-in Styles, unfortunately, Excel lacks this functionality due to a host of reasons, which are quite valid. However, we can create a workaround by incorporating some VBA.
The following code is an updated version I created a few years ago. It was simple and served my needs. Over the years it’s needed work, but like a mechanic with his own vehicle, I never really put the time forth to do it, always pushing it to the back burner. Not so anymore! Today I updated the code and made it much more versatile and dynamic! Plus I added comments, which are always helpful when looking back on it.
The code will now take any type of worksheet and create a hyperlink to it. Previously, the problem was if the user had a Dialog, Macro or Chart sheet in a workbook, standard hyperlinks do not work, as you can only use a standard hyperlink to a worksheet (all of the above objects are in the Sheets collection, but not a Worksheet type). In order to bypass this we can create a button on top of each unsupported object it which is linked to a procedure in a we have stored in a module. You can change the variables at the top of the module to whatever you’d like, but it will work as-is if you copy/paste to a new module. The code It will automatically change the name of the module to whatever you specify for the sModuleName variable.
Here is the code. If you have any comments, please feel free to let me know!
'---------------------------------------------------------------------------------------
' Module : Mod_TOC_RPA
' Author : Zack Barresse
' Updated : 1/27/2012
' Purpose : This code module serves as a stand-alone module to create a Table of
' Contents of the active workbook. The other sub routines are supportive
' of this functionality. This will handle the following sheet types:
' Worksheets
' Chart sheets
' Dialog sheets
' Macro sheets
' For those sheets which are not Worksheet types, a shape is utilized. This
' is done because you cannot hyperlink to these sheet types with the normal
' functionality. So instead we add the sheet name to it with an old
' Excel4Macro and add an OnAction property for it to use a sub routine. All
' other 'normal' worksheets will receive a hyperlink to that sheet, with a
' destination of cell A1.
' References: Microsoft Visual Basic for Applications Extensibility 5.3
' You must set this reference for the code to compile without error. To
' add this reference library, click Tools | References, find the correct
' reference, check the box next to it, then click Ok. If you don't see it
' in the list, look for it in its normal location:
' C:\Program Files (x86)\Common Files\microsoft shared\VBA\VBA6\VBE6EXT.OLB
' or
' C:\Program Files\Common Files\microsoft shared\VBA\VBA6\VBE6EXT.OLB
' Change the 'sModuleName' to whatever you want the module to be named.
' With the above reference, you can change it to whatever you want. If you
' name it to another module name that exists in the same project, the
' current module name will be retained.
' Examples : Some other examples of creating Table of Contents can be found here:
' http://dmcritchie.mvps.org/excel/buildtoc.htm
' http://www.vbaexpress.com/kb/getarticle.php?kb_id=120
' http://www.mrexcel.com/articles/table-of-contents-macro.php
' http://alturl.com/nrk83 **
' http://extremecpa.blogspot.com/2005/08/table-of-contents-in-excel-with-vba.html
' ** Like this code, will take any type of sheet (the others will fail),
' but uses VBA to write to the Table of Contents sheet code module
' for the functionality of hyperlinking.
'---------------------------------------------------------------------------------------
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
Public Function VBComponentExists(VBCompName As String, Optional VBProj As VBIDE.VBProject = Nothing) As Boolean
'---------------------------------------------------------------------------------------
' Procedure : VBComponentExists
' Author : Simon Lloyd
' Date : 4/20/2011
' Purpose : Check to see if a code module already exists. If it does, and if the name
' is not equal to the current module name (which will result in shape
' hyperlinks being broken) then set the sModuleRename variable to the
' current module name
' Variables : VBCompName - pass a string name to check if it exists
' : VBProj - otionally pass a specific project (workbook) to look in
'---------------------------------------------------------------------------------------
Dim VBP As VBIDE.VBProject
If VBProj Is Nothing Then
Set VBP = ActiveWorkbook.VBProject
Else
Set VBP = VBProj
End If
On Error Resume Next
sModuleRename = vbNullString
VBComponentExists = CBool(Len(VBP.VBComponents(VBCompName).Name))
If VBComponentExists And VBCompName <> VBP.VBE.ActiveCodePane.CodeModule Then
sModuleRename = VBP.VBE.ActiveCodePane.CodeModule
End If
End Function
Copy, paste, run CreateTOC. Done. 
NB: There is a link in the comments section of the code created from ShortURL.com, to which the full link is:
http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/A_3515-Excel-VBA-to-create-a-Table-of-Contents-TOC-summary-sheet.html
This was code written by Dave Brett (brettdj) which is just as functional as this (unlike most other code out there to create a Table of Contents), but his differs from this functionally in that he used VBA to write code to the worksheet itself as an event, which is quite ingenious.
Many thanks to Simon Lloyd, Ken Puls, Anne Troy, Chip Pearson, for helping with pieces of code, testing, and inspiration.
Create Outlook email and appointments from Excel with VBA
The power of Microsoft Office is quite undeniable. The premier application of the suite is Excel. The love/hate relationship we have all had with it endures. Often times you may find the need to utilize multiple Office applications from within one another. An extremely common request is to create emails and appointments in Outlook, all from within the confines of Excel. Thanks to VBA this is all possible, and can be done quite easily.
In this code sample I have created an Excel workbook. I created a Table (i.e. Insert tab, clicked Table) which housed three columns. Column A housed names, deftly titled “Name”, column B housed email addresses, again so cryptically titled “Email Addresses”, and column C housed a date column titled “Email Sent”. I prefer the Short Date format, but any will suffice. Here is a screenshot of the created Table.
Example Table used
Basically I wanted to keep this table as a reminder of who I emailed on a certain subject and when that email was dispatched. I also had a need to add this to my Outlook calendar for when I emailed this person, for record keeping purposes. Rather than take the time to open Outlook, create a new email item, input all of my data, go to my calendar, create new appointment item, input all of my data, send and save respectively, I decided to take a somewhat faster approach and speed it up with VBA. I like making my life easier, and if I can take 30-60 minutes to code this solution which will probably save me an accumulative 7-8 hours over the next month or so (10 minutes per day x 5 days a week x 52 weeks = 7.22 hrs per month), and I could do so at the click of a button, I’m all for it.
The below code is commented, so I won’t waste time making double comments here. This will basically loop through the entire Table’s column C, check for any value in the cell (besides a blank null, i.e. =”" ), none being found it will create an email to that person with the address listed as well as put it to my default Outlook calendar. There are some settings you can utilize to customize it in multiple fashions. When it’s done with the current iteration it will put the current system date into column C. I do this for two reasons: 1) so I know the date I created the email, and 2) next time I run this I don’t inundate that person with another email.
There are some other web references in the code to both help explain and show other options. If you want to truly utilize the code to best fit your needs, take the time to read through the comments and check out some of the links provided. They are links to some of the most frequently asked questions regarding the use of Outlook via Excel VBA.
I hope you enjoy the code!
In a module titled “modTest” (can be any name):
Option Explicit
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)
End Sub
In a module titled “modMisc”:
Option Explicit
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 Function GetNS(ByRef olApp As Object) As Object
'/// Used to set an Outlook Namespace by late binding
Set GetNS = olApp.GetNamespace("MAPI")
End Function
In a module titled “modEmail”:
Option Explicit
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
End Sub
The only routine which needs to be run is SentEmailToRecipients. In it you will see the two Call lines where the information needs to be set. This was created in Excel 2010, but can be run in 2007 as well. It is set in this example, customize to your hearts content.
Regards,
Zack Barresse
ARCHOS 7 Home Tablet (is a piece of sh*t)
I might be something of a old-school guy, but I would much rather read a real book than something electronic. I finally wore out and decided to get a tablet to be able to read books on the plane and in the hotel while I travel, which I now do quite a bit. I was getting tired of lugging around 700+ page books, so I bought the ARCHOS 7 Home tablet (I won’t tell you where I got it, because I actually like them).
My immediate thoughts & recommendations: the ARCHOS 7 Home Tablet is an absolute piece of SHIT (my site, so I can say it).
The firmware needs upgrading as soon as you get it, but you won’t find that out until you actually hound their “support” department via e-mail (I must note that Tony, my support rep, was fantastic at helping with a PIECE OF SHIT that was built in China and came with instructions that might as well been in Cantonese for all the use they did – DO I really need to know not to plug the my finger into a 220V Outlet?). Tony was incredibly helpful, but even with his help the ARCHOS 7 won’t do a damn thing after that; seriously, if you’re going to have something built in another country (China), and sell it in a country that at least expects a functioning product (other than county of origin) then at least shouldn’t you have the damn decency do make the thing work? How’s the product testing working over there? My 7 year old daughter figured out that this thing was a POS almost as soon as I got it out of the box.
After upgrading the “firmware”, which frankly a good dose of Viagra wouldn’t fix, it still doesn’t work. But you need to upgrade the limpware to get the pre-installed Android “AppLib” to work (don’t forget that you need to uninstall it, somehow find it, and then reinstall it, and even then if you do find anything it won’t work, so it’s, shall I say, useless?). I can understand not being able to find my favorite non-physical game (cribbage), but the complete lack of searchability is frustrating. If the word “searchability” bothers anyone, then try it on the ARCHOS 7 and you’ll see what I mean.
Oh, and the ARCHOS “Android Marketplace”? The offerings through Archos are useless as well, and if you try to get creative and find something you like you’ll find that unless you’re lucky it won’t load at all. I suppose the Czechoklooifadkian newsreader might be interesting to me if I start taking some classes, but really?
As for the Alkido Reader, that was wonderful, as it actually came with two very good books. I love Sun Tzu’s “Art of War” and that is probably the only redeeming factor behind this ARCHAWFUL thing. Except that it can’t find anything else. If I hook the thing up to my PC I can drop my e-books on it (but only on the SD card I had to buy), see them on my PC, but the ARCHOS doesn’t seem to see them. When I told my wife that my tablet said it’s memory was “unmounted” she wanted to know what I’d been up to…Really. All I wanted to do was read a book on a plane, not have my daughter download Super Mario for $0.99 (which I am happy to tell you doesn’t work…) And so the ARCHOS 7 POS is now hers and I will not be taking it on my next trip.
If this thing was defective I might not have a problem with it, but IT’S NOT. It’s just a POS. Pay the extra bucks for something that actually works. I’ve wasted more time on trying to get this thing to work than it’s been worth. The only good thing on it is the Skeet game, becase that’s what’s going to happen to it next, and that will be the most enjoyment I’ve gotten out of it so far. For the frustration involved in this thing I’ve had been better off getting an iPad. Pricey or not, at least they work. All for a business trip so I didn’t have to lug around a few 700 page books, and I still end up lugging the books. So much for that, I’ll pay the $25 bucks to check my bags again…At least I get reimbursed for that expense. Do you think the IRS will care that I shot my “office supplies”?
For what it’s worth, Tony @ ARCHOS (albeit via e-mail and on only on Albanian time) was fantastic, and a great representative for his company. The ARCHOS 7 Home Tablet, on the other hand is about as useful as the UN.
Smitticisms
My wife was talking to her sister in Crested Butte, Colorado tonight and were discussing how to prepare roe from fresh caught Rainbow Trout. I made a choice comment and was rewarded with:
“Smitty knows as much about Rainbow Trout as he does about…” as she pondered, I volunteered “Women…”
And walked off. Score one for the good guys.
Smitty
