将Outlook日历数据导出到Excel文件 - 共享日历和VBA [英] Exporting Outlook calendar data to Excel file - Shared calendars and VBA

问题描述

我正在尝试将一些数据从Outlook导出到Excel。任务是分析所有共享的日历，并找出用户何时休假。

I'm trying to export some data from Outlook to Excel. The task is to analyze all the shared calendar and find out when an user is going on vacation.

所有的人都会预约位置假期，而一天每天运行该脚本的结果将是一个Excel表格，其中包含Employee - 开始 - 结束行，这意味着员工从何时到何时休假。

All the people would put an appointment with location "vacation" and, day by day, running the script the result would be an excel sheet with rows like "Employee - Start - End" with meaning employee who is in vacation from when to when.

我设法适应互联网上发现的一个脚本。它工作，但只有我的本地日历。

I managed to adapt a script found on internet. It works but only with my local calendar. How could I adapt this script again in order to scan all the shared calendars? Here is the code:

Private Sub Test_Click()
Call GetCalData("16/06/2015", "28/06/2015")
InputBox("Data inizio")
End Sub


Private Sub GetCalData(StartDate As Date, Optional EndDate As Date)
' -------------------------------------------------
' Notes:
' If Outlook is not open, it still works, but much slower (~8 secs vs. 2 secs w/ Outlook open).
' Make sure to reference the Outlook object library before running the code
' End Date is optional, if you want to pull from only one day, use: Call GetCalData("7/14/2008")
' -------------------------------------------------
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim myCalItems As Outlook.Items
Dim ItemstoCheck As Outlook.Items
Dim ThisAppt As Outlook.AppointmentItem
Dim MyItem As Object
Dim StringToCheck As String
Dim MyBook As Excel.Workbook
Dim rngStart As Excel.Range
Dim i As Long
Dim NextRow As Long
' if no end date was specified, then the requestor only wants one day, so set EndDate = StartDate
' this will let us return appts from multiple dates, if the requestor does in fact set an appropriate end date
If EndDate = "12:00:00 AM" Then
  EndDate = StartDate
End If
If EndDate < StartDate Then
  MsgBox "Those dates seem switched, please check them and try again.", vbInformation
  GoTo ExitProc
End If
If EndDate - StartDate > 28 Then
  ' ask if the requestor wants so much info
 If MsgBox("This could take some time. Continue anyway?", vbInformation + vbYesNo) = vbNo Then
      GoTo ExitProc
  End If
End If
' get or create Outlook object and make sure it exists before continuing
On Error Resume Next
  Set olApp = GetObject(, "Outlook.Application")
  If Err.Number <> 0 Then
    Set olApp = CreateObject("Outlook.Application")
  End If
On Error GoTo 0
If olApp Is Nothing Then
  MsgBox "Cannot start Outlook.", vbExclamation
  GoTo ExitProc
End If
Set olNS = olApp.GetNamespace("MAPI")
Set myCalItems = olNS.GetDefaultFolder(olFolderCalendar).Items

' ------------------------------------------------------------------
' the following code adapted from:
' http://www.outlookcode.com/article.aspx?id=30
'
With myCalItems
  .Sort "[Start]", False
  .IncludeRecurrences = True
End With
'
StringToCheck = "[Start] >= " & Quote(StartDate & " 12:00 AM") & " AND [End] <= " & _
  Quote(EndDate & " 11:59 PM")
Debug.Print StringToCheck
'
Set ItemstoCheck = myCalItems.Restrict(StringToCheck)
Debug.Print ItemstoCheck.Count
' ------------------------------------------------------------------
If ItemstoCheck.Count > 0 Then
  ' we found at least one appt
 ' check if there are actually any items in the collection, otherwise exit
 If ItemstoCheck.Item(1) Is Nothing Then GoTo ExitProc
  Set MyBook = ThisWorkbook
  Set rngStart = ThisWorkbook.Sheets(1).Range("A1")
  With rngStart
    .Offset(0, 0).Value = "Impiegato"
    .Offset(0, 1).Value = "Data inizio"
    .Offset(0, 2).Value = "Fine"
    .Offset(0, 3).Value = "Location"
 End With
  For Each MyItem In ItemstoCheck
    If MyItem.Class = olAppointment Then
   ' MyItem is the appointment or meeting item we want,
   ' set obj reference to it
     Set ThisAppt = MyItem
     If StrComp(ThisAppt.Location, "vacation") = 0 Then
        NextRow = Range("A" & Rows.Count).End(xlUp).Row
With rngStart
.Offset(NextRow, 0).Value = ThisAppt.Organizer
.Offset(NextRow, 1).Value = ThisAppt.Start
.Offset(NextRow, 2).Value = ThisAppt.End
.Offset(NextRow, 3).Value = ThisAppt.Location
      End With
    End If
   End If
  Next MyItem

  ' make it pretty
 Call Cool_Colors(rngStart)
Else
    MsgBox "There are no appointments or meetings during" & _
      "the time you specified. Exiting now.", vbCritical
End If
ExitProc:
Set myCalItems = Nothing
Set ItemstoCheck = Nothing
Set olNS = Nothing
Set olApp = Nothing
Set rngStart = Nothing
Set ThisAppt = Nothing
End Sub


Private Function Quote(MyText)
' from Sue Mosher's excellent book "Microsoft Outlook Programming"
 Quote = Chr(34) & MyText & Chr(34)
End Function

Private Sub Cool_Colors(rng As Excel.Range)
'
' Lt Blue BG with white letters
'
'
With Range("A18:AE18")
'With Range(rng, rng.End(xlToRight))
  .Font.ColorIndex = 2
  .Font.Bold = True
 '.HorizontalAlignment = xlCenter
 '.MergeCells = False
 '.AutoFilter
 '.CurrentRegion.Columns.AutoFit
  With .Interior
    .ColorIndex = 41
    .Pattern = xlSolid
  End With
End With
End Sub

推荐答案

而不是使用 Namespace.GetDefaultFolder ，调用 Namespace.CreateRecipient传递其他用户的名称，调用 Recipient.Resolve ，然后将其传递给 Namespace.GetSharedDefaultFolder

Instead of using Namespace.GetDefaultFolder, call Namespace.CreateRecipient passing the name of the other user, call Recipient.Resolve, then pass it to Namespace.GetSharedDefaultFolder

这篇关于将Outlook日历数据导出到Excel文件 - 共享日历和VBA的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！