导出 Outlook 日历会议和今天的约会

Question

请看下面的代码。我无法获取今天的日期和日历约会的代码。

Option Explicit

Private Sub Workbook_Open()
On Error GoTo ErrHand:

    Application.ScreenUpdating = False

    'This is an enumeration value in context of getDefaultSharedFolder
    Const olFolderCalendar As Byte = 9

    Dim olapp       As Object: Set olapp = CreateObject("Outlook.Application")
    Dim olNS        As Object: Set olNS = olapp.GetNamespace("MAPI")
    Dim olfolder    As Object
    Dim olApt       As Object: Set olNS = olapp.GetNamespace("MAPI")
    Dim objOwner    As Object: Set objOwner = olNS.CreateRecipient("s.prabhuboazgnanaraj@asianpaints.com")
    Dim NextRow     As Long
    Dim olmiarr As Object
    Dim ws  As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")


    objOwner.Resolve

    If objOwner.Resolved Then
        Set olfolder = olNS.GetSharedDefaultFolder(objOwner, olFolderCalendar)

    End If
        ws.Range("A1:D1").Value2 = Array("Subject", "Start", "End", "Location")
    'Ensure there at least 1 item to continue
    If olfolder.items.Count = 0 Then Exit Sub

    'Create an array large enough to hold all records
    Dim myArr() As Variant: ReDim myArr(0 To 3, 0 To olfolder.items.Count - 1)

    'Add the records to an array
    'Add this error skip, as I found some of my calendar items don't have all properties e.g. a start time
    On Error Resume Next
    For Each olApt In olfolder.items
        myArr(0, NextRow) = olApt.Subject
        myArr(1, NextRow) = olApt.Start
        myArr(2, NextRow) = olApt.End
        myArr(3, NextRow) = olApt.Location
        NextRow = NextRow + 1
    Next
    On Error GoTo 0

    'Write all records to a worksheet from an array, this is much faster
    ws.Range("A2:D" & NextRow + 1).Value = WorksheetFunction.Transpose(myArr)

    'AutoFit
    ws.Columns.AutoFit

cleanExit:
    Application.ScreenUpdating = True
    Exit Sub

ErrHand:
    'Add error handler
    Resume cleanExit
End Sub

Answer 1

您可以在今天之前使用限制项目。日历文件夹比邮件文件夹更复杂。

Option Explicit

Sub restrictCalendarEntryByDate()

    Dim Counter As Long

    Dim olkItems As Items
    Dim olkSelected As Items
    Dim olkAppt As AppointmentItem

    Dim dateStart
    Dim dateEnd

    Dim StrFilter As String

    dateStart = Date
    dateEnd = Date + 1 ' Note this day will not be in the time period

    'dateStart = "2017-10-30"
    'dateEnd = "2017-10-31" ' Note this day will not be in the time period

    If IsDate(dateStart) And IsDate(dateEnd) Then

        Set olkItems = Session.GetDefaultFolder(olFolderCalendar).Items
        olkItems.IncludeRecurrences = True
        olkItems.Sort "Start"

        StrFilter = "[Start] >= '" & Format(dateStart, "ddddd h:nn AMPM") & "'"
        Debug.Print StrFilter

        Set olkSelected = olkItems.Restrict(StrFilter)

        StrFilter = StrFilter & " AND [Start] < '" & Format(dateEnd, "ddddd h:nn AMPM") & "'"
        Debug.Print StrFilter

        Set olkSelected = olkItems.Restrict(StrFilter)

        For Each olkAppt In olkSelected
            Counter = Counter + 1
            Debug.Print Counter & ":" & olkAppt.Subject & " " & olkAppt.location & olkAppt.start
        Next

    End If

End Sub

Answer 2

您可以从 Outlook 获取今天的约会 try if(olkAppt.Start==DateTime.Now.Date)

For Each olkAppt In olkSelected
 Counter = Counter + 1
 if(olkAppt.Start==DateTime.Now.Date) 
{
            Debug.Print Counter & ":" & olkAppt.Subject & " " & olkAppt.location & olkAppt.start
}
 Next

Answer 3

您可以使用下面的脚本通过 Excel 设置您想要的任何约会。

Sub AddAppointments()
    ' Create the Outlook session
    Set myOutlook = CreateObject("Outlook.Application")

    ' Start at row 2
    r = 2

    Do Until Trim(Cells(r, 1).Value) = ""
        ' Create the AppointmentItem
        Set myApt = myOutlook.CreateItem(1)
        ' Set the appointment properties
        myApt.Subject = Cells(r, 1).Value
        myApt.Location = Cells(r, 2).Value
        myApt.Start = Cells(r, 3).Value
        myApt.Duration = Cells(r, 4).Value
        ' If Busy Status is not specified, default to 2 (Busy)
        If Trim(Cells(r, 5).Value) = "" Then
            myApt.BusyStatus = 2
        Else
            myApt.BusyStatus = Cells(r, 5).Value
        End If
        If Cells(r, 6).Value > 0 Then
            myApt.ReminderSet = True
            myApt.ReminderMinutesBeforeStart = Cells(r, 6).Value
        Else
            myApt.ReminderSet = True
        End If
        myApt.Body = Cells(r, 7).Value
        myApt.Save
        r = r + 1
    Loop
End Sub

设置如下所示。 . .