VBA script to export Calendar to PST and CSV

  • Thread starter Thread starter Guest
  • Start date Start date
G

Guest

I am struggling to create a macro to export my calendar to PST and CSV. I
perform this task so often, automating would be great. Is there an easy way
to write this? And then, can I schedule it to run on its own?
 
Both these macros will work for either situation:

Sub ExportAppointmentsToCSVFile()
On Error Resume Next

'You must set a reference to the Microsoft Scripting Runtime library to
use the FileSystemObject

Dim objNS As Outlook.NameSpace
Dim objAppointments As Outlook.Items, objCalendarFolder As
Outlook.MAPIFolder
Dim objAppointment As Outlook.AppointmentItem
Dim objFS As Scripting.FileSystemObject, objOutputFile As
Scripting.TextStream

Set objNS = Application.GetNamespace("MAPI")
Set objCalendarFolder = objNS.GetDefaultFolder(olFolderCalendar)
Set objAppointments = objCalendarFolder.Items

Set objFS = New Scripting.FileSystemObject
Set objOutputFile = objFS.OpenTextFile("C:\Temp\AppointmentExport.csv",
ForWriting _
, True)

'Write header line
objOutputFile.WriteLine "Subject,Start,End"

For Each objAppointment In objAppointments
objOutputFile.WriteLine objAppointment.Subject & "," &
objAppointment.Start & "," & objAppointment.End
Next
objOutputFile.Close

Set objNS = Nothing
Set objAppointment = Nothing
Set objAppointments = Nothing
Set objCalendarFolder = Nothing
Set objFS = Nothing
Set objOutputFile = Nothing
End Sub

Sub CopyItemsToFolder()
On Error Resume Next

Dim objNS As Outlook.NameSpace
Dim objSourceItems As Outlook.Items
Dim objSourceItem As Object, objCopy As Object
Dim objSourceFolder As Outlook.MAPIFolder
Dim objDestinationFolder As Outlook.MAPIFolder
Dim blnCopyFolder As Boolean

Set objNS = Application.GetNamespace("MAPI")

MsgBox "In the next dialog, please select the source folder containing
the items you want to copy...", vbOKOnly
Set objSourceFolder = objNS.PickFolder
If objSourceFolder Is Nothing Then GoTo Exitt: 'User cancelled

If MsgBox("Do you wish to copy the entire folder? Click 'No' to copy
just the contents of the folder. Otherwise, all subfolders" _
& " will also be copied.", vbYesNo + vbQuestion, "Select Copy Type")
= vbYes Then
blnCopyFolder = True
MsgBox "In the next dialog, please select the parent folder where
you want the new folder copied to...", vbOKOnly
Else
MsgBox "In the next dialog, please select the destination folder
where you want the folder items copied to...", vbOKOnly
End If

Set objDestinationFolder = objNS.PickFolder
If objDestinationFolder Is Nothing Then GoTo Exitt: 'User cancelled

If objDestinationFolder.DefaultItemType <>
objSourceFolder.DefaultItemType Then
If blnCopyFolder = False Then
MsgBox "Please pick a destination folder that is of the same
default item type as the source folder." _
, vbOKOnly + vbExclamation, "Invalid Folder"
GoTo Exitt:
End If
End If

If blnCopyFolder = True Then
objSourceFolder.CopyTo objDestinationFolder
Else
Set objSourceItems = objSourceFolder.Items
For Each objSourceItem In objSourceItems
Set objCopy = objSourceItem.Copy
objCopy.Move objDestinationFolder
Next
End If

MsgBox "Copy complete."

Exitt:
Set objNS = Nothing
Set objCopy = Nothing
Set objSourceFolder = Nothing
Set objSourceItem = Nothing
Set objSourceItems = Nothing
Set objDestinationFolder = Nothing
End Sub
 
I tried this and it works well. However, what about recurring appointments?
Manual export hadles recurring appointments but can it be done with VBA code?
 
Certainly. Use the AppointmentItem.GetRecurrencePattern method to get a
RecurrencePattern object. You can then work with that object in conjunction
with the GetOccurrence method to retrieve any AppointmentItem object in the
range. See the Outlook VBA help file on these topics for oodles of sample
code that you can integrate with the export sample I gave.

--
Eric Legault (Outlook MVP, MCDBA, MCTS: Messaging & Collaboration)
Try Picture Attachments Wizard for Outlook:
http://www.collaborativeinnovations.ca
Blog: http://blogs.officezealot.com/legault/
 
I would appreciate knowing what changes need to be made to this code, so that
I can export my 2002 Outlook Calendar to an access database file. Any help is
appreciated:

Sub ExportAppointmentsToCSVFile()
On Error Resume Next
Dim objNS As Outlook.NameSpace
Dim objAppointments As Outlook.Items, objCalendarFolder As
Outlook.MAPIFolder
Dim objAppointment As Outlook.AppointmentItem
Dim objFS As Scripting.FileSystemObject, objOutputFile As
Scripting.TextStream

