Solved

Export Calendar Items Programmatically (VBA)

Posted on 2008-06-24
13
2,854 Views
Last Modified: 2011-08-18
Using the standard menu choices to export a calendar and its associated appointments does not work (some appointments are missing). The commonality is that these are recurring appointments. For example, I have set up a non-terminating recurring daily appointment. Sometimes I change the start/stop time of single occurrences. The export function doesn't always include all appointments.

Is there a VBA-solution to bulletproof export them?
0
Comment
Question by:HalfAndHalf
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 7
  • 4
13 Comments
 
LVL 76

Expert Comment

by:David Lee
ID: 21861323
Hi, HalfAndHalf.

Sure.  What do you want to export too?
0
 

Author Comment

by:HalfAndHalf
ID: 21861378
Ultimately, the data will be entered into a database (Access). For now, I'd like to export to a text file and then I can manipulate the data as I see fit.

BTW, the calendar is not the default "CALENDAR"--just another one in the list.
0
 
LVL 76

Expert Comment

by:David Lee
ID: 21861417
Is CSV ok?
0
[Live Webinar] The Cloud Skills Gap

As Cloud technologies come of age, business leaders grapple with the impact it has on their team's skills and the gap associated with the use of a cloud platform.

Join experts from 451 Research and Concerto Cloud Services on July 27th where we will examine fact and fiction.

 

Author Comment

by:HalfAndHalf
ID: 21861443
csv is great.
0
 
LVL 76

Expert Comment

by:David Lee
ID: 21861545
Ok.  Here's the code.  The usage will be:

    ExportFolder OpenOutlookFolder("MailboxName\Folder\SubFolder"), "C:\CalendarExport.csv"

for example

    ExportFolder OpenOutlookFolder("Mailbox - Doe, John\Calendar\My Calendar"), "C:\CalendarExport.csv"

Are you familiar with using Outlook scripts, or do you want more detailed instructions?
Sub ExportFolder(olkFolder As Outlook.MAPIFolder, strFilename As String)
    Dim objFSO As Object, _
        objFile As Object, _
        olkItem As Object, _
        olkProp As Outlook.ItemProperty, _
        bolHeader As Boolean, _
        strHeader As String, _
        strBuffer As String, _
        QT As String
    QT = Chr(34)
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFile = objFSO.CreateTextFile(strFilename, True)
    For Each olkItem In olkFolder.items
        For Each olkProp In olkItem.ItemProperties
            If Not olkProp.Type = olOutlookInternal Then
                If Not bolHeader Then
                    strHeader = strHeader & QT & olkProp.Name & QT & ","
                End If
                strBuffer = strBuffer & QT & olkProp.Value & QT & ","
            End If
        Next
        If Not bolHeader Then
            bolHeader = True
            strHeader = Left(strHeader, Len(strHeader) - 1)
            objFile.WriteLine strHeader
            strHeader = ""
        End If
        strBuffer = Left(strBuffer, Len(strBuffer) - 1)
        objFile.WriteLine strBuffer
        strBuffer = ""
    Next
    objFile.Close
    Set objFile = Nothing
    Set objFSO = Nothing
    Set olkItem = Nothing
    Set olkProp = Nothing
End Sub
 
Function IsNothing(obj)
  If TypeName(obj) = "Nothing" Then
    IsNothing = True
  Else
    IsNothing = False
  End If
