?
Solved

Altering Macro to Export Individual Recurring Appointments

Posted on 2007-12-05
4
Medium Priority
?
1,299 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 2000 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

Get your Conversational Ransomware Defense e‑book

This e-book gives you an insight into the ransomware threat and reviews the fundamentals of top-notch ransomware preparedness and recovery. To help you protect yourself and your organization. The initial infection may be inevitable, so the best protection is to be fully prepared.

Question has a verified solution.

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

Changing a few Outlook Options can help keep you organized!
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 …
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…
Suggested Courses

765 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