2012-01-26 102 views
1

下面的代码愉快地填写了一周的任命的电子邮件,但它通过约会创建日期而不是实际约会列出电子邮件中的日历项目日期。有没有办法按预约日期列出项目? 我对任何帮助或建议表示感谢。 编码到电子邮件的日历项目按创建日期排序 - 需要按预约日期排序

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 

回答

0

我没有审查(我不能居功这个代码,我贴在网上能找到拼在一起。我比与Outlook更熟悉Excel和Access VBA。再次感谢。)约翰·您现有的代码虽然我确实发现了:

  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 

我希望我已经包含了足够的注释所以这都有道理。回来的问题是必要的。

+0

完美地工作。您的意见帮助我掌握阵列。非常感谢你。 – JEK

+0

很高兴能有所帮助。祝你未来的节目顺利。如果你接受我的回答,我将不胜感激。 –