Set objNS = Application.GetNamespace("MAPI")
Set objCalendarFolder = objNS.GetDefaultFolder(olFolderCalendar)
Set objAppointments = objCalendarFolder.Items

Set objFS = New Scripting.FileSystemObject
Set objOutputFile = objFS.OpenTextFile("C:\Temp\AppointmentExport.csv",
ForWriting, True)

'Write header line
objOutputFile.WriteLine "Subject,Start,End"

For Each objAppointment In objAppointments
objOutputFile.WriteLine objAppointment.Subject & "," &
objAppointment.Start & "," & objAppointment.End
Next
objOutputFile.Close

Set objNS = Nothing
Set objAppointment = Nothing
Set objAppointments = Nothing
Set objCalendarFolder = Nothing
Set objFS = Nothing
Set objOutputFile = Nothing
End Sub
 
My browser timed out, I don't know if this made it through. Do you know what
alterations need to be made to this for it to export my calendar to an access
file?

Sub ExportAppointmentsToCSVFile()
On Error Resume Next


Dim objNS As Outlook.NameSpace
Dim objAppointments As Outlook.Items, objCalendarFolder As
Outlook.MAPIFolder
Dim objAppointment As Outlook.AppointmentItem
Dim objFS As Scripting.FileSystemObject, objOutputFile As
Scripting.TextStream

Set objNS = Application.GetNamespace("MAPI")
Set objCalendarFolder = objNS.GetDefaultFolder(olFolderCalendar)
Set objAppointments = objCalendarFolder.Items

Set objFS = New Scripting.FileSystemObject
Set objOutputFile = objFS.OpenTextFile("C:\Temp\AppointmentExport.csv",
ForWriting, True)

'Write header line
objOutputFile.WriteLine "Subject,Start,End"

For Each objAppointment In objAppointments
objOutputFile.WriteLine objAppointment.Subject & "," &
objAppointment.Start & "," & objAppointment.End
Next
objOutputFile.Close

Set objNS = Nothing
Set objAppointment = Nothing
Set objAppointments = Nothing
Set objCalendarFolder = Nothing
Set objFS = Nothing
Set objOutputFile = Nothing
End Sub
 
It's actually easier to import from Outlook into Access, without any code at
all. In Access, choose File -> Get External Data -> Import... and select
Outlook from the Files of Type dropdown. You can then browse your Outlook
data store to import from any folder - Calendar, Contacts, etc. However, the
key Start and End fields are NOT imported! Kind of pointless, but if you
just want the subject and body this would suffice (probably not!).
Otherwise, the procedure below could be easily modified to write only
Calendar items to the database of your choice and the table and fields you've
already created. If you need more help, ping me after the weekend and I can
make this more "calendar friendly".

Sub WriteEmailToDatabase()
Dim objFolder As Outlook.MAPIFolder, objItems As Outlook.Items
Dim objEmail As Outlook.MailItem, objMessageObj As Object
Dim dbsThis As DAO.Database, rstThis As DAO.Recordset

