Outlook中的每周/每月时间报告针对多个类别

Question

我想提取Outlook日历中用于不同类别的时间（每周和每月）以提取报告。

我发现了这段代码，我试图以此为目标，以便在excel工作表中汇总整个日历的信息：

Sub ExportTimeSpentOnAppointmentsInEachColorCategory()
    Dim objDictionary As Object
    Dim objAppointments As Outlook.Items
    Dim objAppointment As Outlook.AppointmentItem
    Dim strCategory As String
    Dim arrCategory As Variant
    Dim varCategory As Variant
    Dim objExcelApp As Excel.Application
    Dim objExcelWorkbook As Excel.Workbook
    Dim objExcelWorksheet As Excel.Worksheet
    Dim arrKey As Variant
    Dim arrItem As Variant
    Dim i As Long
    Dim nLastRow As Integer

    Set objDictionary = CreateObject("Scripting.Dictionary")
    Set objAppointments = Application.Session.PickFolder.Items

    For Each objAppointment In objAppointments
        arrCategory = Split(objAppointment.Categories, ",")
        For Each varCategory In arrCategory
            strCategory = Trim(varCategory)
            If objDictionary.Exists(strCategory) Then
               objDictionary.Item(strCategory) = objDictionary.Item(strCategory) + objAppointment.Duration
            Else
               objDictionary.Add strCategory, objAppointment.Duration
            End If
        Next
    Next

    'Create a new Excel workbook
    Set objExcelApp = CreateObject("Excel.Application")
    Set objExcelWorkbook = objExcelApp.Workbooks.Add
    Set objExcelWorksheet = objExcelWorkbook.Sheets(1)
    objExcelApp.Visible = True
    objExcelWorkbook.Activate

    With objExcelWorksheet
         .Cells(1, 1) = "Color Category"
         .Cells(1, 1).Font.Bold = True
         .Cells(1, 1).Font.Size = 14
         .Cells(1, 2) = "Total Time (min)"
         .Cells(1, 2).Font.Bold = True
         .Cells(1, 2).Font.Size = 14
    End With

    arrKey = objDictionary.Keys
    arrItem = objDictionary.Items

    For i = LBound(arrKey) To UBound(arrKey)
        nLastRow = objExcelWorksheet.Range("A" & objExcelWorksheet.Rows.count).End(xlUp).Row + 1

        objExcelWorksheet.Cells(nLastRow, 1) = arrKey(i)
        objExcelWorksheet.Cells(nLastRow, 2) = arrItem(i)
    Next

    objExcelWorksheet.Columns("A:B").AutoFit
End Sub

如何修改此代码以生成给定一周或一个月（例如2020年1月）的报告。

Answer 1

如果您不知道从哪里开始问题，那么搜索可能包含相关代码的代码块可能是一个不错的开始。但是您需要挖掘该代码以获取有用的块。简单地尝试使该代码适应您的问题将不会起作用，也不会要求其他人对其进行适应。

您需要知道什么？我的初始列表是：

1. 如何找到我要分析的期间的日历项目？
2. 如何按类别对那些日历项目进行排序？
3. 如何创建新的Excel工作簿或如何更新现有的工作簿？
4. 我如何以有用的方式在工作簿中安排信息？

这不是完整的列表。例如：用户如何指定所需的日期范围？在调查更困难的问题时，我不会担心此类问题。您的代码与需求2有关，因此我将专注于需求1。

如果日历上有任何不错的Outlook VBA教程，则找不到它们。我所知道的一切都是实验的结果。

我将来会创建一些约会，因此它们不会与我的真实约会混淆。我使用了“创建约会”中所有感兴趣的选项。我创建了同一天中不同时期的单一约会，即全天活动，约会从一天开始，到另一天结束。我为每个可用周期创建了周期性条目，对于固定次数的出现，直到给定日期或永远。然后，我更改或删除了单个出现。

我从约会项目的对象模型开始。我编写了一个例程，循环了我的约会项，输出了看起来很有趣的属性。我了解了约会项目的不同类型，以及哪些属性与哪种类型一起使用。下面的例程是我实验的结果。

我了解到的第一件事是我的日历不在我期望的位置。此例程有助于解决该问题：

Sub CalendarDtls()

  Dim InxFldrCrnt As Long
  Dim InxStoreCrnt As Long

  With Application.Session
    Debug.Print "Store containing default calendar: " & .GetDefaultFolder(olFolderCalendar).Parent.Name
    Debug.Print "Name of default calendar: " & .GetDefaultFolder(olFolderCalendar).Name
    Debug.Print "Items in default calendar: " & .GetDefaultFolder(olFolderCalendar).Items.Count

    For InxStoreCrnt = 1 To .Folders.Count
      With .Folders(InxStoreCrnt)
        For InxFldrCrnt = 1 To .Folders.Count
          If LCase(Left$(.Folders(InxFldrCrnt).Name, 8)) = "calendar" Then
            Debug.Print .Name & "\" & .Folders(InxFldrCrnt).Name & "  Items: " & _
                        .Folders(InxFldrCrnt).Items.Count
            Exit For
          End If
        Next
      End With
    Next
  End With

