在Outlook中,我想要一个VBA脚本,它将在一天内完成所有约会,并按类别计算总时数。
答案 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