Want to protect your cyber security and still get fast solutions? Ask a secure question today.Go Premium

x
?
Solved

Altering Macro to Export Individual Recurring Appointments

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

Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

Question has a verified solution.

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

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.
Today as you open your Outlook, you witness an error message: “Outlook is using an old copy of your Outlook Data File…”. Probably, Outlook is accessing an old OST file.
Finds all prime numbers in a range requested and places them in a public primes() array. I've demostrated a template size of 30 (2 * 3 * 5) but larger templates can be built such 210  (2 * 3 * 5 * 7) or 2310  (2 * 3 * 5 * 7 * 11). The larger templa…
There are cases when e.g. an IT administrator wants to have full access and view into selected mailboxes on Exchange server, directly from his own email account in Outlook or Outlook Web Access. This proves useful when for example administrator want…

578 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