Solved

Export Calendar Items Programmatically (VBA)

Posted on 2008-06-24
13
2,599 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
 

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
Highfive + Dolby Voice = No More Audio Complaints!

Poor audio quality is one of the top reasons people don’t use video conferencing. Get the crispest, clearest audio powered by Dolby Voice in every meeting. Highfive and Dolby Voice deliver the best video conferencing and audio experience for every meeting and every room.

 
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

Find Ransomware Secrets With All-Source Analysis

Ransomware has become a major concern for organizations; its prevalence has grown due to past successes achieved by threat actors. While each ransomware variant is different, we’ve seen some common tactics and trends used among the authors of the malware.

Join & Write a Comment

Resolve DNS query failed errors for Exchange
If you don't know how to downgrade, my instructions below should be helpful.
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 …
To add imagery to an HTML email signature, you have two options available to you. You can either add a logo/image by embedding it directly into the signature or hosting it externally and linking to it. The vast majority of email clients display l…

744 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

Need Help in Real-Time?

Connect with top rated Experts

13 Experts available now in Live!

Get 1:1 Help Now