简体   繁体   English

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

[英]Export outlook calendar meeting and appointment for today's date

See the below code.请参阅下面的代码。 I can't get the code for today's date and calendar appointments.我无法获取今天日期和日历约会的代码。

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

You can use restrict items by today's date.您可以在今天的日期之前使用限制项目。 The calendar folder is trickier than mail folders.日历文件夹比邮件文件夹更棘手。

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

You can get today appointments from outlook try if(olkAppt.Start==DateTime.Now.Date)您可以从 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

You can set any appointments you want, via Excel, using the script below.您可以使用以下脚本通过 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

The setup looks like this .设置看起来像这样。 . . . .

在此处输入图片说明

声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM