出口展望日曆會議和約會今天的日期

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

您可以使用下面的腳本通過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 

設置看起來像這樣。 。 。

Answer 2

您可以使用限制通過今天的日期的項目。日曆文件夾比郵件文件夾更復雜。

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