Go Premium for a chance to win a PS4. Enter to Win

x
?
Solved

Export Calendar Items Programmatically (VBA)

Posted on 2008-06-24
13
Medium Priority
?
3,023 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
  • 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
Concerto's Cloud Advisory Services

Want to avoid the missteps to gaining all the benefits of the cloud? Learn more about the different assessment options from our Cloud Advisory team.

 

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 2000 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

This article will help to fix the below errors for MS Exchange Server 2013 I. Certificate error "name on the security certificate is invalid or does not match the name of the site" II. Out of Office not working III. Make Internal URLs and Externa…
This article describes how to import Lotus Notes Contacts into Outlook 2016, 2013, 2010 and 2007 etc. with a few manual steps. You can easily export and migrate Lotus Notes contacts into Microsoft Outlook without having to use any third party tools.
This Experts Exchange video Micro Tutorial shows how to tell Microsoft Office that a word is NOT spelled correctly. Microsoft Office has a built-in, main dictionary that is shared by Office apps, including Excel, Outlook, PowerPoint, and Word. When …
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: …

963 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