Set dbsThis = DAO.OpenDatabase("C:\Documents and
Settings\elegault\Desktop\db1.mdb")
Set rstThis = dbsThis.OpenRecordset("Table1", dbOpenDynaset)

Set objFolder = Application.ActiveExplorer.CurrentFolder
Set objItems = objFolder.Items
For Each objMessageObj In objItems
If objMessageObj.Class = olMail Then
Set objEmail = objMessageObj

'SAVE TO ACCESS DATABASE
rstThis.AddNew
rstThis("Subject") = objEmail.Subject
rstThis("Body") = objEmail.Body
rstThis.UPdate
End If
Next
End Sub
 
Eric,

I appreciated your advice on Importing Outlook from within Access, but as
you said, the key Start/End fields--along with meeting organizer--are not
included.

So I would appreciate being tweaked a little, to be able to include all
Outlook Calendar data: and then I’ll just query out unnecessary fields,
dates, etc. once inside Access.

But indeed I do need help tweaking. Along with any Tools, References that I
should have checked in Outlook to make this work.

Sub WriteEmailToDatabase()

Dim objFolder As Outlook.MAPIFolder, objItems As Outlook.Items
Dim objEmail As Outlook.MailItem, objMessageObj As Object
Dim dbsThis As DAO.Database, rstThis As DAO.Recordset

Set dbsThis = DAO.OpenDatabase("C:\Documents and
Settings\elegault\Desktop\db1.mdb")

Set rstThis = dbsThis.OpenRecordset("Table1", dbOpenDynaset)
Set objFolder = Application.ActiveExplorer.CurrentFolder
Set objItems = objFolder.Items

For Each objMessageObj In objItems
If objMessageObj.Class = olMail Then
Set objEmail = objMessageObj
'SAVE TO ACCESS DATABASE
rstThis.AddNew
rstThis("Subject") = objEmail.Subject
rstThis("Body") = objEmail.Body
rstThis.UPdate
End If
Next

End Sub
 
At the risk of sounding too teacher-like, you should have at least tried to
take what I had and ran with it. My bad too, because I could have gave you
some general guidelines rather than code the whole solution for you, but I
simply can't resist...

'---------------------------------------------------------------------------------------
' 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 'Calendar':
' : Subject (Text)
' : Contents (Memo)
' : Start (Date/Time)
' : End (Date/Time)
'
' Example Call:
' ExportCalendarToDatabase "C:\Test\db1.mdb"
'---------------------------------------------------------------------------------------

Sub ExportCalendarToDatabase(PathToAccessDB As String)
On Error GoTo ExportCalendarToDatabase_Error

Dim objFolder As Outlook.MAPIFolder, objItems As Outlook.Items
Dim objAppt As Outlook.AppointmentItem, objMessageObj As Object
Dim conThis As ADODB.Connection, rstThis As ADODB.Recordset

Set conThis = New ADODB.Connection
conThis.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" &
PathToAccessDB & ";Persist Security Info=False"
Set rstThis = New ADODB.Recordset

rstThis.Open "Calendar", conThis, 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 = Application.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
For Each objMessageObj In objItems
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
rstThis("Start").Value = objAppt.Start
rstThis("End").Value = objAppt.End
rstThis.UPdate
End If
Next

Exitt:
On Error Resume Next
Set rstThis = Nothing
conThis.Close
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

--
Eric Legault (Outlook MVP, MCDBA, MCTS: Messaging & Collaboration)
Try Picture Attachments Wizard for Outlook:
http://www.collaborativeinnovations.ca
Blog: http://blogs.officezealot.com/legault/
 
Eric,

Let me just say, thank you so much for taking the time to craft a solution,
rather than me figuring it out. I program in VBA in Word, Excel, Access,
PowerPoint, and I have no idea what I'm doing in Outlook. It's a lot
different to me. So thanks for the solution. Now that I'm back at the
computer, I'll give it a try and let you know how it works.

I'm glad you couldn't resist tackling the problem.

Eric Legault said:
At the risk of sounding too teacher-like, you should have at least tried to
take what I had and ran with it. My bad too, because I could have gave you
some general guidelines rather than code the whole solution for you, but I
simply can't resist...

'---------------------------------------------------------------------------------------
' 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 'Calendar':
' : Subject (Text)
' : Contents (Memo)
' : Start (Date/Time)
' : End (Date/Time)
'
' Example Call:
' ExportCalendarToDatabase "C:\Test\db1.mdb"
'---------------------------------------------------------------------------------------

Sub ExportCalendarToDatabase(PathToAccessDB As String)
On Error GoTo ExportCalendarToDatabase_Error

Dim objFolder As Outlook.MAPIFolder, objItems As Outlook.Items
Dim objAppt As Outlook.AppointmentItem, objMessageObj As Object
Dim conThis As ADODB.Connection, rstThis As ADODB.Recordset

Set conThis = New ADODB.Connection
conThis.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" &
PathToAccessDB & ";Persist Security Info=False"
Set rstThis = New ADODB.Recordset

rstThis.Open "Calendar", conThis, 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 = Application.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
For Each objMessageObj In objItems
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
rstThis("Start").Value = objAppt.Start
rstThis("End").Value = objAppt.End
rstThis.UPdate
End If
Next

Exitt:
On Error Resume Next
Set rstThis = Nothing
conThis.Close
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

--
Eric Legault (Outlook MVP, MCDBA, MCTS: Messaging & Collaboration)
Try Picture Attachments Wizard for Outlook:
http://www.collaborativeinnovations.ca
Blog: http://blogs.officezealot.com/legault/


Access101 said:
Eric,

I appreciated your advice on Importing Outlook from within Access, but as
you said, the key Start/End fields--along with meeting organizer--are not
included.

So I would appreciate being tweaked a little, to be able to include all
Outlook Calendar data: and then I’ll just query out unnecessary fields,
dates, etc. once inside Access.

But indeed I do need help tweaking. Along with any Tools, References that I
should have checked in Outlook to make this work.

Sub WriteEmailToDatabase()

Dim objFolder As Outlook.MAPIFolder, objItems As Outlook.Items
Dim objEmail As Outlook.MailItem, objMessageObj As Object
Dim dbsThis As DAO.Database, rstThis As DAO.Recordset

Set dbsThis = DAO.OpenDatabase("C:\Documents and
Settings\elegault\Desktop\db1.mdb")

Set rstThis = dbsThis.OpenRecordset("Table1", dbOpenDynaset)
Set objFolder = Application.ActiveExplorer.CurrentFolder
Set objItems = objFolder.Items

For Each objMessageObj In objItems
If objMessageObj.Class = olMail Then
Set objEmail = objMessageObj
'SAVE TO ACCESS DATABASE
rstThis.AddNew
rstThis("Subject") = objEmail.Subject
rstThis("Body") = objEmail.Body
rstThis.UPdate
End If
Next

End Sub
Click to expand...
Click to expand...
 
Back
Top