Solved

Altering Macro to Export Individual Recurring Appointments

Posted on 2007-12-05
4
1,282 Views
Last Modified: 2008-05-24
The macro I use was originally written by Helen Feddema to export Outlook appointment data to an Excel spreadsheet.
I made very minor modifications to add a start date and end date.
It works fine except that it does not export recurring appointments.  Does anyone have any idea how to do this?
Thanks.

Sub SaveCalendarToExcel2()

     'Created by Helen Feddema 9-17-2004

     'Last modified 9-17-2004

     'Demonstrates pushing Calendar data to rows in an Excel worksheet

     

    On Error GoTo ErrorHandler

     

    Dim appWord As Word.Application

    Dim appExcel As Excel.Application

    Dim wkb As Excel.Workbook

    Dim wks As Excel.Worksheet

    Dim rng As Excel.Range

    Dim strSheet As String

    Dim strTemplatePath As String

    Dim i As Integer

    Dim j As Integer

    Dim lngCount As Long

    Dim nms As Outlook.NameSpace

    Dim fld As Outlook.MAPIFolder

     'Must declare as Object because folders may contain different

     'types of items

    Dim itm As Object

    Dim strTitle As String

    Dim strPrompt As String

    Dim SetStartDate As Date

    Dim SetEndDate As Date

    

     'Pick up  Template path from the Word Options dialog

    Set appWord = GetObject(, "Word.Application")

    strTemplatePath = appWord.Options.DefaultFilePath(wdUserTemplatesPath) & "\"

    Debug.Print "Templates folder: " & strTemplatePath

    strSheet = "Calendar.xls"

    strSheet = strTemplatePath & strSheet

    Debug.Print "Excel workbook: " & strSheet

     

     'Test for file in the Templates folder

    If TestFileExists(strSheet) = False Then

        strTitle = "Worksheet file not found"

        strPrompt = strSheet & _

        " not found; please copy Calendar.xls to this folder and try again"

        MsgBox strPrompt, vbCritical + vbOKOnly, strTitle

        GoTo ErrorHandlerExit

    End If

     

    Set appExcel = GetObject(, "Excel.Application")

    appExcel.Workbooks.Open (strSheet)

    Set wkb = appExcel.ActiveWorkbook

    Set wks = wkb.Sheets(1)

    wks.Activate

    appExcel.Application.Visible = True

     

     'Let user select a folder to export

    Set nms = Application.GetNamespace("MAPI")

    Set fld = nms.PickFolder

    If fld Is Nothing Then

        GoTo ErrorHandlerExit

    End If

     

     'Test whether selected folder contains contact items

    If fld.DefaultItemType <> olAppointmentItem Then

        MsgBox "Folder is not a calendar folder"

        GoTo ErrorHandlerExit

    End If

     

    lngCount = fld.Items.Count

     

    If lngCount = 0 Then

        MsgBox "No appointments to export"

        GoTo ErrorHandlerExit

    Else

        Debug.Print lngCount & " appointments to export"

    End If
 

    SetStartDate = Now

    SetEndDate = Now + 3

    Debug.Print SetStartDate

    Debug.Print SetEndDate

    

     'Adjust i (row number) to be 1 less than the number of the first body row

    i = 3

     

     'Iterate through contact items in Calendar folder, and export a few fields

     'from each item to a row in the Calendar worksheet

    For Each itm In fld.Items

        

        If (itm.Start >= SetStartDate And itm.Start <= SetEndDate) Then

        

        If itm.Class = olAppointment Then

        'Process item only if it is an appointment item

            i = i + 1

             

             'j is the column number

            j = 1

             

            Set rng = wks.Cells(i, j)

            

            If itm.Start <> "" Then rng.Value = itm.Start

            j = j + 1

             

            Set rng = wks.Cells(i, j)

            If itm.End <> "" Then rng.Value = itm.End

            j = j + 1

             

            Set rng = wks.Cells(i, j)

            If itm.CreationTime <> "" Then rng.Value = itm.CreationTime

            j = j + 1

             

            Set rng = wks.Cells(i, j)

            If itm.Subject <> "" Then rng.Value = itm.Subject

            j = j + 1

             

            Set rng = wks.Cells(i, j)

            If itm.Location <> "" Then rng.Value = itm.Location

            j = j + 1

             

            Set rng = wks.Cells(i, j)

            If itm.Categories <> "" Then rng.Value = itm.Categories

            j = j + 1

             

            Set rng = wks.Cells(i, j)

            If itm.IsRecurring <> "" Then rng.Value = itm.IsRecurring

            j = j + 1

             

            Set rng = wks.Cells(i, j)

            On Error Resume Next

             'The next line illustrates the syntax for referencing

             'a custom Outlook field

            If itm.UserProperties("CustomField") <> "" Then

                rng.Value = itm.UserProperties("CustomField")

            End If

            j = j + 1

        

        End If

        

        'i = i + 1

        

        Debug.Print i

        Debug.Print itm.Class

        

        End If

                

    Next itm

     