End Function
 
Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
    Dim arrFolders As Variant, _
        varFolder As Variant, _
        olkFolder As Outlook.MAPIFolder
    On Error GoTo ehOpenOutlookFolder
    If strFolderPath = "" Then
        Set OpenOutlookFolder = Nothing
    Else
        If Left(strFolderPath, 1) = "\" Then
            strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
        End If
        arrFolders = Split(strFolderPath, "\")
        For Each varFolder In arrFolders
            If IsNothing(olkFolder) Then
                Set olkFolder = Session.Folders(varFolder)
            Else
                Set olkFolder = olkFolder.Folders(varFolder)
            End If
        Next
        Set OpenOutlookFolder = olkFolder
    End If
    On Error GoTo 0
    Exit Function
ehOpenOutlookFolder:
    Set OpenOutlookFolder = Nothing
    On Error GoTo 0
End Function

Open in new window

0
 

Author Comment

by:HalfAndHalf
ID: 21865473
Good morning BlueDevil,

Thanks for the immediate attention to this. The code runs but the individual instances of the daily recurring appointments didn't get captured. For example, I created a recurring appointment called "Attendance" which goes from 9am to 5pm. (No! I am not a 9-5er ;)) This runs M-F. (ditto).

Somedays, I change the individual occurrence to, say, 7am to 6pm. I want to be able to export for each day as shown in the calendar layout the appointments that appear on screen into a csv file. The program merely outputted the global settings of the series rather than each individual occurrence.

Any ideas?

Thanks a lot.
0
 
LVL 76

Expert Comment

by:David Lee
ID: 21904583
HalfAndHalf,

I haven't forgotten about this question.  I was traveling with no internet connection.  I'll have a look at this tomorrow.
0
 
LVL 76

Accepted Solution

by:
David Lee earned 500 total points
ID: 21934433
HalfAndHalf,

Here's the revised code.  Replace what you have with this version.  Call this with a command like this

    ExportCalendar Session.GetDefaultFolder(olFolderCalendar), "C:\eeTesting\Calendar.csv", #7/1/2008 12:01:00 AM#, #7/30/2008 11:59:00 PM#

This would export everything in July of this year.
Sub ExportCalendar(olkFolder As Outlook.MAPIFolder, strFilename As String, datStart As Date, datEnd As Date)
    Dim objFSO As Object, _
        objFile As Object, _
        olkItems As Outlook.items, _
        olkItem As Outlook.AppointmentItem, _
        strBuffer As String, _
        datMyStart As Date, _
        datMyEnd As Date, _
        QT As String
    QT = Chr(34)
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFile = objFSO.CreateTextFile(strFilename, True)
    Set olkItems = olkFolder.items
    olkItems.Sort "[Start]"
    olkItems.IncludeRecurrences = True
    datMyStart = VBA.Format(datStart, "Short Date")
    datMyEnd = VBA.Format(datEnd, "Short Date")
    Set olkItem = olkItems.Find("[Start] >= """ & datMyStart & """ and [Start] <= """ & datMyEnd & """")
    'Modify the header line to reflect all the values being written
    objFile.WriteLine "Subject,Start,End"
    While TypeName(olkItem) <> "Nothing"
        With olkItem
            'The first value has to be written with a command like this
            strBuffer = QT & .Subject & QT & ","
            'Each subsequent value has to be written with a line like this
            strBuffer = strBuffer & QT & .Start & QT & ","
            'The final value has to be written with a line like this
            strBuffer = strBuffer & QT & .End & QT
        End With
        objFile.WriteLine strBuffer
        strBuffer = ""
        Set olkItem = olkItems.FindNext
    Wend
    objFile.Close
    Set objFile = Nothing
    Set objFSO = Nothing
    Set olkItem = Nothing
    Set olkProp = Nothing
End Sub
 
Function IsNothing(obj)
  If TypeName(obj) = "Nothing" Then
    IsNothing = True
  Else
    IsNothing = False
  End If
End Function
 
Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
    Dim arrFolders As Variant, _
        varFolder As Variant, _
        olkFolder As Outlook.MAPIFolder
    On Error GoTo ehOpenOutlookFolder
    If strFolderPath = "" Then
        Set OpenOutlookFolder = Nothing
    Else
        If Left(strFolderPath, 1) = "\" Then
            strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
        End If
        arrFolders = Split(strFolderPath, "\")
        For Each varFolder In arrFolders
            If IsNothing(olkFolder) Then
                Set olkFolder = Session.Folders(varFolder)
            Else
                Set olkFolder = olkFolder.Folders(varFolder)
            End If
        Next
        Set OpenOutlookFolder = olkFolder
    End If
    On Error GoTo 0
    Exit Function
ehOpenOutlookFolder:
    Set OpenOutlookFolder = Nothing
    On Error GoTo 0
End Function

Open in new window

0
 

Author Closing Comment

by:HalfAndHalf
ID: 31470393
Thank you for sticking with this. I appreciate your assistance.
0
 
LVL 76

Expert Comment

by:David Lee
ID: 21968391
You're welcome.  Sorry I was slow in spots.
0
 
LVL 3

Expert Comment

by:lucidica
ID: 22206157
Hi,

I know this has an accepted solution, but I have the same issue, and am not sure how to implement your script, are you able to elaborate? :)

Cheers

Tom
0
 
LVL 76

Expert Comment

by:David Lee
ID: 22209132
Hi, Tom.

Follow these instructions to use the code.
  1. Start Outlook.
  2. Click Tools->Macro->Visual Basic Editor.
  3. If not already expanded, expand Modules and click on Module1.
  4. Copy the  code above and below and paste it into the right-hand pane of the VB Editor.
  5. Edit  the code as desired.  I placed a comment line where things can/need to change
  6. Click the diskette icon on the toolbar to save the  changes.
  7. Close the VB Editor.
  8. Click  Tools->Macro->Security.
  9. Change the Security Level setting to  Medium.
  10. Run the macro (Tools->Macro->Macros).
Sub RunExport()
    'Change the file name and path, and the starting/ending dates/times on the next line
    ExportCalendar Session.GetDefaultFolder(olFolderCalendar), "C:\eeTesting\Calendar.csv", #7/1/2008 12:01:00 AM#, #7/30/2008 11:59:00 PM#
End Sub

Open in new window

0

Featured Post

Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Find out what you should include to make the best professional email signature for your organization.
Changing a few Outlook Options can help keep you organized!
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
This video shows how to remove a single email address from the Outlook 2010 Auto Suggestion memory. NOTE: For Outlook 2016 and 2013 perform the exact same steps. Open a new email: Click the New email button in Outlook. Start typing the address: …

634 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question