下面的代码愉快地填写了一周的任命的电子邮件,但它通过约会创建日期而不是实际约会列出电子邮件中的日历项目日期。有没有办法按预约日期列出项目? 我对任何帮助或建议表示感谢。 编码到电子邮件的日历项目按创建日期排序 - 需要按预约日期排序
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
完美地工作。您的意见帮助我掌握阵列。非常感谢你。 – JEK
很高兴能有所帮助。祝你未来的节目顺利。如果你接受我的回答,我将不胜感激。 –