将Outlook 2010日历导出到Excel 2010 - 代码无法正常工作 [英] Export Outlook 2010 Calendar to Excel 2010 - code not working

问题描述

您好， 

我的任务是为我所在的部门创建资源计划。我想做的是导出每个Outlook 2010交换日历到excel 2010.我有这段代码（下面）应该可以工作但是我遇到了麻烦，因为'Calendar-tul0crf'的文件夹
路径无法识别？！请你看看，让我知道我哪里出错了？或者，如果还有其他方式我可以接近这个？ 

I have been tasked to create a resource plan for the department I work in. What I would like to do, is export each Outlook 2010 exchange calendar to excel 2010. I have this piece of code (below) which should work however i'm having trouble because the folder path to 'Calendar - tul0crf' is not recognised?! Please can you take a look and let me know where i'm going wrong? Or alternatively, if there is another way I could approach this? 

Sub ExportAppointmentsToExcel()
    'On the next line, edit the list of calendars you want to export.  Each entry is the path to a calendar.  Entries are separated by a comma.
    Const CAL_LIST = "Calendar - tul0crf"
    'On the next line, edit the path to and name of the Excel spreadsheet to export to
    Const EXCEL_FILE = "\\ketpddsc01\users\tul0crf\CameronTest.xlsx"
    Const SCRIPT_NAME = "Export Appointments to Excel (Rev 2)"
    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, _
        arrCal As Variant, _
        varCal As Variant
    strDat = InputBox("Enter the date range of the appointments 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"
    Set excApp = CreateObject("Excel.Application")
    Set excWkb = excApp.Workbooks.Add()
    Set excWks = excWkb.Worksheets(1)
    'Write Excel Column Headers
    With excWks
        .Cells(1, 1) = "Calendar"
        .Cells(1, 2) = "Category"
        .Cells(1, 3) = "Subject"
        .Cells(1, 4) = "Starting Date"
        .Cells(1, 5) = "Ending Date"
        .Cells(1, 6) = "Start Time"
        .Cells(1, 7) = "End Time"
        .Cells(1, 8) = "Hours"
        .Cells(1, 9) = "Attendees"
    End With
    lngRow = 2
    arrCal = Split(CAL_LIST, ",")
    For Each varCal In arrCal
        Set olkFld = OpenOutlookFolder(CStr(varCal))
        If TypeName(olkFld) <> "Nothing" Then
            If olkFld.DefaultItemType = olAppointmentItem Then
                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) = olkFld.FolderPath
                        excWks.Cells(lngRow, 2) = olkApt.Categories
                        excWks.Cells(lngRow, 3) = olkApt.Subject
                        excWks.Cells(lngRow, 4) = Format(olkApt.Start, "mm/dd/yyyy")
                        excWks.Cells(lngRow, 5) = Format(olkApt.End, "mm/dd/yyyy")
                        excWks.Cells(lngRow, 6) = Format(olkApt.Start, "hh:nn ampm")
                        excWks.Cells(lngRow, 7) = Format(olkApt.End, "hh:nn ampm")
                        excWks.Cells(lngRow, 8) = DateDiff("n", olkApt.Start, olkApt.End) / 60
                        excWks.Cells(lngRow, 8).NumberFormat = "0.00"
                        excWks.Cells(lngRow, 9) = strLst
                        lngRow = lngRow + 1
                        lngCnt = lngCnt + 1
                    End If
                Next
            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
        Else
            MsgBox "I could not find a folder named " & varCal & ".  Folder skipped.  I will continue processing the remaining folders.", vbExclamation + vbOKOnly, SCRIPT_NAME
        End If
    Next
    excWks.Columns("A:I").AutoFit
    excWks.Range("A1:I" & lngRow - 1).Sort Key1:="Category", Order1:=xlAscending, Header:=xlYes
    excWks.Cells(lngRow, 8) = "=sum(H2:H" & lngRow - 1 & ")"
    excWkb.SaveAs EXCEL_FILE
    excWkb.Close
    MsgBox "Process complete.  I exported a total of " & lngCnt & " appointments were exported.", vbInformation + vbOKOnly, SCRIPT_NAME
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    Set olkApt = Nothing
    Set olkLst = Nothing
    Set olkFld = Nothing
End Sub
 
Private Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
    ' Purpose: Opens an Outlook folder from a folder path.
    ' Written: 29/10/2015
    ' Author:  Cameron Rutherford
    ' Outlook: All versions
    Dim arrFolders As Variant, _
        varFolder As Variant, _
        bolBeyondRoot As Boolean
    On Error Resume Next
    If strFolderPath = "" Then
        Set OpenOutlookFolder = Nothing
    Else
        Do While Left(strFolderPath, 1) = "\"
            strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
        Loop
        arrFolders = Split(strFolderPath, "\")
        For Each varFolder In arrFolders
            Select Case bolBeyondRoot
                Case False
                    Set OpenOutlookFolder = Outlook.Session.Folders(varFolder)
                    bolBeyondRoot = True
                Case True
                    Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
            End Select
            If Err.Number <> 0 Then
                Set OpenOutlookFolder = Nothing
                Exit For
            End If
        Next
    End If
    On Error GoTo 0
End Function

谢谢，

Thanks,

Cam

推荐答案

Hello Cameron，

Hello Cameron,

你需要使用
GetSharedDefaultFolder Namespace类的方法，其中r eturns a   文件夹  对象
表示重复找到指定用户的指定默认文件夹。 此方法用于委派方案，其中一个用户为一个或多个默认文件夹委派了另一个用户的访问权限（例如，他们的共享  日历   文件夹）。
例如：

You need to use the GetSharedDefaultFolder method of the Namespace class which returns a Folder object that represents the specified default folder for the specified user. This method is used in a delegation scenario, where one user has delegated access to another user for one or more of their default folders (for example, their shared Calendar folder). For example:

Sub ResolveName()  
 Dim myNamespace As Outlook.NameSpace  
 Dim myRecipient As Outlook.Recipient  
 Dim CalendarFolder As Outlook.Folder 
 Set myNamespace = Application.GetNamespace("MAPI")  
 Set myRecipient = myNamespace.CreateRecipient("Eugene Astafiev")
 myRecipient.Resolve 
 If myRecipient.Resolved Then 
  Call ShowCalendar(myNamespace, myRecipient) 
 End If 
End Sub 
 
Sub ShowCalendar(myNamespace, myRecipient)  
 Dim CalendarFolder As Outlook.Folder 
 Set CalendarFolder = _ 
 myNamespace.GetSharedDefaultFolder(myRecipient, olFolderCalendar) 
 CalendarFolder.Display  
End Sub

这篇关于将Outlook 2010日历导出到Excel 2010 - 代码无法正常工作的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！