ErrorHandlerExit:

    Exit Sub

     

ErrorHandler:

    If Err.Number = 429 Then

         'Application object is not set by GetObject; use CreateObject instead

        If appWord Is Nothing Then

            Set appWord = CreateObject("Word.Application")

            Resume Next

        ElseIf appExcel Is Nothing Then

            Set appExcel = CreateObject("Excel.Application")

            Resume Next

        End If

    Else

        MsgBox "Error No: " & Err.Number & "; Description: "

        Resume ErrorHandlerExit

    End If

     

End Sub

 

Public Function TestFileExists(strFile As String) As Boolean

     'Created by Helen Feddema 9-1-2004

     'Last modified 9-1-2004

     'Tests for existing of a file, using the FileSystemObject

     

    Dim fso As New Scripting.FileSystemObject

    Dim fil As Scripting.File

     

    On Error Resume Next

     

    Set fil = fso.GetFile(strFile)

    If fil Is Nothing Then

        TestFileExists = False

    Else

        TestFileExists = True

    End If

     

End Function

Open in new window

0
Comment
Question by:levinho
4 Comments
 
LVL 12

Expert Comment

by:chandru_sol
ID: 20413680
Does the original code to this?
0
 
LVL 59

Accepted Solution

by:
Chris Bottomley earned 500 total points
ID: 21291273
Not completely efficient ... I have simply copied a block of code but try the attached

