Календарь Элементы, закодированные по электронной почте, отсортированы по дате создания - необходимо отсортировать по дате встречи

Question

Приведенный ниже код успешно заполняет электронное письмо назначениями на неделю, но в нем перечислены элементы календаря в электронном письме по дате создания встречи, а не по фактической дате встречи.Есть ли способ перечислить предметы по дате встречи?Мое скромное спасибо за любую помощь или предложения.(Я не могу взять кредит на этот код, так как я собрал воедино фрагменты, найденные в сети. Я больше знаком с Excel и Access VBA, чем с Outlook. Еще раз спасибо.) Джон

Public Sub ListAppointments()
    On Error GoTo On_Error

    Dim Session As Outlook.NameSpace
    Dim Report As String
    Dim AppointmentsFolder As Outlook.Folder
    Dim currentItem As Object
    Dim currentAppointment As AppointmentItem
    Set Session = Application.Session

    Set AppointmentsFolder = Session.GetDefaultFolder(olFolderCalendar)

    For Each currentItem In AppointmentsFolder.Items
        If (currentItem.Class = olAppointment) Then
            Set currentAppointment = currentItem
            'get the week's appointments
        If currentAppointment.Start >= Now() And currentAppointment.Start <= Now() + 7 Then
                    If currentAppointment.AllDayEvent = False Then 'exclude all day events

               Call AddToReportIfNotBlank(Report, "Subject", currentAppointment.Subject)
               Call AddToReportIfNotBlank(Report, "Start", currentAppointment.Start)
               Call AddToReportIfNotBlank(Report, "End", currentAppointment.End)
               Call AddToReportIfNotBlank(Report, "Location", currentAppointment.Location)
               Report = Report & "-----------------------------------------------------"
               Report = Report & vbCrLf & vbCrLf

                    End If
                End If
        End If

    Next

    Call CreateReportAsEmail("List of Appointments", Report)

Exiting:
        Exit Sub
On_Error:
    MsgBox "error=" & Err.Number & " " & Err.Description
    Resume Exiting

End Sub

Private Function AddToReportIfNotBlank(Report As String, FieldName As String, FieldValue)
    AddToReportIfNotBlank = ""
    If (IsNull(FieldValue) Or FieldValue <> "") Then
        AddToReportIfNotBlank = FieldName & " : " & FieldValue & vbCrLf
        Report = Report & AddToReportIfNotBlank
    End If

End Function

'publish items to Outlook email
Public Sub CreateReportAsEmail(Title As String, Report As String)
    On Error GoTo On_Error

    Dim objNS As Outlook.NameSpace
    Dim objItem  As MailItem
    Dim objFolder As MAPIFolder

    Set objNS = Application.GetNamespace("MAPI") 'Application.Session
    Set objItem = Application.CreateItem(olMailItem)
    Set objFolder = objNS.GetDefaultFolder(olFolderInbox)

    With objItem
        .Subject = "This weeks appointments"
        .Body = Report
        .Display
    End With

Exiting:
        'Set Session = Nothing
        Exit Sub
On_Error:
    'MsgBox "error=" & Err.Number & " " & Err.Description
    Resume Exiting

End Sub

Answer 1

Я не проверял ваш существующий код, хотя и заметил:

1. Если бы вы составили список моих встреч и пропустили мои дневные встречи, я был бы серьезно недоволен.
2. AddToReportIfNotBlank не является функцией, поскольку она не возвращает значение.

С моим решением вы не добавляете встречи в Report по мере их обнаружения.Вместо этого они добавляются в массив структур.Как только все соответствующие встречи найдены, создается массив индексов в массиве структур, который сортируется по дате встречи.Затем отчет строится из массива структур в индексной последовательности.Я надеюсь, что в этом есть смысл.Дополнительные детали в коде.

Мое решение требует структуры.Определение типа должно быть помещено перед любой подпрограммой или функцией.

Type typAppointment
  Start As Date
  AllDay As Boolean
  End As Date
  Subject As String
  Location As String
End Type

Мне нужны эти переменные в дополнение к вашей:

  Dim AppointmentDtl() As typAppointment
  Dim InxADCrnt As Long
  Dim InxADCrntMax As Long
  Dim InxAppointmentSorted() As Long
  Dim InxSrtCrnt1 As Long
  Dim InxSrtCrnt2 As Long
  Dim Stg as String

Этот код подготавливает массив структур для использования.Поместите перед циклом, который ищет встречи:

  ReDim AppointmentDtl(1 To 100)
  ' * I avoid having too many ReDim Preserves because they
  '   involve creating a copy of the original array.
  ' * 100 appointments should be enough but the array will
  '   be resized if necessary.
  InxADCrntMax = 0      ' The current last used entry in AppointmentDtl

