Solved: Sub - Pull Outlook calendar items to DB Table - Late Binding

[Movian]

Hey,
this is a fairly cool little sub that i found online. I updated it to fix some issues with name spacing and simplified the code a little.

However one thing I would like to do is convert it from early binding (Outlook 12.0) to late binding so that it can be used for outlook 2003, 2007 and 2010 without having to build seperate DB's. However when i remove the reference to outlook and convert the outlook data types to objects the system throws a problem with GetNameSpace... This triggers the folder selection window in outlook so you can pick which calendar to import. Any suggestions for alternatives that can be used with latebinding ? :help

(Origional Script here - http://www.pcreview.co.uk/forums/vba-script-export-calendar-pst-and-csv-t2634828.html)

'---------------------------------------------------------------------------------------
' Procedure : ExportCalendarToDatabase
' DateTime : 11/09/2006 19:44
' Author : Eric Legault [MVP - Outlook]
' Purpose : Exports Outlook Calendar items to an Access database.
' : Requires Reference to Microsoft ActiveX Data Objects 2.X Library
' : Assumes existence of these fields in a table named 'tblCalendar':
' : Subject (Text) - (Nvarchar(255))
' : Contents (Memo) - (NvarChar(Max))
' : Start (Date/Time) - (DateTime)
' : End (Date/Time) - (DateTime)
'
' Example Call:
' ExportCalendarToDatabase
'
'Modfication
'Author: Richard Burgess
'Date : 02/29/2012
'Purpose: Bugfix and conversion to latebinding.
'---------------------------------------------------------------------------------------

Sub ExportCalendarToDatabase()
On Error GoTo ExportCalendarToDatabase_Error

Dim objFolder As Outlook.MAPIFolder, objItems As Outlook.Items
Dim objAppt As Outlook.AppointmentItem, objMessageObj As Object
Dim rstThis As New ADODB.Recordset, counter As Integer

rstThis.Open "tblCalendar", CurrentProject.Connection, adOpenDynamic, adLockOptimistic, adCmdTable

MsgBox "Please select the Calendar that you want to export to Access with the next dialog...", vbOKOnly + vbInformation, "Export Calendar"

Set objFolder = GetNamespace("MAPI").PickFolder
If objFolder.DefaultItemType <> olAppointmentItem Then
MsgBox "Invalid folder. Export aborted.", vbOKOnly + vbExclamation, "Invalid Folder Type"
GoTo Exitt:
End If

Set objItems = objFolder.Items
counter = 0

For Each objMessageObj In objItems
counter = counter + 1
'Forms("frmMain").Text1 = counter & " of " & objItems.Count
If objMessageObj.Class = olAppointment Then
Set objAppt = objMessageObj

'SAVE TO ACCESS DATABASE
rstThis.AddNew
rstThis("Subject").Value = objAppt.Subject
'If the Body field is a memo data type, ensure that zero length strings are allowed
If objAppt.Body <> "" Then
rstThis("Contents").Value = objAppt.Body
End If
rstThis("Start").Value = objAppt.Start
rstThis("End").Value = objAppt.End
rstThis.Update

End If
DoEvents
Next
MsgBox "Operation Complete", vbInformation
Exitt:
On Error Resume Next
Set rstThis = Nothing
Set objFolder = Nothing
Set objItems = Nothing
Set objAppt = Nothing
Set objMessageObj = Nothing

On Error GoTo 0
Exit Sub

ExportCalendarToDatabase_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure"
ExportCalendarToDatabase
Resume Next
End Sub

[Movian]

Never Mind, got it figured out.

Please find the finished Sub here for reference.

Option Compare Database
Option Explicit

Public Const olAppointment = 26
Public Const olAppointmentItem = 1

'---------------------------------------------------------------------------------------
' Procedure : ExportCalendarToDatabase
' DateTime : 11/09/2006 19:44
' Author : Eric Legault [MVP - Outlook]
' Purpose : Exports Outlook Calendar items to an Access database.
' : Requires Reference to Microsoft ActiveX Data Objects 2.X Library
' : Assumes existence of these fields in a table named 'tblCalendar':
' : Subject (Text) - (Nvarchar(255))
' : Contents (Memo) - (NvarChar(Max))
' : Start (Date/Time) - (DateTime)
' : End (Date/Time) - (DateTime)
'
' Example Call:
' ExportCalendarToDatabase
'
'Modfication
'Author: Richard Burgess
'Date : 02/29/2012
'Purpose: Bugfix and update to office 2007/2010
'---------------------------------------------------------------------------------------

Sub ExportCalendarToDatabase()
On Error GoTo ExportCalendarToDatabase_Error

Dim objFolder As Object, objItems As Object, closeApp As Boolean
Dim objAppt As Object, objMessageObj As Object
Dim rstThis As New ADODB.Recordset, counter As Integer

Dim olApp As Object

On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
closeApp = False

If Err.Number = 429 Then
Set olApp = CreateObject("Outlook.application")
closeApp = True
End If

On Error GoTo 0

rstThis.Open "tblCalendar", CurrentProject.Connection, adOpenDynamic, adLockOptimistic, adCmdTable

MsgBox "Please select the Calendar that you want to export to Access with the next dialog...", vbOKOnly + vbInformation, "Export Calendar"

Set objFolder = olApp.GetNamespace("MAPI").PickFolder

If objFolder.DefaultItemType <> olAppointmentItem Then
MsgBox "Invalid folder. Export aborted.", vbOKOnly + vbExclamation, "Invalid Folder Type"
GoTo Exitt:
End If

Set objItems = objFolder.Items
counter = 0

For Each objMessageObj In objItems
counter = counter + 1
Forms("frmMain").Text1 = counter & " of " & objItems.Count
If objMessageObj.Class = olAppointment Then
Set objAppt = objMessageObj

'SAVE TO ACCESS DATABASE
rstThis.AddNew
rstThis("Subject").Value = objAppt.Subject
'If the Body field is a memo data type, ensure that zero length strings are allowed
If objAppt.Body <> "" Then
rstThis("Contents").Value = objAppt.Body
End If
rstThis("Start").Value = objAppt.Start
rstThis("End").Value = objAppt.end
rstThis.Update
End If
DoEvents
Next
MsgBox "Operation Complete", vbInformation
Exitt:
On Error Resume Next
Set rstThis = Nothing
Set objFolder = Nothing
Set objItems = Nothing
Set objAppt = Nothing
Set objMessageObj = Nothing
Set olApp = Nothing
If closeApp Then
olApp.Quit
End If
On Error GoTo 0
Exit Sub

ExportCalendarToDatabase_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure"
ExportCalendarToDatabase
Resume Next
End Sub

[Bob Phillips]

That is still early binding the ADO.

[Movian]

Yes, but its not early binding on Outlook which was the important part. This way it can be used on outlook 2000, 2003, 2007 or 2010. The Ado is not a problem with the early binding.

[Bob Phillips]

Could be just as problemmatical. If you refer to ADO 6.0 they won't have that, they would have 2.7, 2.8, and they could give an issue.

I use late binding de facto, it isn't worth the risk when distributing, and the overhead is rarely a factor.

[Movian]

I just use 2.6 .... never had a problem. XP. XP SP3, Vista OR 7 but I agree with your reasoning :) and try to do the same with almost everything else (with a few exceptions with microsoft classes... Could you give me an example of late binding ADO and DAO ? mabye i will make changes just incase that never had a problem yet decides to change its mind....)

[Bob Phillips]

The technique is just the same.

Instead of


Dim rstThis As New ADODB.Recordset, counter As Integer

use


Dim rstThis As Object, counter As Integer

and then Create the recordset before using it

Set rstThis = CreateObject("ADODB.RecordSet")