VBA Excel import appointment des calendriers partagés outlook

J'obtiens "-calendrier" sans avoir le nom du calendrier du propriétaire du calendrier partagé.

Vous pouvez essayer de modifier cette instruction :

ref_calendrier = calendrier.Parent.Name & "-" & calendrier.Name

comme ceci :

ref_calendrier = calendrier.Name & "-" & calendrier.store.DisplayName

Avec le Debug.Print j'obtiens :
des numéros ID du type 0000000EFCD etc etc

et des \\\Calendar

En ce qui concerne les dates j'ai toujours l'inversion.

En ce qui concerne les dates j'ai toujours l'inversion.

Vous avez appliqué cette modif ?

    '// initialisation feuille "Calend"
    With ThisWorkbook.Sheets("calend")
        .Cells.ClearContents
        .Columns("B:C").NumberFormat = "m/d/yyyy"
        .Range("A1:E1").Value2 = Array("Sujet", "Début", "Fin", "Emplacement", "Nom")
    End With

Vous avez essayé cette instruction ?

ref_calendrier = calendrier.Name & "-" & calendrier.store.DisplayName

J'ai appliqué l'instruction mais les dates sont toujours inversé

'// initialisation feuille "Calend"

With ThisWorkbook.Sheets("calend")

.Cells.ClearContents

.Columns("B:C").NumberFormat = "m/d/yyyy"

.Range("A1:E1").Value2 = Array("Sujet", "Début", "Fin", "Emplacement", "Nom")

End With

En ce qui concerne le nom des calendrier j'ai également essayé l'instruction, mais il une erreur 91 de variable objet ou variable de bloc with non définie

ref_calendrier = calendrier.Name & "-" & calendrier.store.DisplayName

J'ai appliqué l'instruction mais les dates sont toujours inversé

Votre version d'Excel est-elle bien en français ??

J'ai réussi avec cela pour les noms :

ref_calendrier = calendrier_dossier.DisplayName

J'ai toujours mon inversion de date.

Et sans vouloir abuser, est-il possible de trier par date de début ?

Merci à vous.

J'ai toujours mon inversion de date.

Encore une fois, j'ai l'impression que vous avez une version d'Excel en anglais ... Ce qui implique un changement de l'instruction de formatage de date.

Je crois que les date se formate bien dès lors qu'il y a une heure de début et fin de rendez-vous, sinon les dates s'inversent.

ma version d'Excel est en français, j'ai vérifié dans options langus

Et sans vouloir abuser, est-il possible de trier par date de début ?

ajouter l''instruction de tri dans ce groupe d'instructions :

    
    '// remplissage de la feuille à partir des rdvs stockés
    With ThisWorkbook.Sheets("calend")
        If UBound(tb) > -1 Then .Range("A2").Resize(UBound(tb) + 1, 5).Value = Application.Index(tb, 0, 0) _
        Else MsgBox "pas de rdvts trouvés"
        .UsedRange.Sort key1:=.Range("B2"), order1:=xlAscending, Header:=xlYes
    End With

Je crois que les date se formate bien dès lors qu'il y a une heure de début et fin de rendez-vous, sinon les dates s'inversent.

ma version d'Excel est en français, j'ai vérifié dans options langus

Les dates inversées sont-elle alignées à droite au niveau de la cellule qui contient, autrement dit sont-elles bien reconnues comme des dates ?

Oui elles sont alignées à droite.

De plus je viens de m'apercevoir que sur les dates inversées, les heures ne s'affichent pas.

Quand je regarde le format de la cellule celle-ci est en date avec un format type *14/03/2012

Donnez des exemples de vos dates inversées

Exemples de dates inversées pour une recherche 04/06/2023 au 09/06/2023.

De plus certaines dates apparaissent alors qu'elles ne sont pas dans le champ de recherche (exemple22/01/2021)

Exemples de dates inversées pour une recherche 04/06/2023 au 09/06/2023.

Quelles sont ces dates ? ça ne parait pas évident.

De plus certaines dates apparaissent alors qu'elles ne sont pas dans le champ de recherche (exemple22/01/2021)

Il doit s'agir de rendez-vous périodiques car le filtrage n'agit pas sur ce type de rendez-vous.

Oui il s'agit de rendez-vous périodiques.

Je ne sais pas comment faire pour régler ce problème de dates. Il ne reste plus que cela et ça serait parfait.

Vous pourriez apporter cette modification dans le groupe d'instructions ci-dessous

    
    'analyse des rdvts trouvés
    For Each olApt In rdvts_trouvés
        If (olApt.Subject <> "?PRESENT" And olApt.Subject <> "PRESENT") Then
            If Not olApt.IsRecurring Then
                ReDim Preserve tb(NextRow)
                ref_calendrier = calendrier.Name & "-" & calendrier_dossier.DisplayName
                tb(NextRow) = Array(olApt.Subject, olApt.Start, olApt.End, olApt.Location, ref_calendrier)
                NextRow = NextRow + 1
            Else
                Date_rdvt = DateSerial(Year(Date), olApt.GetRecurrencePattern.MonthOfYear, olApt.GetRecurrencePattern.DayOfMonth)
                If Date_rdvt >= FromDate And Date_rdvt <= ToDate Then
                    ReDim Preserve tb(NextRow)
                    ref_calendrier = calendrier.Name & "-" & calendrier_dossier.DisplayName
                    tb(NextRow) = Array(olApt.Subject, Date_rdvt, "", olApt.Location, ref_calendrier)
                    NextRow = NextRow + 1
                End If
            End If
        End If
    Next olApt

    Return

J'ai finalement réussi à importer avec les dates non inversées, avec le code ci-dessous.

Est-il possible de tagué les rendez-vous périodiques ?

Est-il possible de supprimer les rendez-vous annulés ?

Merci à vous.

Sub lister_rdvs()
 'Constantes Outlook
    Const olFolderCalendar As Byte = 9
    Const olExchange As Byte = 0
    Const olAppointmentItem = 1
    Dim OLApp As Object, OLExp As Object
    Dim module As NavigationModule
    Dim module_calendrier As CalendarModule
    Dim groupe_calendriers As NavigationGroup
    Dim calendrier_dossier As NavigationFolder
    Dim calendrier As Folder
    Dim filtre As String, ref_calendrier As String
    Dim rdvts_trouvés As Object, olApt As Object
    Dim NextRow As Long
    Dim FromDate As Date, ToDate As Date
    Dim tb(): tb = Array("")

    '// assignation application Outlook et explorateur
    Set OLApp = CreateObject("Outlook.Application")

    ' si OutLook n'est pas ouvert .....................
    If OLApp.Explorers.Count = 0 Then
        OLApp.Session.GetDefaultFolder(olFolderInbox).Display
        OLApp.ActiveExplorer.WindowState = olMinimized
    End If
    ' .....................................................
    Set OLExp = OLApp.ActiveExplorer

    '// assignation fourchette de dates
    FromDate = InputBox("Date de début ")
    ToDate = InputBox("Date de fin")

    '// initialisation feuille "Calend"
    With ThisWorkbook.Sheets("calend")
        .Cells.ClearContents
        .Columns("B:C").NumberFormat = "mm/d/YYYY hh:mm"
        .Range("A1:E1").Value2 = Array("Sujet", "Début", "Fin", "Emplacement", "Nom")
    End With

    '// remplissage de la feuille à partir des rdvs stockés

    '// exploration des calendriers
    For Each module In OLExp.NavigationPane.Modules

        If module.Class = olCalendarModule Then
            For Each groupe_calendriers In module.NavigationGroups

                For Each calendrier_dossier In groupe_calendriers.NavigationFolders
                    'assignation du calendrier
                    Set calendrier = calendrier_dossier.Folder

                    'stockage rdvs du calendrier
                    GoSub Stockage_rdvts
                Next calendrier_dossier

            Next groupe_calendriers
            Exit For
        End If

    Next module

    '// remplissage de la feuille à partir des rdvs stockés
    With ThisWorkbook.Sheets("calend")
        If UBound(tb) > -1 Then .Range("A2").Resize(UBound(tb) + 1, 5).Value = Application.Index(tb, 0, 0) _
        Else MsgBox "pas de rdvts trouvés"
    End With

    '// sortie procédure

    Exit Sub

'// sous_procédure de stockage des rdvts dans un tableau selon filtre de dates
Stockage_rdvts:
    'filtrage des rdvs correspondant à la fourchette de dates
    filtre = "[Start] > '" & FromDate & "'" & "And" & "[Start] < '" & ToDate + 1 & "'"
    Set rdvts_trouvés = calendrier.Items.Restrict(filtre)
    rdvts_trouvés.Sort "[Start]"

    'analyse des rdvts trouvés
    For Each olApt In rdvts_trouvés
        If (olApt.Subject <> "?PRESENT" And olApt.Subject <> "PRESENT") Then
            ReDim Preserve tb(NextRow)
            ref_calendrier = calendrier_dossier.DisplayName
            Debug.Print calendrier_dossier.DisplayName
            tb(NextRow) = Array(olApt.Subject, olApt.Start, olApt.End, olApt.Location, ref_calendrier)
            Debug.Print olApt.Start
            NextRow = NextRow + 1
        End If
    Next olApt

    Return

End Sub

Est-il possible de tagué les rendez-vous périodiques ?

Est-il possible de supprimer les rendez-vous annulés ?

J'ai traité les rendez-vous périodiques et les réunions annulées et ajouté le tri sur la date de début

ci-dessous code complet :

