2017-10-16 8 views
0

Voir le code ci-dessous. Je ne peux pas obtenir le code pour la date d'aujourd'hui et les rendez-vous du calendrier.Réunion sur les perspectives d'exportation et rendez-vous pour la date d'aujourd'hui

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("[email protected]") 
    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 

Répondre

-1

Vous pouvez définir les rendez-vous souhaités via Excel en utilisant le script ci-dessous.

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 

La configuration ressemble à ceci. . .

enter image description here

0

Vous pouvez utiliser limiter les éléments de la date d'aujourd'hui. Le dossier de calendrier est plus délicat que les dossiers de courrier.

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