Экспорт календаря изо дня в день в Excel VBA - PullRequest
Новая
       22

Экспорт календаря изо дня в день в Excel VBA

0 голосов
/ 04 июня 2019

Ниже кода, который я написал и получил вывод между датой начала и датой окончания, но я хочу, чтобы все встречи были на день, который ранее запланирован, а не между указанной датой начала и датой окончания.

Option Explicit


Sub ListAppointments()
    Dim olApp As Object
    Dim olNS As Object
    Dim olFolder As Object
    Dim olApt As Object
    Dim NextRow As Long
    Dim FromDate As Date
    Dim ToDate As Date

    'FromDate = CDate("08/25/2017")
    'ToDate = CDate("12/31/2017")

    FromDate = Format(InputBox("Enter Start Date(dd/mm/yyyy)", , Date), "dd/mm/yyyy")
    ToDate = Format(InputBox("Enter Start Date(dd/mm/yyyy)", , DateAdd("d", 7, Date)), "dd/mm/yyyy")

    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
    NextRow = 2

    With Sheets("Sheet1") 'Change the name of the sheet here
        .Range("A1:D1").Value = Array("Project", "StartDate", "EndDate", "Time spent", "Location")
        For Each olApt In olFolder.Items
            If (olApt.Start >= FromDate And olApt.End <= ToDate) Then
                .Cells(NextRow, "A").Value = olApt.Subject
                .Cells(NextRow, "B").Value = CDate(olApt.Start)
                .Cells(NextRow, "C").Value = CDate(olApt.End)
                .Cells(NextRow, "D").Value = olApt.End - olApt.Start
                .Cells(NextRow, "D").NumberFormat = "HH:MM:SS"
                .Cells(NextRow, "E").Value = olApt.Location
                .Cells(NextRow, "F").Value = olApt.Categories
                NextRow = NextRow + 1
            Else
            End If
        Next olApt
        .Columns.AutoFit
    End With

    Set olApt = Nothing
    Set olFolder = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
End Sub

Я хочу, чтобы изо дня в день все данные встречи.если встреча запланирована ранее.

...