Question

有人可以帮我吗。我有这段代码，它从日历中读取特定日期的所有约会；但是，该代码在给定日期内不会显示任何重复的会议：

ToDate = CDate("10/12/2019")
FromDate = CDate("10/06/2019")

'On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err.Number > 0 Then Set olApp = CreateObject("Outlook.Application")
On Error GoTo 0

Set olNS = olApp.GetNamespace("MAPI")
Set olFolder = olNS.GetDefaultFolder(9) 'olFolderCalendar

'include reccuring items
'-------------------------
olFolder.Items.Sort ("[Start]")
olFolder.Items.IncludeRecurrences = True

'-------------------------

NextRow = 2

With Sheets("Sheet1") 'Change the name of the sheet here
    .Range("A1:F1").Value = Array("Report Date", "Date", "Time spent", "Location", "Categories", "Title")

    For Each olApt In olFolder.Items

        If (olApt.Start >= FromDate And olApt.Start <= ToDate) Then

            .Cells(NextRow, "A").Value = Format(Now, "DD-MM-YY")
            .Cells(NextRow, "B").Value = CDate(olApt.Start)
            .Cells(NextRow, "C").Value = olApt.End - olApt.Start
             .Cells(NextRow, "C").NumberFormat = "HH:MM"
            .Cells(NextRow, "E").Value = olApt.Categories
            .Cells(NextRow, "F").Value = olApt.Subject
            NextRow = NextRow + 1
        Else
        End If
    Next olApt
    .Columns.AutoFit
End With

有人可以帮帮我，让我知道我做错了吗！!

谢谢！

Answer 1

必须将文件夹中的项目放入集合中，然后才能进行操作。

On Error Resume Next ' This is a rare proper use.
Set olApp = GetObject(, "Outlook.Application")
If Err.Number > 0 Then Set olApp = CreateObject("Outlook.Application")
On Error GoTo 0

Set olNS = olApp.GetNamespace("MAPI")
Set olFolder = olNS.GetDefaultFolder(9) 'olFolderCalendar

Set itmCollection = olFolder.Items

'include recurring items
'-------------------------
itmCollection.Sort ("[Start]")
itmCollection.IncludeRecurrences = True
'-------------------------

For Each olApt In itmCollection

演示代码

Option Explicit

Sub apptsInDateRangeIncludingRecurrences()

Dim ToDate As Date
Dim FromDate As Date

Dim olApp As Object
Dim olNS As Object
Dim olFolder As Object

Dim itmCollection As Object
Dim itmCollectionFrom As Object
Dim itmCollectionFromTo As Object
Dim sFilter As String

Dim olApt As Object

ToDate = CDate("10/12/2019")
FromDate = CDate("10/06/2019")

On Error Resume Next ' This is a rare proper use.
Set olApp = GetObject(, "Outlook.Application")
If Err.Number > 0 Then Set olApp = CreateObject("Outlook.Application")
On Error GoTo 0

Set olNS = olApp.GetNamespace("MAPI")
Set olFolder = olNS.GetDefaultFolder(9) 'olFolderCalendar

Set itmCollection = olFolder.Items

'include recurring items
'-------------------------
itmCollection.Sort ("[Start]")
itmCollection.IncludeRecurrences = True
'-------------------------

'Filter for applicable items
sFilter = "[Start]>='" & FromDate & "'"
'Debug.Print sFilter
Set itmCollectionFrom = itmCollection.Restrict(sFilter)

sFilter = "[Start]<='" & ToDate & "'"
'Debug.Print sFilter
Set itmCollectionFromTo = itmCollectionFrom.Restrict(sFilter)

For Each olApt In itmCollectionFromTo
    If olApt.Start >= FromDate Then
        Debug.Print olApt.Start & " " & olApt.Subject
    End If
Next olApt

Debug.Print "Done."

End Sub

获取定期约会VBA

1 个答案: