脚本按Outlook中的日历类别计算总小时数

时间:2015-07-09 00:49:16

标签: vba outlook

在Outlook中,我想要一个VBA脚本,它将在一天内完成所有约会,并按类别计算总时数。

1 个答案:

答案 0 :(得分:0)

我想出了以下代码,似乎没问题 -

Sub TotalCategories()

Dim app As New Outlook.Application
Dim namespace As Outlook.namespace
Dim calendar As Outlook.Folder
Dim appt As Outlook.AppointmentItem
Dim apptList As Outlook.Items
Dim apptListFiltered As Outlook.Items
Dim explorer As Outlook.explorer
Dim view As Outlook.view
Dim calView As Outlook.CalendarView
Dim startDate As String
Dim endDate As String
Dim category As String
Dim duration As Integer
Dim outMsg As String

' Access appointment list
Set namespace = app.GetNamespace("MAPI")
Set calendar = namespace.GetDefaultFolder(olFolderCalendar)
Set apptList = calendar.Items

' Include recurring appointments and sort the list
apptList.IncludeRecurrences = True
apptList.Sort "[Start]"

' Get selected date
Set explorer = app.ActiveExplorer()
Set view = explorer.CurrentView()
Set calView = view
startDate = Format(calView.SelectedStartTime, "dd/MM/yyyy") & " 00:01"
endDate = Format(calView.SelectedEndTime, "dd/MM/yyyy") & " 11:59 PM"

' Filter the appointment list
strFilter = "[Start] >= '" & startDate & "'" & " AND [End] <= '" & endDate & "'"
Set apptListFiltered = apptList.Restrict(strFilter)

' Loop through the appointments and total for each category
Set catHours = CreateObject("Scripting.Dictionary")
For Each appt In apptListFiltered
    category = appt.Categories
    duration = appt.duration
    If catHours.Exists(category) Then
        catHours(category) = catHours(category) + duration
    Else
        catHours.Add category, duration
    End If
Next

' Loop through the categories
keyArray = catHours.Keys
For Each key In keyArray
    outMsg = outMsg & key & ": " & (catHours(key) / 60) & vbCrLf & vbCrLf
Next

' Display final message
MsgBox outMsg, , "Category Totals"

' Clean up objects
Set app = Nothing
Set namespace = Nothing
Set calendar = Nothing
Set appt = Nothing
Set apptList = Nothing
Set apptListFiltered = Nothing
Set explorer = Nothing
Set view = Nothing
Set calView = Nothing

End Sub