Удалите ваш код:

        Call AddToReportIfNotBlank(Report, "Subject", currentAppointment.Subject)
        Call AddToReportIfNotBlank(Report, "Start", currentAppointment.Start)
        Call AddToReportIfNotBlank(Report, "End", currentAppointment.End)
        Call AddToReportIfNotBlank(Report, "Location", currentAppointment.Location)
        Report = Report & "-----------------------------------------------------"
        Report = Report & vbCrLf & vbCrLf

и замените его следующим, который сохраняет детали выбранных встреч в структуре.Этот код обрабатывает дневные и неполные собрания:

        InxADCrntMax = InxADCrntMax + 1
        If InxADCrntMax > UBound(AppointmentDtl) Then
          ' Have filled array.  Add another 100 entries
          ReDim Preserve AppointmentDtl(1 To 100 + UBound(AppointmentDtl))
        End If
        AppointmentDtl(InxADCrntMax).Start = .Start
        If .AllDayEvent Then
          AppointmentDtl(InxADCrntMax).AllDay = True
        Else
          AppointmentDtl(InxADCrntMax).AllDay = False
          AppointmentDtl(InxADCrntMax).End = .End
        End If
        AppointmentDtl(InxADCrntMax).Subject = .Subject
        AppointmentDtl(InxADCrntMax).Location = .Location
      End If

Выше Call CreateReportAsEmail("List of Appointments", Report) вставка:

  ' Initialise index array as 1, 2, 3, 4, ...
  ReDim InxAppointmentSorted(1 To InxADCrntMax)
  For InxSrtCrnt1 = 1 To InxADCrntMax
    InxAppointmentSorted(InxSrtCrnt1) = InxSrtCrnt1
  Next

  ' Sort index array by AppointmentDtl(xxx).Start.
  ' This is not an efficient sort but it should be sufficient for your purposes.
  ' If not, I have a Shell Sort written in VBA although a Quick Sort
  ' is considered the best.
  InxADCrnt = 1
  Do While InxADCrnt < InxADCrntMax
    InxSrtCrnt1 = InxAppointmentSorted(InxADCrnt)
    InxSrtCrnt2 = InxAppointmentSorted(InxADCrnt + 1)
    If AppointmentDtl(InxSrtCrnt1).Start > AppointmentDtl(InxSrtCrnt2).Start Then
      InxAppointmentSorted(InxADCrnt) = InxSrtCrnt2
      InxAppointmentSorted(InxADCrnt + 1) = InxSrtCrnt1
      If InxADCrnt > 1 Then
        InxADCrnt = InxADCrnt - 1
      Else
        InxADCrnt = InxADCrnt + 1
      End If
    Else
      InxADCrnt = InxADCrnt + 1
    End If
  Loop

  ' InxAppointmentSorted() is now: 5, 20, 2, ... where appointment 5 is
  ' the earliest, appointment 20 the next and so on

  ' Process appointments in Start order
  For InxSrtCrnt1 = 1 To InxADCrntMax
    InxADCrnt = InxAppointmentSorted(InxSrtCrnt1)
    With AppointmentDtl(InxADCrnt)
      ' I have tested all other code on my calendar.  This code is untested.
      ' I have included all day meetings but you could easily restore the
      ' original approach.
      Call AddToReportIfNotBlank(Report, "Subject", .Subject)
      If .AllDay Then
        Stg = "All day " & Format(.Start, "dddd d mmm")
      Else
        ' Date formatted as "Friday 27 Jan". Use "dddd mmmm, d" if you
        ' prefer "Friday January, 27".  That is: "d" gives day of month
        ' with leading zero omitted. "dddd" gives full day of week. "mmm"
        ' gives three letter month.  "mmmm" gives full month.  "yy", if
        ' required, give two day year. "yyyy" gives four day year. Include
        ' spaces and punctuation as desired. 
        Stg = Format(.Start, "dddd d mmm") & _
              Format(.Start, " hh:mm") & " to " & _
              Format(.End, "hh:mm")
      End If
      Call AddToReportIfNotBlank(Report, "When", Stg)
      Call AddToReportIfNotBlank(Report, "Location", .Location)
      Report = Report & "-----------------------------------------------------"
      Report = Report & vbCrLf & vbCrLf
    End With
  Next

Надеюсь, я включил достаточно комментариев, так что все это имеет смысл.Вернись с вопросами необходимо.