• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 3289
  • Last Modified:

Export Calendar Items Programmatically (VBA)

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
HalfAndHalf
Asked:
HalfAndHalf
  • 7
  • 4
1 Solution
 
David LeeCommented:
Hi, HalfAndHalf.

Sure.  What do you want to export too?
0
 
HalfAndHalfAuthor Commented:
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
 
David LeeCommented:
Is CSV ok?
0
Free Tool: Path Explorer

An intuitive utility to help find the CSS path to UI elements on a webpage. These paths are used frequently in a variety of front-end development and QA automation tasks.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

 
HalfAndHalfAuthor Commented:
csv is great.
0
 
David LeeCommented:
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
 
HalfAndHalfAuthor Commented:
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
 
David LeeCommented:
HalfAndHalf,

I haven't forgotten about this question.  I was traveling with no internet connection.  I'll have a look at this tomorrow.
0
 
David LeeCommented:
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
 
HalfAndHalfAuthor Commented:
Thank you for sticking with this. I appreciate your assistance.
0
 
David LeeCommented:
You're welcome.  Sorry I was slow in spots.
0
 
lucidicaCommented:
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
 
David LeeCommented:
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
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Introducing Cloud Class® training courses

Tech changes fast. You can learn faster. That’s why we’re bringing professional training courses to Experts Exchange. With a subscription, you can access all the Cloud Class® courses to expand your education, prep for certifications, and get top-notch instructions.

  • 7
  • 4
Tackle projects and never again get stuck behind a technical roadblock.
Join Now