Solved

Altering Macro to Export Individual Recurring Appointments

Posted on 2007-12-05
4
1,288 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
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

Microsoft Certification Exam 74-409

Veeam® is happy to provide the Microsoft community with a study guide prepared by MVP and MCT, Orin Thomas. This guide will take you through each of the exam objectives, helping you to prepare for and pass the examination.

Question has a verified solution.

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

Suggested Solutions

Many people use more than one email account and so it becomes difficult for them to manage them when they use separate accounts,  so, in this article, I have shared an easy way to add Other Mail Accounts in your Google Inbox. It helps to combine all…
When you have clients or friends from around the world, it becomes a challenge to arrange a meeting or effectively manage your time. This is where Outlook's capability to show 2 time zones in one calendar comes in handy.
This Micro Tutorial demonstrates how to create Excel charts: column, area, line, bar, and scatter charts. Formatting tips are provided as well.
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.

726 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