Want to win a PS4? Go Premium and enter to win our High-Tech Treats giveaway. Enter to Win

x
?
Solved

Altering Macro to Export Individual Recurring Appointments

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

[Webinar] Lessons on Recovering from Petya

Skyport is working hard to help customers recover from recent attacks, like the Petya worm. This work has brought to light some important lessons. New malware attacks like this can take down your entire environment. Learn from others mistakes on how to prevent Petya like worms.

Question has a verified solution.

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

Access developers frequently have requirements to interact with Excel (import from or output to) in their applications.  You might be able to accomplish this with the TransferSpreadsheet and OutputTo methods, but in this series of articles I will di…
If you need to forecast numbers -- typically for finance -- the Windows and Mac versions of Excel 2016 have a basket of tools to get the job done.
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…
Many of my clients call in with monstrous Gmail overloading issues with Outlook. A quick tip is to turn off the All Mail and Important folders from synching. Here is a quick video I made to show you how to turn off these and other folders in Gmail s…

636 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