Itens de calendário codificado para um e-mail são ordenados por data de criação, precisa ordenar por data de compromisso
-
14-11-2019 - |
Pergunta
O código abaixo feliz preenche um e-mail com a semana appoinments mas ele lista os itens de calendário no e-mail, por nomeação data de criação, em vez da data do compromisso.Existe uma maneira de listar os itens por data de compromisso?Meu humilde obrigado por qualquer ajuda ou sugestões.(Eu não posso levar o crédito por este código, como eu colados peças encontradas na net.Eu estou mais familiarizado com o Excel e VBA do Access que com o Outlook.Novamente o meu muito obrigado.) João
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
Solução
Eu não reviu o seu código existente, apesar de que eu fiz lugar:
- Se você criou uma lista de meus compromissos e omitido o meu todos os dias de reuniões, gostaria de ser seriamente indignado.
AddToReportIfNotBlank
não é uma função porque ela não retorna um valor.
Com a minha solução não adicionar compromissos para o Report
como eles são descobertos.Em vez disso, eles são adicionados a uma matriz de estruturas.Uma vez que todas as nomeações foram encontrados, uma matriz de índices para a matriz de estruturas é criada e ordenada por data de compromisso.Relatório e, em seguida, é construído a partir da matriz de estruturas índice de sequência.Espero que isso faz sentido.Detalhe Extra no código.
A minha solução requer uma estrutura.A definição de tipo deve ser colocado antes de qualquer sub-rotinas ou funções.
Type typAppointment
Start As Date
AllDay As Boolean
End As Date
Subject As String
Location As String
End Type
Eu preciso que estas variáveis além do seu:
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
Este código prepara a matriz de estruturas para uso.Antes do loop que olha para compromissos:
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
Excluir o seu código:
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
e substituir com o seguinte, que armazena o detalhe dos selecionados compromissos na estrutura.Este código processa todos os dias de reuniões, bem como parte do dia de reuniões:
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
Acima Call CreateReportAsEmail("List of Appointments", Report)
insira:
' 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
Espero ter incluído o suficiente comentários para que tudo isso faz sentido.Não voltar com as perguntas é necessário.