none
Outlook 2010 export - VBA

    Question

  • Hi,

    I've been trying for weeks now to get someone who can actually help me answer this question.

    I have code that will export the selected calendar (only one calendar) to an excel document which is great! Works a treat! My only issue is that i want to export more than one calendar at the same time! So rather than just exporting the one i have selected i would like to export all the calendar names that I want...

    Here is my code so far (below). If you can amend the code below and send it back to me that would be awesome and would thank that individual immensely!!!

    Sub ExportAppointmentsToExcel()
        Const SCRIPT_NAME = "Export Calendar to Excel"
        Const xlAscending = 1
        Const xlYes = 1
        Dim olkFld As Object, _
            olkLst As Object, _
            olkRes As Object, _
            olkApt As Object, _
            olkRec As Object, _
            excApp As Object, _
            excWkb As Object, _
            excWks As Object, _
            lngRow As Long, _
            lngCnt As Long, _
            strFil As String, _
            strLst As String, _
            strDat As String, _
            datBeg As Date, _
            datEnd As Date, _
            arrTmp As Variant
        Set olkFld = Application.ActiveExplorer.CurrentFolder
        If olkFld.DefaultItemType = olAppointmentItem Then
            strDat = InputBox("Enter the date range of the calendar to export in the form ""mm/dd/yyyy to mm/dd/yyyy""", SCRIPT_NAME, Date & " to " & Date)
            arrTmp = Split(strDat, "to")
            datBeg = IIf(IsDate(arrTmp(0)), arrTmp(0), Date) & " 12:00am"
            datEnd = IIf(IsDate(arrTmp(1)), arrTmp(1), Date) & " 11:59pm"
            strFil = InputBox("Enter a filename (including path) to save the exported appointments to.", SCRIPT_NAME)
            If strFil <> "" Then
                Set excApp = CreateObject("Excel.Application")
                Set excWkb = excApp.Workbooks.Add()
                Set excWks = excWkb.Worksheets(1)
                'Write Excel Column Headers
                With excWks
                    .Cells(1, 1) = "Category"
                    .Cells(1, 2) = "Subject"
                    .Cells(1, 3) = "Starting Date"
                    .Cells(1, 4) = "Ending Date"
                    .Cells(1, 5) = "Start Time"
                    .Cells(1, 6) = "End Time"
                    .Cells(1, 7) = "Hours"
                    .Cells(1, 8) = "Attendees"
                End With
                lngRow = 2
                Set olkLst = olkFld.Items
                olkLst.Sort "[Start]"
                olkLst.IncludeRecurrences = True
                Set olkRes = olkLst.Restrict("[Start] >= '" & Format(datBeg, "ddddd h:nn AMPM") & "' AND [Start] <= '" & Format(datEnd, "ddddd h:nn AMPM") & "'")
                'Write appointments to spreadsheet
                For Each olkApt In olkRes
                    'Only export appointments
                    If olkApt.Class = olAppointment Then
                        strLst = ""
                        For Each olkRec In olkApt.Recipients
                            strLst = strLst & olkRec.Name & ", "
                        Next
                        If strLst <> "" Then strLst = Left(strLst, Len(strLst) - 2)
                        'Add a row for each field in the message you want to export
                        excWks.Cells(lngRow, 1) = olkApt.Categories
                        excWks.Cells(lngRow, 2) = olkApt.Subject
                        excWks.Cells(lngRow, 3) = Format(olkApt.Start, "mm/dd/yyyy")
                        excWks.Cells(lngRow, 4) = Format(olkApt.End, "mm/dd/yyyy")
                        excWks.Cells(lngRow, 5) = Format(olkApt.Start, "hh:nn ampm")
                        excWks.Cells(lngRow, 6) = Format(olkApt.End, "hh:nn ampm")
                        excWks.Cells(lngRow, 7) = DateDiff("n", olkApt.Start, olkApt.End) / 60
                        excWks.Cells(lngRow, 7).NumberFormat = "0.00"
                        excWks.Cells(lngRow, 8) = strLst
                        lngRow = lngRow + 1
                        lngCnt = lngCnt + 1
                    End If
                Next
                excWks.Columns("A:H").AutoFit
                excWks.Range("A1:H" & lngRow - 1).Sort Key1:="Category", Order1:=xlAscending, Header:=xlYes
                excWks.Cells(lngRow, 7) = "=sum(G2:G" & lngRow - 1 & ")"
                excWkb.SaveAs strFil
                excWkb.Close
                MsgBox "Process complete.  A total of " & lngCnt & " appointments were exported.", vbInformation + vbOKOnly, SCRIPT_NAME
            End If
        Else
            MsgBox "Operation cancelled.  The selected folder is not a calendar.  You must select a calendar for this macro to work.", vbCritical + vbOKOnly, SCRIPT_NAME
        End If
        Set excWks = Nothing
        Set excWkb = Nothing
        Set excApp = Nothing
        Set olkApt = Nothing
        Set olkLst = Nothing
        Set olkFld = Nothing
    End Sub
    

    Friday, November 06, 2015 2:56 PM

Answers

  • Hello Cameron,

    Instead of using the following line of code where you get the current folder:

     Set olkFld = Application.ActiveExplorer.CurrentFolder
    

    You need to iterate over all Outlook folders checking the DefaultItemType property as you do right now:

     If olkFld.DefaultItemType = olAppointmentItem Then
    

    The following VBA macro lists all subfolders recursively:

    Public Sub LoopFolders(Folders As Outlook.Folders, _
      ByVal Recursive As Boolean _
    )
      Dim Folder As Outlook.MAPIFolder
    
      For Each Folder In Folders
        DoAnything Folder
    
        If Recursive Then
          LoopFolders Folder.Folders, Recursive
        End If
      Next
    End Sub
    
    Private Sub DoAnything(Folder As Outlook.MAPIFolder)
      Debug.Print Folder.Name
    End Sub
    You may also find the Can I iterate through all Outlook emails in a folder including sub-folders? page helpful.

    Friday, November 06, 2015 3:27 PM