Solved

Altering Macro to Export Individual Recurring Appointments

Posted on 2007-12-05
4
1,280 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

Do You Know the 4 Main Threat Actor Types?

Do you know the main threat actor types? Most attackers fall into one of four categories, each with their own favored tactics, techniques, and procedures.

Join & Write a Comment

If you don't know how to downgrade, my instructions below should be helpful.
This article descibes how to create a connection between Excel and SAP and how to move data from Excel to SAP or the other way around.
This Micro Tutorial demonstrate the bugs in Microsoft Excel for Mac with Pivot Charts.
This Micro Tutorial demonstrates in Microsoft Excel how to consolidate your marketing data by creating an interactive charts using form controls. This creates cool drop-downs for viewers of your chart to choose from.

759 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

20 Experts available now in Live!

Get 1:1 Help Now