Sub lister_rdvs()
    'Constantes Outlook
    Const olCalendarModule = 159
    Const olFolderInbox As Byte = 6
    Const olMinimized As Byte = 1
    Const olNonMeeting As Byte = 0
    Const olMeetingCanceled As Byte = 5

    'Variables Outlook
    Dim OLApp As Object, OLExp As Object
    Dim module As Object
    Dim module_calendrier As Object
    Dim groupe_calendriers As Object
    Dim calendrier_navigation As Object
    Dim calendrier As Object
    Dim filtre As String, ref_calendrier As String
    Dim rdvts_trouvés As Object, olApt As Object
    Dim NextRow As Long
    Dim FromDate As Date, ToDate As Date
    Dim tb(): tb = Array("")
    Dim ligne As Range
    Dim Date_rdvt As Date

    '// assignation application Outlook et explorateur
    Set OLApp = CreateObject("Outlook.Application")

    ' si OutLook n'est pas ouvert .....................
    If OLApp.Explorers.Count = 0 Then
        OLApp.Session.GetDefaultFolder(olFolderInbox).Display
        OLApp.ActiveExplorer.WindowState = olMinimized
    End If
    ' .....................................................
    Set OLExp = OLApp.ActiveExplorer

    '// assignation fourchette de dates
    FromDate = CDate(InputBox("Date de début (format: dd/mm/yyyy)"))
    ToDate = CDate(InputBox("Date de fin(format: dd/mm/yyyy)"))

    '// initialisation feuille "Calend"
    With ThisWorkbook.Sheets("calend")
        .Cells.ClearContents
        .Columns("B:C").NumberFormat = "m/d/yyyy"
        .Range("A1:E1").Value2 = Array("Sujet", "Début", "Fin", "Emplacement", "Nom")
    End With

    '// exploration des calendriers
    For Each module In OLExp.NavigationPane.Modules

        If module.Class = olCalendarModule Then
            For Each groupe_calendriers In module.NavigationGroups

                For Each calendrier_navigation In groupe_calendriers.NavigationFolders
                    'assignation du calendrier
                    Set calendrier = calendrier_navigation.folder
                    'stockage rdvs du calendrier
                    GoSub Stockage_rdvts
                Next calendrier_navigation

            Next groupe_calendriers
            Exit For
        End If

    Next module

    '// remplissage de la feuille à partir des rdvs stockés
    With ThisWorkbook.Sheets("calend")
        'remplissage feuille
        If UBound(tb) > -1 Then .Range("A2").Resize(UBound(tb) + 1, 5).Value = Application.Index(tb, 0, 0) _
        Else MsgBox "pas de rdvts trouvés"

        'reconnaissance dates de début et de fin
        For Each ligne In .UsedRange.Rows
            If ligne.Row > 1 Then
                ligne.Columns("B") = CDate(ligne.Columns("B"))
                ligne.Columns("C") = CDate(ligne.Columns("C"))
            End If
        Next ligne

        'tri sur date début
        .UsedRange.Sort key1:=.Range("B2"), order1:=xlAscending, Header:=xlYes
    End With

    '// sortie procédure
    Exit Sub

'// sous_procédure de stockage des rdvts dans un tableau selon filtre de dates
Stockage_rdvts:
    'filtrage des rdvs correspondant à la fourchette de dates
    filtre = "[Start] > '" & FromDate & "'" & "And" & "[Start] < '" & ToDate + 1 & "'"
    Set rdvts_trouvés = calendrier.Items.Restrict(filtre)
    rdvts_trouvés.Sort "[Start]"

    'analyse des rdvts trouvés
    For Each olApt In rdvts_trouvés
        If (olApt.Subject <> "?PRESENT" And olApt.Subject <> "PRESENT") Then
            If Not olApt.IsRecurring Then
                If olApt.MeetingStatus <> olMeetingCanceled Then
                    ReDim Preserve tb(NextRow)
                    ref_calendrier = calendrier_navigation.DisplayName
                    tb(NextRow) = Array(olApt.Subject, olApt.Start, olApt.End, olApt.Location, ref_calendrier)
                    NextRow = NextRow + 1
                End If
            Else
                Date_rdvt = DateSerial(Year(Date), olApt.GetRecurrencePattern.MonthOfYear, olApt.GetRecurrencePattern.DayOfMonth)
                If Date_rdvt >= FromDate And Date_rdvt <= ToDate _
                And olApt.MeetingStatus <> olMeetingCanceled Then
                    ReDim Preserve tb(NextRow)
                    ref_calendrier = calendrier_navigation.DisplayName
                    tb(NextRow) = Array(olApt.Subject, Date_rdvt, olApt.GetRecurrencePattern.PatternEndDate, olApt.Location, ref_calendrier)
                    NextRow = NextRow + 1
                End If
            End If
        End If
    Next olApt

    Return

End Sub

Bonjour,

Je vous remercie beaucoup, la macro est opérationnelle.

J'ai encore un service à vous demander, est-il possible de mettre des bordures sur le tableau et de mettre un fond gris sur les données de la date du jour ?

Bonne journée.