MS Outlook COM : Export Calendar data into Excel

'Reference Google and MSDN Site

On Error resume Next

err.clear

Sub calendarExport

Dim objWord
Dim objExcelApp
Dim objExcelBook
Dim objExcelSheets
Dim objExcelSheet
Dim objExcelRange
Dim strRange
Dim lngASC
Dim strASCII
Dim i
Dim lngCount
Dim nms
Dim objFolder
Dim objItems
Dim objItem

strSheet = "C:\Calendar.xls"

'Adjust the following number to be 1 less than the row number of the
'first body row
i = 3

'Initialize column letters with 64, so the first letter used will be A
lngASCII = 64
Set objExcelApp = CreateObject("Excel.Application")
objExcelApp.Workbooks.Open(strSheet)
Set objExcelBook = objExcelApp.ActiveWorkbook
Set objExcelSheets = objExcelBook.Worksheets
Set objExcelSheet = objExcelBook.Sheets(1)
objExcelSheet.Activate
objExcelApp.Application.Visible = True

'Set reference to default Calendar folder
Set ot = CreateObject("Outlook.Application")
Set nms = ot.GetNamespace("MAPI")
Set fld = nms.GetDefaultFolder(9)
Set itms = fld.Items
lngCount = itms.Count

'Iterate through items in Calendar folder, and export a few fields
'from each item to a row in the Calendar worksheet
For Each itm in itms
i = i + 1
' If i > 809 then
objExcelSheet.Range("H1") = (i-3)
lngASCII = lngASCII + 1
strASCII = Chr(lngASCII)
strRange = strASCII & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
strV = itm.Start
If err.number = 0 then
If itm.Start <> "" Then objRange.Value = itm.Start
Else
objRange.Value = "Conflict with Item, not able to retrieve data"
End If

lngASCII = lngASCII + 1
strASCII = Chr(lngASCII)
strRange = strASCII & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
strV = itm.End
If err.number = 0 then
If itm.End <> "" Then objRange.Value = itm.End
Else
objRange.Value = "Conflict with Item, not able to retrieve data"
End If

lngASCII = lngASCII + 1
strASCII = Chr(lngASCII)
strRange = strASCII & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
On Error resume Next
strV = itm.CreationTime
If err.number = 0 then
If itm.CreationTime <> "" Then objRange.Value = itm.CreationTime
Else
objRange.Value = "Conflict with Item, not able to retrieve data"
End If

lngASCII = lngASCII + 1
strASCII = Chr(lngASCII)
strRange = strASCII & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
strV = itm.Subject
If err.number = 0 then
If itm.Subject <> "" Then objRange.Value = itm.Subject
Else
objRange.Value = "Conflict with Item, not able to retrieve data"
End If

lngASCII = lngASCII + 1
strASCII = Chr(lngASCII)
strRange = strASCII & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
strV = itm.Location
If err.number = 0 then
If itm.Location <> "" Then objRange.Value = itm.Location
Else
objRange.Value = "Conflict with Item, not able to retrieve data"
End If

lngASCII = lngASCII + 1
strASCII = Chr(lngASCII)
strRange = strASCII & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
strV = itm.Categories
If err.number = 0 then
If itm.Categories <> "" Then objRange.Value = itm.Categories
Else
objRange.Value = "Conflict with Item, not able to retrieve data"
End If

lngASCII = lngASCII + 1
strASCII = Chr(lngASCII)
strRange = strASCII & CStr(i)
Set objRange = objExcelSheet.Range(strRange)
strV = itm.IsRecurring
If err.number = 0 then
If itm.IsRecurring <> "" Then objRange.Value = itm.IsRecurring
Else
objRange.Value = "Conflict with Item, not able to retrieve data"
End If
lngASCII = 64
' End If

Next
objExcelBook.Save
objExcelBook.Close
End Sub

Call calendarExport