I’ve have not posted for a while. Partly because I’ve been so busy but I’ve also not had anything worthy of a blog post…. Until today.
THE CHALLENGE: Exporting your calendar to Excel and getting a calculated value for the duration of each task or appointment.
I did not design the code and the author did not provide their name in it so I could thank them or give them credit. I’ve tested this and it works great!
If you are not in to coding then scroll down to the very bottom of this post where I’ve embedded a video (not mine) of how to export Outlook calendars to Excel using the built in export feature in Outlook. The only issue I have with it is that is does not calculate the duration of the appointments and why I used the script below. Good luck.
Sample Output:
I’ve made a couple of small modifications to the original script:
1. Changed the destination drive from d:\ to c:\
2. Changed the output date format from dd/mm/yyyy to mm/dd/yyyy
How to make this work?
First, you will need to be on a PC running Windows XP or Windows 7.
Copy the code below and paste it in to any text editor like notepad and save it with a file name like OutlookCalendarExport.vbs.
Now you should be able to double click the file you just saved to run this script. You should get message boxes asking for the start and end dates then it will tell you that it is going off to do its work and will display a message letting you know when it is done. It will save the file on the root of you c: drive.
VBScript: Export Outlook Calendar to Excel
on error resume next
DefaultDrive = "c:\"
set objFS=Wscript.CreateObject("Scripting.FileSystemObject")
If Not objFS.DriveExists(DefaultDrive) Then
msgbox "Your home drive is not mapped. (" & DefaultDrive & ")" & vbcrlf & "Please resolve this before continuing.",48,"Drive Mapping Error"
wscript.quit
end if
starttime = now
' ==== Define Variables
Dim theApp, theNameSpace, theMailItem, calendar, apointmentItems, appointment
' ==== Create a Shell and FileSystem Object
Set WshShell = WScript.CreateObject( "WScript.Shell" )
Set fso = CreateObject("Scripting.FileSystemObject")
' ==== Create Excel Spreadsheet
Set app = CreateObject("Excel.Application")
Set wb = app.Workbooks.Add
app.Visible = False
app.AlertBeforeOverwriting = True
wb.Activate
Row = 1
Column = 1
Set ws = wb.Worksheets(1)
ws.Cells(1,1).Value = "Subject"
ws.Columns(1).ColumnWidth = 50
ws.Cells(1,2).Value = "Date"
ws.Columns(2).ColumnWidth = 9
ws.Cells(1,3).Value = "Start Time"
ws.Columns(3).ColumnWidth = 11
ws.Cells(1,4).Value = "End Time"
ws.Columns(4).ColumnWidth = 11
ws.Cells(1,5).Value = "Duration"
ws.Columns(5).ColumnWidth = 8
ws.Cells(1,6).Value = "Category"
ws.Columns(6).ColumnWidth = 25
Row = Row + 1
OutputFileName = DefaultDrive & "OutlookExport.xls"
' ==== Connect to Outlook
set theApp = CreateObject("Outlook.Application")
set theNameSpace = theApp.GetNameSpace("MAPI")
set calendar = theNameSpace.GetDefaultFolder(9)
set appointmentItems = calendar.Items
' ==== Work out example dates
' ==== Selects Monday to Friday of Previous week as defaults
LastWeek = Weekday(Now)
Select Case LastWeek
Case "1"
Lastweek=Dateadd("D",-6,Date)
Case "2"
Lastweek=Dateadd("D",-7,Date)
Case "3"
Lastweek=Dateadd("D",-8,Date)
Case "4"
Lastweek=Dateadd("D",-9,Date)
Case "5"
Lastweek=Dateadd("D",-10,Date)
Case "6"
Lastweek=Dateadd("D",-11,Date)
Case "7"
Lastweek=Dateadd("D",-12,Date)
End Select
StartofRange = inputbox("Start of Range","Outlook Exporter",LastWeek)
StartofRange=cdate(StartofRange)
EndofRange = inputbox("End of Range","Outlook Exporter",(dateadd("D",+6,LastWeek)))
EndofRange=cdate(EndofRange)
DatetoQuery=StartofRange
If (StartofRange = "") OR (EndofRange = "") Then
wscript.quit
End If
'Popup
Set Shell = wScript.CreateObject("wScript.Shell")
Msg = "Export Started. You will be notified when it is ready."
Timeout = 5
temp = Shell.Popup(Msg, Timeout, "Outlook Exporter")
'if temp = -1 then
' wScript.Quit
'End if
' ==== Create Array to hold valid date range
dim datearray()
numberofdays=DateDiff("D", StartofRange, (dateadd("D",1,EndofRange)))
If Not numberofdays = 0 Then
redim datearray(numberofdays)
Else
redim datearray(1)
End if
' ==== populate the array with the valid dates for the query
datearray(0)=StartofRange
for x=1 to (ubound(datearray)-1)
datearray(x)=dateadd("D",1,(datearray(x-1)))
next
' ==== Find appointments that occur between the StartofRange and EndofRange dates
set appointment = appointmentItems.GetFirst
While TypeName(appointment) <> "Nothing"
if TypeName(appointment) = "AppointmentItem" then
For x = 0 to ubound(datearray)
' ==== Check if appointment is recurring
If appointment.RecurrenceState = 0 then
' =================================================================================
' ====================== Non Recurring appointment ================================
' =================================================================================
If DateValue(appointment.Start) = datearray(x) then
if (appointment.BusyStatus = 2) AND (appointment.sensitivity = 0) Then
Beginning=TimeValue(appointment.start)
Ending=TimeValue(appointment.end)
Duration=DateDiff("N",Beginning,Ending)
if appointment.AllDayEvent then
Beginning="8:30:00"
Ending="5:00:00"
Duration="480"
Else If Duration = "24.00" Then
Duration="480"
End If
End If
ws.Cells(Row,Column).Value = appointment.subject
Column = Column + 1
ws.Cells(Row,Column).Value = DatePart("M",appointment.start) & "/" & DatePart("D",appointment.start) & "/" & DatePart("YYYY",appointment.start)
Column = Column + 1
ws.Cells(Row,Column).Value = Beginning
Column = Column + 1
ws.Cells(Row,Column).Value = Ending
Column = Column + 1
ws.Cells(Row,Column).Value = FixDate(abs(Duration))
Column = Column + 1
ws.Cells(Row,Column).Value = appointment.categories
Row = Row + 1
Column = 1
End If
End If
Else
' =================================================================================
' ====================== Recurring appointment -- get occurrence for date =========
' =================================================================================
Set recurrencePattern = appointment.GetRecurrencePattern
Set recurringApptItem = recurrencePattern.GetOccurrence(datearray(x) & " " & TimeValue(appointment.Start))
errorCode = err.Number
err.Clear
If errorCode = 0 then
set appointment = recurringApptItem
if (appointment.BusyStatus = 2) AND (appointment.sensitivity = 0) Then
Beginning=TimeValue(appointment.start)
Ending=TimeValue(appointment.end)
Duration=DateDiff("N",Beginning,Ending)
if appointment.AllDayEvent then
Beginning="8:30:00"
Ending="5:00:00"
Duration="480"
Else If Duration = "24.00" Then
Duration="480"
End If
End If
ThisOne = """" & appointment.subject & """" & "," & DatePart("M",appointment.start) & "/" & DatePart("D",appointment.start) & "/" & DatePart("YYYY",appointment.start) & "," & Beginning & "," & Ending & "," & Duration & "," & """" & appointment.categories & """" & vbCRLF
If Not ThisOne = LastOne Then
ws.Cells(Row,Column).Value = appointment.subject
Column = Column + 1
ws.Cells(Row,Column).Value = DatePart("M",appointment.start) & "/" & DatePart("D",appointment.start) & "/" & DatePart("YYYY",appointment.start)
Column = Column + 1
ws.Cells(Row,Column).Value = Beginning
Column = Column + 1
ws.Cells(Row,Column).Value = Ending
Column = Column + 1
ws.Cells(Row,Column).Value = FixDate(abs(Duration))
Column = Column + 1
ws.Cells(Row,Column).Value = appointment.categories
Row = Row + 1
Column = 1
LastOne = ThisOne
End If
End If ' status
End If ' error code 0
End If ' appointment.RecurrenceState = 0
Next ' in date array
End If ' TypeName(appointment) = "AppointmentItem"
set appointment = appointmentItems.GetNext
Wend
Beginning = ""
Ending = ""
Duration = ""
' =======================================================================================================
' ============================= Edited Recurring Appointments ===========================================
' =======================================================================================================
Set appointmentItems = calendar.Items
Set appointment = appointmentItems.GetFirst
While TypeName(appointment) <> "Nothing"
If TypeName(appointment) = "AppointmentItem" then
Set RecurrencePattern = appointment.GetRecurrencePattern
Counter = RecurrencePattern.Exceptions.Count
For y = 1 to (Counter)
Set Exception = RecurrencePattern.Exceptions.Item(y)
If (appointment.BusyStatus = 2) AND (appointment.sensitivity = 0) Then
For x = 0 to ubound(Datearray)
If Formatdatetime(DatePart("M",Exception.AppointmentItem.start) & "/" & DatePart("D",Exception.AppointmentItem.start) & "/" & DatePart("YYYY",Exception.AppointmentItem.start)) = formatdatetime(Datearray(x)) Then
Beginning=TimeValue(Exception.AppointmentItem.start)
Ending=TimeValue(Exception.AppointmentItem.end)
Duration=DateDiff("N",Beginning,Ending)
If NOT Beginning = "" Then
ws.Cells(Row,Column).Value = Exception.AppointmentItem.Subject
Column = Column + 1
ws.Cells(Row,Column).Value = DatePart("M",Exception.AppointmentItem.Start) & "/" & DatePart("D",Exception.AppointmentItem.Start) & "/" & DatePart("YYYY",Exception.AppointmentItem.Start)
Column = Column + 1
If Beginning = Ending Then
Beginning="8:30:00 AM"
Ending="5:00:00 PM"
Duration="480"
End If
ws.Cells(Row,Column).Value = Beginning
Column = Column + 1
ws.Cells(Row,Column).Value = Ending
Column = Column + 1
If (Duration = "24.00") OR (Duration = "0") Then
Duration="480"
End If
ws.Cells(Row,Column).Value = FixDate(abs(Duration))
Column = Column + 1
ws.Cells(Row,Column).Value = Exception.AppointmentItem.categories
Row = Row + 1
Column = 1
Beginning = ""
Ending = ""
Duration = ""
End If
End If ' date within range
Next ' ubound(Datearray)
End If ' appointment status
Next 'y - counter
set appointment = appointmentItems.GetNext
End If
wend
' =======================================================================================================
' =======================================================================================================
' =======================================================================================================
Function FixDate(Duration)
Hours = fix(duration / 60)
If (duration - (Hours*60)) < 10 Then
Minutes = "0" & (duration - (Hours*60))
Else
Minutes = (duration - (Hours*60))
End If
If (Hours > 0) AND (Hours < 10) Then
T = "0" & Hours & ":" & Minutes
Else If (Hours > 9 ) Then
T = Hours & ":" & Minutes
Else
T = "00:" & Minutes
End if
End If
FixDate = T
End Function
' =============================================================
' ============ Sort Excel Data and save file ==================
' =============================================================
Const xlAscending = 1
Const xlDescending = 2
Const xlGuess = 0
Const xlTopToBottom = 1
app.Selection.Sort app.Worksheets(1).Range("F2"), _
xlAscending, _
app.Worksheets(1).Range("B2"), _
, _
xlAscending, _
, _
, _
xlGuess, _
1, _
False, _
xlTopToBottom
app.DisplayAlerts = False
err.clear
ws.SaveAs OutputFileName
If err.number = 1004 Then
msgbox err.description & vbcrlf & vbcrlf & "Outlook Exporter cannot continue."
err.clear
wscript.quit
End If
wscript.sleep 2000
' ==== Tidy Up
set appointmentItems = nothing
set calendar = Nothing
theNameSpace.Logoff
set theNameSpace = Nothing
set theApp = Nothing
set fso = Nothing
Set ws = Nothing
wb.close
Set wb = Nothing
' ==== Exit Excel - important if visible = false
app.quit
set app = Nothing
endtime = now
TimeToComplete = formatdatetime(endtime - starttime)
' ==== Inform that the report is finished
Retval = msgbox("Report duration was " & TimeToComplete & vbcrlf & vbcrlf & "View results now?",vbyesno + vbinformation,"Outlook Exporter")
If Retval = vbYes then
wsHshell.Run (OutputFileName)
End If
Set WshShell = Nothing
' ===========================================================================================================
' ================================================== Notes ==================================================
' ===========================================================================================================
' Lists appointments from Outlook Calander
' Includes only those appointments in user specified date range
' Includes regular , recurring and edit-recurring appointments
' Only lists appointments where Busy and not Private
' If alldayevent then duration listed as 8 hours, start 8.30, stop 5pm
' If 24 hour event the duration listed as 8 hours, start 8.30, stop 5pm
' Converts duration to HH:MM format
' Sorts by Date, then start time
' Saves as H:\OutlokExport.xls
Video: Export Outlook Calendar to Excel