End Sub

上面是一个Outlook宏，它显示默认日历及其可以找到的每个日历的详细信息。

[当我开始编写Outlook宏时，我很快了解到宏的数量可以增长多快，以及如何找到今天想要查看的宏有多困难。我有很多名称有意义的模块。我的日历实验在ModCalendar模块中。 （使用F4来访问“属性窗口”以重命名模块。）ModCalendar中没有操作代码。操作代码保存在名称类似于ModTaskName的模块中。我建议您做类似的事情，并将上面的宏和下一个宏放在名为ModCalendar的模块中或类似的东西。不要忘记将Option Explicit作为第一条语句。

现在考虑此宏：

Sub DspCalendarItems()

  ' Create programmer-friendly list of items in selected calendar
  ' in desktop file Appointments.txt.
  'Developed as aid to understanding Outlook calendars.

  Dim ItemCrnt As Object
  Dim ItemCrntClass As Long
  Dim FileOut As Object
  Dim FolderSrc As MAPIFolder
  Dim Fso As FileSystemObject
  Dim Path As String
  Dim RecurrPattCrnt As RecurrencePattern

  Path = CreateObject("WScript.Shell").specialfolders("Desktop")

  Set Fso = CreateObject("Scripting.FileSystemObject")
  Set FileOut = Fso.CreateTextFile(Path & "\Appointments.txt", True)

  With Application.Session

    'Set FolderSrc = .GetDefaultFolder(olFolderCalendar)
    Set FolderSrc = .Folders("Outlook Data File").Folders("Calendar")
    FileOut.WriteLine ("Number of items: " & FolderSrc.Items.Count)

    For Each ItemCrnt In FolderSrc.Items

      With ItemCrnt

        ' Occasionally I get syncronisation
        ' errors.  This code avoids them.
        ItemCrntClass = 0
        On Error Resume Next
        ItemCrntClass = .Class
        On Error GoTo 0

        ' I have never found anything but appointments in
        ' Calendar but test just in case
        If ItemCrntClass = olAppointment Then

          Select Case .RecurrenceState
            Case olApptException
              FileOut.WriteLine ("Recurrence state is Exception")
              If .AllDayEvent Then
                FileOut.WriteLine ("All day " & Format(.Start, "ddd d mmm yy"))
                Debug.Assert False
              ElseIf Day(.Start) = Day(.End) Then
                ' Appointment starts and finishes on same day
                If Format(.Start, "hh:mm") <> Format(.End, "hh:mm") Then
                  ' Different start and end times on same day
                  FileOut.Write ("From " & Format(.Start, "hh:mm") & " to " & _
                                           Format(.End, "hh:mm") & " on " & Format(.Start, "ddd d mmm yy"))
                  Debug.Assert False
                Else
                  ' Start and end time the same
                  Debug.Assert False
                  FileOut.Write ("At " & Format(.Start, "hh:mm") & " on " & Format(.Start, "ddd d mmm yy"))
                End If
              Else
                ' Different start and end dates.
                FileOut.Write ("From " & Format(.Start, "hh:mm") & " on " & Format(.Start, "ddd d mmm yy") & " to " & _
                                         Format(.End, "hh:mm") & " on " & Format(.End, "ddd d mmm yy"))
              End If
              Debug.Assert False
            Case olApptMaster
              Set RecurrPattCrnt = .GetRecurrencePattern
              Debug.Assert Year(RecurrPattCrnt.PatternStartDate) = Year(.Start)
              Debug.Assert Month(RecurrPattCrnt.PatternStartDate) = Month(.Start)
              Debug.Assert Day(RecurrPattCrnt.PatternStartDate) = Day(.Start)
              If .AllDayEvent Then
                FileOut.Write ("All day ")
              ElseIf Day(.Start) = Day(.End) Then
                'Debug.Assert False
                ' Appointment starts and finishes on same day
                If Format(.Start, "hh:mm") <> Format(.End, "hh:mm") Then
                  ' Different start and end times on same day
                  FileOut.Write ("From " & Format(.Start, "hh:mm") & " to " & _
                                           Format(.End, "hh:mm") & " ")
                  'Debug.Assert False
                Else
                  ' Start and end time the same
                  FileOut.Write ("At " & Format(.Start, "hh:mm") & " ")
                  Debug.Assert False
                End If
              ElseIf DateDiff("d", .Start, .End) = 1 And Format(.Start, "hh:mm") = "00:00" And _
                                                         Format(.End, "hh:mm") = "00:00" Then
                FileOut.Write ("All day ")
                'Debug.Assert False
              Else
                ' Have not thought repeating multi-day appointments through
                Debug.Assert False
                FileOut.Write ("XXX From " & Format(.Start, "hh:mm") & " on " & Format(.Start, "ddd d mmm yy") & " to " & _
                                         Format(.End, "hh:mm") & " on " & Format(.End, "ddd d mmm yy"))
              End If
              Select Case RecurrPattCrnt.RecurrenceType
                Case olRecursDaily
                  'Debug.Assert False
                  FileOut.Write ("daily")
                Case olRecursMonthly
                  Debug.Assert False
                  FileOut.Write ("monthly")
                Case olRecursMonthNth
                  Debug.Assert False
                  FileOut.Write ("nth monthly")
                Case olRecursWeekly
                  'Debug.Assert False
                  FileOut.Write ("weekly")
                Case olRecursYearly
                  'Debug.Assert False
                  FileOut.Write ("yearly")
              End Select  ' RecurrPattCrnt.RecurrenceType
              FileOut.Write (" from " & Format(RecurrPattCrnt.PatternStartDate, "ddd d mmm yy"))
              If Year(RecurrPattCrnt.PatternEndDate) = 4500 Then
                ' For ever
                'Debug.Assert False
              Else
                FileOut.Write (" to " & Format(RecurrPattCrnt.PatternEndDate, "ddd d mmm yy"))
                'Debug.Assert False
              End If
            Case olApptNotRecurring
              If .AllDayEvent Then
                FileOut.Write ("All day " & Format(.Start, "ddd d mmm yy"))
                'Debug.Assert False
              ElseIf Day(.Start) = Day(.End) Then
                ' Appointment starts and finishes on same day
                If Format(.Start, "hh:mm") <> Format(.End, "hh:mm") Then
                  ' Different start and end times on same day
                  FileOut.Write ("From " & Format(.Start, "hh:mm") & " to " & _
                                           Format(.End, "hh:mm") & " on " & Format(.Start, "ddd d mmm yy"))
                  'Debug.Assert False
                Else
                  ' Start and end time the same
                  FileOut.Write ("At " & Format(.Start, "hh:mm") & " on " & Format(.Start, "ddd d mmm yy"))
                  'Debug.Assert False
                End If
              Else
                ' Different start and end dates.
                FileOut.Write ("From " & Format(.Start, "hh:mm") & " on " & Format(.Start, "ddd d mmm yy") & " to " & _
                                         Format(.End, "hh:mm") & " on " & Format(.End, "ddd d mmm yy"))
                'Debug.Assert False
              End If
            Case olApptOccurrence
              FileOut.WriteLine ("Occurrence")
              Debug.Assert False
            Case Else
              Debug.Print ("Unknown recurrence state " & .RecurrenceState)
              Debug.Assert False
              FileOut.WriteLine ("Unknown recurrence state " & .RecurrenceState)
          End Select  ' .RecurrenceState
          If .Subject <> "" Then
            FileOut.Write ("  " & .Subject)
          Else
            FileOut.Write ("  ""No subject""")
          End If
          If .Location <> "" Then
            FileOut.Write (" at " & .Location)
          Else
            FileOut.Write (" at undefined location")
          End If
          FileOut.WriteLine ("")
          If .Body <> "" Then
            FileOut.WriteLine ("  Body: " & .Body)
          End If

        End If ' ItemCrntClass = olAppointment

      End With  ' ItemCrnt

    Next ItemCrnt

  End With  ' Application.Session

  FileOut.Close

End Sub

在上述宏的顶部附近，您将找到：

'Set FolderSrc = .GetDefaultFolder(olFolderCalendar)
Set FolderSrc = .Folders("Outlook Data File").Folders("Calendar")

如果约会位于默认日历中，请从第一行中删除引号，然后在第二行中添加引号。如果您的约会不在默认日历中，则CalendarDtls()将显示以下内容：

Store containing default calendar: [email protected]
Name of default calendar: Calendar (This computer only)
Items in default calendar: 0
[email protected] @virginmedia.com\Calendar (This computer only)  Items: 0
Outlook Data File\Calendar  Items: 180

[为Items查找具有非零值的行，并将商店名称（对我来说是Outlook Data File）和文件夹名称（对我来说是日历）复制到第二行。

运行此宏并研究输出。它从哪里获得显示的值？大多数约会项目具有相同的属性，但是对于不合适的项目，这些属性将没有明智的价值。宏如何决定要显示的属性和不显示的属性？添加类别显示。我对类别不感兴趣，因此宏不会显示它们。

此宏是基本的。它不涉及异常之类的复杂问题。我相信这将是了解如何确定报告期内的任命的良好起点。

我在我要分享的下一个宏中发现了一个错误。修复错误后，我将添加此宏。