Outlook 2010共享日历导出 [英] Outlook 2010 Shared Calendar Export
本文介绍了Outlook 2010共享日历导出的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！
问题描述
我有以下代码，它将导出我自己的日历 - 我如何指定其他共享日历我想导出到同一个文件？
I have the below code, which will export my own calendar - how do i specify the other shared calendars i want to export to the same file?
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 = "tul0crf@123.com\Calendar"
'On the next line, edit the path to and name of the Excel spreadsheet to export to
Const EXCEL_FILE = "\\ketpddsc01\users\tul0crf\Tester.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: 4/24/2009
' Author: David Lee
' 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谢谢，
Cam
推荐答案
Hello Cameron，
Hello Cameron,
您可以使用
GetSharedDefaultFolder Namespace类的方法，以获取 a 文件夹 object
表示sp的指定默认文件夹有效的用户。 此方法用于委派方案，其中一个用户为一个或多个默认文件夹委派了另一个用户的访问权限（例如，他们的共享 日历 &NBSP; 文件夹）。
例如：
You can use the GetSharedDefaultFolder method of the Namespace class to get 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共享日历导出的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
查看全文