Chris
Sub SaveCalendarToExcel2()

     'Created by Helen Feddema 9-17-2004

     'Last modified 9-17-2004

     'Demonstrates pushing Calendar data to rows in an Excel worksheet

     

    On Error GoTo ErrorHandler

     

    Dim appWord As Word.Application

    Dim appExcel As Excel.Application

    Dim wkb As Excel.Workbook

    Dim wks As Excel.Worksheet

    Dim rng As Excel.Range

    Dim strSheet As String

    Dim strTemplatePath As String

    Dim i As Integer

    Dim j As Integer

    Dim lngCount As Long

    Dim nms As Outlook.NameSpace

    Dim recur As Outlook.RecurrencePattern

    Dim fld As Outlook.MAPIFolder

     'Must declare as Object because folders may contain different

     'types of items

    Dim itm As Object

    Dim strTitle As String

    Dim strPrompt As String

    Dim SetStartDate As Date

    Dim SetEndDate As Date

    

     'Pick up  Template path from the Word Options dialog

    Set appWord = GetObject(, "Word.Application")

    strTemplatePath = appWord.Options.DefaultFilePath(wdUserTemplatesPath) & "\"

    Debug.Print "Templates folder: " & strTemplatePath

    strSheet = "Calendar.xls"

    strSheet = strTemplatePath & strSheet

    Debug.Print "Excel workbook: " & strSheet

     

     'Test for file in the Templates folder

    If TestFileExists(strSheet) = False Then

        strTitle = "Worksheet file not found"

        strPrompt = strSheet & _

        " not found; please copy Calendar.xls to this folder and try again"

        MsgBox strPrompt, vbCritical + vbOKOnly, strTitle

        GoTo ErrorHandlerExit

    End If

     

    Set appExcel = GetObject(, "Excel.Application")

    appExcel.Workbooks.Open (strSheet)

    Set wkb = appExcel.ActiveWorkbook

    Set wks = wkb.Sheets(1)

    wks.Activate

    appExcel.Application.Visible = True

     

     'Let user select a folder to export

    Set nms = Application.GetNamespace("MAPI")

    Set fld = nms.PickFolder

    If fld Is Nothing Then

        GoTo ErrorHandlerExit

    End If

     

     'Test whether selected folder contains contact items

    If fld.DefaultItemType <> olAppointmentItem Then

        MsgBox "Folder is not a calendar folder"

        GoTo ErrorHandlerExit

    End If

     

    lngCount = fld.Items.Count

     

    If lngCount = 0 Then

        MsgBox "No appointments to export"

        GoTo ErrorHandlerExit

    Else

        Debug.Print lngCount & " appointments to export"

    End If

 

    SetStartDate = Now

    SetEndDate = Now + 3

    Debug.Print SetStartDate

    Debug.Print SetEndDate

    

     'Adjust i (row number) to be 1 less than the number of the first body row

    i = 3

     

     'Iterate through contact items in Calendar folder, and export a few fields

     'from each item to a row in the Calendar worksheet

    For Each itm In fld.Items

        If itm.Class = olAppointment Then

        'Process item only if it is an appointment item

            If itm.IsRecurring Then

                Set recur = itm.GetRecurrencePattern

                If (recur.PatternStartDate >= SetStartDate And recur.PatternEndDate <= SetEndDate) Then

                

                    i = i + 1

                     

                     'j is the column number

                    j = 1

                     

                    Set rng = wks.Cells(i, j)

                    

                    If recur.PatternStartDate <> "" Then rng.Value = recur.PatternStartDate

                    j = j + 1

                     

                    Set rng = wks.Cells(i, j)

                    If recur.PatternEndDate <> "" Then rng.Value = recur.PatternEndDate

                    j = j + 1

                     

                    Set rng = wks.Cells(i, j)

                    If itm.CreationTime <> "" Then rng.Value = itm.CreationTime

                    j = j + 1

                     

                    Set rng = wks.Cells(i, j)

                    If itm.Subject <> "" Then rng.Value = itm.Subject

                    j = j + 1

                     

                    Set rng = wks.Cells(i, j)

                    If itm.Location <> "" Then rng.Value = itm.Location

                    j = j + 1

                     

                    Set rng = wks.Cells(i, j)

                    If itm.Categories <> "" Then rng.Value = itm.Categories

                    j = j + 1

                     

                    Set rng = wks.Cells(i, j)

                    If itm.IsRecurring <> "" Then rng.Value = itm.IsRecurring

                    j = j + 1

                     

                    Set rng = wks.Cells(i, j)

                    On Error Resume Next

                     'The next line illustrates the syntax for referencing

                     'a custom Outlook field

                    If itm.UserProperties("CustomField") <> "" Then

                        rng.Value = itm.UserProperties("CustomField")

                    End If

                    j = j + 1

                

                End If

            Else

                If (itm.Start >= SetStartDate And itm.Start <= SetEndDate) Then

                

                    i = i + 1

                     

                     'j is the column number

                    j = 1

                     

                    Set rng = wks.Cells(i, j)

                    

                    If itm.Start <> "" Then rng.Value = itm.Start

                    j = j + 1

                     

                    Set rng = wks.Cells(i, j)

                    If itm.End <> "" Then rng.Value = itm.End

                    j = j + 1

                     

                    Set rng = wks.Cells(i, j)

                    If itm.CreationTime <> "" Then rng.Value = itm.CreationTime

                    j = j + 1

                     

                    Set rng = wks.Cells(i, j)

                    If itm.Subject <> "" Then rng.Value = itm.Subject

                    j = j + 1

                     

                    Set rng = wks.Cells(i, j)

                    If itm.Location <> "" Then rng.Value = itm.Location

                    j = j + 1

                     

                    Set rng = wks.Cells(i, j)

                    If itm.Categories <> "" Then rng.Value = itm.Categories

                    j = j + 1

                     

                    Set rng = wks.Cells(i, j)

                    If itm.IsRecurring <> "" Then rng.Value = itm.IsRecurring

                    j = j + 1

                     

                    Set rng = wks.Cells(i, j)

                    On Error Resume Next

                     'The next line illustrates the syntax for referencing

                     'a custom Outlook field

                    If itm.UserProperties("CustomField") <> "" Then

                        rng.Value = itm.UserProperties("CustomField")

                    End If

                    j = j + 1

                

                End If

            End If

        

            Debug.Print i

            Debug.Print itm.Class

        

        End If

                

    Next itm

     

ErrorHandlerExit:

    Exit Sub

     

ErrorHandler:

    If Err.Number = 429 Then

         'Application object is not set by GetObject; use CreateObject instead

        If appWord Is Nothing Then

            Set appWord = CreateObject("Word.Application")

            Resume Next

        ElseIf appExcel Is Nothing Then

            Set appExcel = CreateObject("Excel.Application")

            Resume Next

        End If

    Else

        MsgBox "Error No: " & Err.Number & "; Description: "

        Resume ErrorHandlerExit

    End If

     

End Sub

Open in new window

0

Featured Post

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

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

Outlook Free & Paid Tools
Finding original email is quite difficult due to their duplicates. From this article, you will come to know why multiple duplicates of same emails appear and how to delete duplicate emails from Outlook securely and instantly while vital emails remai…
This Micro Tutorial will demonstrate the scrolling table in Microsoft Excel using the INDEX function.
This Micro Tutorial will demonstrate how to create pivot charts out of a data set. I also added a drop-down menu which allows to choose from different categories in the data set and the chart will automatically update.

919 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

15 Experts available now in Live!

Get 1:1 Help Now