IdentifiantMot de passe
Loading...
Mot de passe oublié ?Je m'inscris ! (gratuit)
Navigation

Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter

Macros et VBA Excel Discussion :

Macro import calendrier outlook et calendriers partagés


Sujet :

Macros et VBA Excel

  1. #1
    Membre du Club
    Homme Profil pro
    Ressources humaines
    Inscrit en
    Février 2019
    Messages
    177
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 51
    Localisation : France, Doubs (Franche Comté)

    Informations professionnelles :
    Activité : Ressources humaines

    Informations forums :
    Inscription : Février 2019
    Messages : 177
    Points : 45
    Points
    45
    Par défaut Macro import calendrier outlook et calendriers partagés
    Bonsoir,

    Dans la macro ci-dessous je récupère les informations de mon calendrier outlook.
    Je souhaiterais récupérer tous les informations du dossier calendriers partagés ( calendrier de Paul, Pierre...)
    Je ne parviens pas à trouver la solution après des recherches.
    Quelqu’un a-t-il la solution ?

    Merci.
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    Sub ListAppointments()
            Dim olApp As Object
            Dim olNS As Object
            Dim olFolder As Object
            Dim olApt As Object
            Dim NextRow As Long
            Dim FromDate As Date
            Dim ToDate As Date
     
            FromDate = Range("H1")
            ToDate = Range("I1")
     
     
            On Error Resume Next
            Set olApp = GetObject(, "Outlook.Application")
     
     
     
            If Err.Number > 0 Then Set olApp = CreateObject("Outlook.application")
     
            On Error GoTo 0
     
            Set olNS = olApp.GetNamespace("MAPI")
            Set olFolder = olNS.GetDefaultFolder(9) 'olFolderCalendar
     
            NextRow = 2
     
     
     
    With Sheets("calend")  'Change the name of the sheet here
                .Range("A1:D1").Value = Array("Project", "Date", "Time spent", "Location")
                For Each olApt In olFolder.Items
                If olApt.Subject <> "REC" Then
                    If (olApt.Start >= FromDate And olApt.Start <= ToDate) Then
                        .Cells(NextRow, "A").Value = olApt.Subject
                        .Cells(NextRow, "B").Value = CDate(olApt.Start)
                        .Cells(NextRow, "C").Value = olApt.End - olApt.Start
                        .Cells(NextRow, "C").NumberFormat = "HH:MM"
                        .Cells(NextRow, "D").Value = olApt.Location
                        .Cells(NextRow, "E").Value = olApt.Categories
                        .Cells(NextRow, "F").Value = olApt.RequiredAttendees
                        NextRow = NextRow + 1
     
     
                    Else
                    End If
                    End If
                Next olApt
     
            End With
     
     
            Set olApt = Nothing
            Set olFolder = Nothing
            Set olNS = Nothing
            Set olApp = Nothing
        End Sub

  2. #2
    Membre du Club
    Homme Profil pro
    Ressources humaines
    Inscrit en
    Février 2019
    Messages
    177
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 51
    Localisation : France, Doubs (Franche Comté)

    Informations professionnelles :
    Activité : Ressources humaines

    Informations forums :
    Inscription : Février 2019
    Messages : 177
    Points : 45
    Points
    45
    Par défaut
    Bonjour,

    J'ai essayé avec la macro ci-dessous, mais j'ai une erreur incompatibilité de type :

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    Sub ListAppointments()
     
    Dim olApp As Object
    Dim olNS As Object
    Dim olFolder As Object
    Dim olApt As Object
    Dim objOwner As Object
    Dim olFolderCalendar As Object
     
    Dim NextRow As Long
     
    Set olApp = CreateObject("Outlook.Application")
     
    Set olNS = olApp.GetNamespace("MAPI")
     
    Set objOwner = olNS.CreateRecipient("paul.durand@dom.fr")
     
    objOwner.Resolve
     
    If objOwner.Resolved Then
     
        MsgBox objOwner.Name
        Set olFolder = olNS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
     
    End If
     
    Range("A1:D1").Value = Array("Subject", "Start", "End", "Location")
     
    NextRow = 2
     
    For Each olApt In olFolder.Items
        Cells(NextRow, "A").Value = olApt.Subject
        Cells(NextRow, "B").Value = olApt.Start
        Cells(NextRow, "C").Value = olApt.End
        Cells(NextRow, "D").Value = olApt.Location
        NextRow = NextRow + 1
    Next olApt
     
    Set olApt = Nothing
    Set olFolder = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
     
    Columns.AutoFit
     
    End Sub

  3. #3
    Expert éminent

    Homme Profil pro
    Curieux
    Inscrit en
    Juillet 2012
    Messages
    5 071
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Paris (Île de France)

    Informations professionnelles :
    Activité : Curieux
    Secteur : Arts - Culture

    Informations forums :
    Inscription : Juillet 2012
    Messages : 5 071
    Points : 9 850
    Points
    9 850
    Billets dans le blog
    5
    Par défaut
    Bonjour,

    quelle est la ligne marquée en erreur ?

    A noter que tu travailles en late binding, ce qui signifie que tu ne peux pas utiliser la constante olFolderCalendar en toute sécurité dans ta procédure (il faut que la référence à Outlook soit cochée), il est préférable de la remplacer par son équivalent numérique qui est le 9 de mémoire

  4. #4
    Membre du Club
    Homme Profil pro
    Ressources humaines
    Inscrit en
    Février 2019
    Messages
    177
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 51
    Localisation : France, Doubs (Franche Comté)

    Informations professionnelles :
    Activité : Ressources humaines

    Informations forums :
    Inscription : Février 2019
    Messages : 177
    Points : 45
    Points
    45
    Par défaut
    je n'ai plus l'erreur à présent.
    Par contre j'arrive à lire seulement mon calendrier.
    Je ne peux pas lire le calendrier d'un collaborateur, bien que son calendrier soit partagé (paul.durand@dom.fr).

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    Option Explicit
     
    Public Sub ListAppointments()
    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
        Dim objOwner    As Object: Set objOwner = olNS.CreateRecipient("paul.durand@dom.fr")
        Dim NextRow     As Long
        Dim ws          As Worksheet: Set ws = ThisWorkbook.Sheets("calend")
        Dim FromDate As Date
        Dim ToDate As Date
        FromDate = InputBox("Enter the start date (format: dd/mm/yyyy)")
       ToDate = InputBox("Enter the end date(format: dd/mm/yyyy)")
     
        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
        Debug.Print olFolder.Items.Count
        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
        If (olApt.Start >= FromDate And olApt.Start <= ToDate) Then
            myArr(0, NextRow) = olApt.Subject
            myArr(1, NextRow) = olApt.Start
            myArr(2, NextRow) = olApt.End
            myArr(3, NextRow) = olApt.Location
            NextRow = NextRow + 1
            Else
            End If
        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

  5. #5
    Expert éminent

    Homme Profil pro
    Curieux
    Inscrit en
    Juillet 2012
    Messages
    5 071
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Paris (Île de France)

    Informations professionnelles :
    Activité : Curieux
    Secteur : Arts - Culture

    Informations forums :
    Inscription : Juillet 2012
    Messages : 5 071
    Points : 9 850
    Points
    9 850
    Billets dans le blog
    5
    Par défaut
    Cette contribution d'Oliv- devrait t'aider


    https://www.developpez.net/forums/d2.../#post11580474

  6. #6
    Membre du Club
    Homme Profil pro
    Ressources humaines
    Inscrit en
    Février 2019
    Messages
    177
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 51
    Localisation : France, Doubs (Franche Comté)

    Informations professionnelles :
    Activité : Ressources humaines

    Informations forums :
    Inscription : Février 2019
    Messages : 177
    Points : 45
    Points
    45
    Par défaut
    Merci pour le post.

    J'ai une erreur sur la ligne SET objNS = Application.session
    Erreur 438 propriété ou méthode non gérée par cet objet.

  7. #7
    Expert éminent

    Homme Profil pro
    Curieux
    Inscrit en
    Juillet 2012
    Messages
    5 071
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Paris (Île de France)

    Informations professionnelles :
    Activité : Curieux
    Secteur : Arts - Culture

    Informations forums :
    Inscription : Juillet 2012
    Messages : 5 071
    Points : 9 850
    Points
    9 850
    Billets dans le blog
    5
    Par défaut
    Oui attention, cette contribution est une procédure qui tourne depuis Outlook et pas Excel

    tu dois adapter, car ici "Application" va se référer à Excel.Application puisque tu la déroules depuis Excel


    Grosso modo, en reprenant les bases de ta procédure :


    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    Set objNS = olApp.Session

  8. #8
    Membre du Club
    Homme Profil pro
    Ressources humaines
    Inscrit en
    Février 2019
    Messages
    177
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 51
    Localisation : France, Doubs (Franche Comté)

    Informations professionnelles :
    Activité : Ressources humaines

    Informations forums :
    Inscription : Février 2019
    Messages : 177
    Points : 45
    Points
    45
    Par défaut
    Oui je me doutais un peu. Néanmoins je suis pas sûr de tout comprendre pour la transformer en vba Excel.
    J'ai essayé avec le code ci-dessous, et j'ai une erreur 424 objet requis.

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    Sub ListeCalendrierPartagé()
    '---------------------------------------------------------------------------------------
    ' Procedure : ListeCalendrierPartagé
    ' Author    : Oliv-
    ' Date      : 19/02/2014
    ' Purpose   : Liste les des "calendrier partagé" et le Dossier correpondant
    '---------------------------------------------------------------------------------------
    '
        Dim objNS As Outlook.Namespace
        Dim objExpCal As Outlook.Explorer
        Dim objNavMod As Outlook.CalendarModule
        Dim objNavCalPart As Outlook.NavigationFolders
        Dim I, objitem
     
        Set objNS = olApp.Session
     
        Set objExpCal = olNS.GetDefaultFolder(olFolderCalendar).GetExplorer
     
        Set objNavMod = olExpCal.NavigationPane.Modules.GetNavigationModule(olModuleCalendar)
        Set objNavCalPart = olNavMod.NavigationGroups.Item("Calendriers partagés").NavigationFolders
        For I = 1 To olNavCalPart.Count
            Set olitem = olNavCalPart(I)
            On Error Resume Next
     
            FoldName = olitem.Folder.Name & "-" & olitem.Folder.FullFolderPath
            If Err Then FoldName = "Pas accessible"
            Debug.Print olitem & "-->" & FoldName
     
        Next I
    End Sub

  9. #9
    Membre du Club
    Homme Profil pro
    Ressources humaines
    Inscrit en
    Février 2019
    Messages
    177
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 51
    Localisation : France, Doubs (Franche Comté)

    Informations professionnelles :
    Activité : Ressources humaines

    Informations forums :
    Inscription : Février 2019
    Messages : 177
    Points : 45
    Points
    45
    Par défaut
    J'ai finalement réussi à importer un calendrier partagé avec cette macro.
    Par contre est-il possible de créer un boucle pour lire plusieurs adresses mail partagées.
    Enfin, comment obtenir le nom du propriétaire du calendrier pour alimenter le tableau en 4.

    Merci pour votre aide.

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    Option Explicit
     
    Public Sub ListAppointments()
    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
        Dim objOwner    As Object: Set objOwner = olNS.CreateRecipient("paul.durand@dom.fr")
        Dim NextRow     As Long
        Dim ws          As Worksheet: Set ws = ThisWorkbook.Sheets("calend")
        Dim FromDate As Date
        Dim ToDate As Date
        FromDate = InputBox("Enter the start date (format: dd/mm/yyyy)")
       ToDate = InputBox("Enter the end date(format: dd/mm/yyyy)")
     
        objOwner.Resolve
     
        If objOwner.Resolved Then
            Set olFolder = olNS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
            'Set olFolder = olNS.GetSharedDefaultFolder(9)
        End If
     
        ws.Range("A1:E1").Value2 = Array("Subject", "Start", "End", "Location", "Name")
     
        'Ensure there at least 1 item to continue
        Debug.Print olFolder.Items.Count
        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 4, 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
        If (olApt.Start >= FromDate And olApt.Start <= ToDate) Then
            myArr(0, NextRow) = olApt.Subject
            myArr(1, NextRow) = olApt.Start
            myArr(2, NextRow) = olApt.End
            myArr(3, NextRow) = olApt.Location
            myArr(4, NextRow) = olFolder.Folder.Name
            NextRow = NextRow + 1
            Else
            End If
        Next
        On Error GoTo 0
     
        'Write all records to a worksheet from an array, this is much faster
        ws.Range("A2:E" & NextRow + 1).Value = WorksheetFunction.Transpose(myArr)
     
        'AutoFit
        ws.Columns.AutoFit
     
    cleanExit:
        Application.ScreenUpdating = True
        Exit Sub
     
    ErrHand:
        'Add error handler
        Resume cleanExit
    End Sub

  10. #10
    Membre du Club
    Homme Profil pro
    Ressources humaines
    Inscrit en
    Février 2019
    Messages
    177
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 51
    Localisation : France, Doubs (Franche Comté)

    Informations professionnelles :
    Activité : Ressources humaines

    Informations forums :
    Inscription : Février 2019
    Messages : 177
    Points : 45
    Points
    45
    Par défaut
    Bonjour,

    Y-a-t-il une solution pour faire l'import de plusieurs calendriers ?

    Merci pour votre aide.

  11. #11
    Membre du Club
    Homme Profil pro
    Ressources humaines
    Inscrit en
    Février 2019
    Messages
    177
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 51
    Localisation : France, Doubs (Franche Comté)

    Informations professionnelles :
    Activité : Ressources humaines

    Informations forums :
    Inscription : Février 2019
    Messages : 177
    Points : 45
    Points
    45
    Par défaut
    J'ai trouvé pour importer le owner du calendrier Par contre je ne sais pas s'il est possible de réaliser un boucle pour importer les appointment de plusieurs calendriers partagés.

  12. #12
    Membre du Club
    Homme Profil pro
    Ressources humaines
    Inscrit en
    Février 2019
    Messages
    177
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 51
    Localisation : France, Doubs (Franche Comté)

    Informations professionnelles :
    Activité : Ressources humaines

    Informations forums :
    Inscription : Février 2019
    Messages : 177
    Points : 45
    Points
    45
    Par défaut
    J'ai essayé avec deux adresses Objowner et objowner2, mais en vain. Je bloque au niveau de la boucle For each.
    Comment faire avec toutes les adresses du dossier calendriers partagés
    Merci à vous

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    Option Explicit
     
    Public Sub ListAppointments()
    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 olFolder2    As Object
        Dim olApt       As Object
        Dim objOwner    As Object: Set objOwner = olNS.CreateRecipient("paul.durand@dom.fr")
        Dim objOwner2   As Object: Set objOwner2 = olNS.CreateRecipient("pierre.dupont@dom.fr")
        Dim NextRow     As Long
        Dim ws          As Worksheet: Set ws = ThisWorkbook.Sheets("calend")
        Dim FromDate As Date
        Dim ToDate As Date
     
     
        FromDate = InputBox("Enter the start date (format: dd/mm/yyyy)")
       ToDate = InputBox("Enter the end date(format: dd/mm/yyyy)")
     
        objOwner.Resolve
        objOwner2.Resolve
     
        If (objOwner.Resolved And objOwner2.Resolve) Then
            Set olFolder = olNS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
            Set olFolder2 = olNS.GetSharedDefaultFolder(objOwner2, olFolderCalendar)
            'Set olFolder = olNS.GetSharedDefaultFolder(9)
        End If
        Worksheets("calend").Cells.ClearContents
        ws.Range("A1:E1").Value2 = Array("Subject", "Start", "End", "Location", "Name")
     
        'Ensure there at least 1 item to continue
        Debug.Print olFolder.Items.Count
        Debug.Print objOwner.Name
        Debug.Print objOwner2.Name
     
        If (olFolder.Items.Count = 0 And olFolder2.Items.Count = 0) Then Exit Sub
     
        'Create an array large enough to hold all records
        Dim myArr() As Variant: ReDim myArr(0 To 4, 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
        If (olApt.Subject <> "?PRESENT" And olApt.Subject <> "PRESENT") Then
        If (olApt.Start >= FromDate And olApt.Start <= ToDate) Then
     
            myArr(0, NextRow) = olApt.Subject
            myArr(1, NextRow) = olApt.Start
            myArr(2, NextRow) = olApt.End
            myArr(3, NextRow) = olApt.Location
            myArr(4, NextRow) = objOwner.Name
            NextRow = NextRow + 1
            Else
            End If
            End If
        Next olApt
         Set olApt = Nothing
            Set olFolder = Nothing
            Set olNS = Nothing
            Set OLApp = Nothing
        On Error GoTo 0
     
        'Write all records to a worksheet from an array, this is much faster
        ws.Range("A2:E" & NextRow + 1).Value = WorksheetFunction.Transpose(myArr)
     
        'AutoFit
        ws.Columns.AutoFit
     
    cleanExit:
        Application.ScreenUpdating = True
        Exit Sub
     
    ErrHand:
        'Add error handler
        Resume cleanExit
    End Sub

  13. #13
    Membre du Club
    Homme Profil pro
    Ressources humaines
    Inscrit en
    Février 2019
    Messages
    177
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 51
    Localisation : France, Doubs (Franche Comté)

    Informations professionnelles :
    Activité : Ressources humaines

    Informations forums :
    Inscription : Février 2019
    Messages : 177
    Points : 45
    Points
    45
    Par défaut
    Bonjour,

    J'ai essayé avec la macro ci-dessous, qui avec un userform en une combo devrait permettre de sélectionner un ou plusieurs nom.
    J'ai toujours un retour avec le message "Not Share calendar"

    Est-ce possible de mettre en place une solution qui permette de sélectionner plusieurs calendrier partagés ?

    Merci pour votre aide.

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
    101
    102
    103
    104
    105
    106
    107
    108
    109
    110
    111
    112
    113
    114
    115
    116
    117
    118
    119
    120
    121
    122
    123
    124
    125
    126
    127
    Option Explicit
    Public R As Long
    Public SelectedCalendar As String
    ' ********************************************************************************
    ' *   Interrogate Outlook calendars for all external meetings & populate
    ' *   Excel database with attendees coming down the columns for each appt.
    ' **********************************************************************************
     
    Sub outlook_calendaritemsexport()
     
    Dim C As Long, i As Long, lrow As Long
    Dim appt_id As Long, append_row As Long
    Dim data_array() As Variant, start_time As Variant
     
    Dim myfol As Outlook.Folder
    Dim ons As Outlook.Namespace
    Dim o As Outlook.Application
    Dim myapt As Outlook.AppointmentItem
    Dim myrpnt As Outlook.Recipient
    Dim oEU As Object
     
    Set o = New Outlook.Application
    Set ons = o.GetNamespace("MAPI")
     
    start_time = Now()
     
    Sheets("Data").Activate
     
    'Show UserForm here. UserForm is a simple box with names of shared calendars, which gets stored into "SelectedCalendar" upon selection. R is also set to 5 (start row on my sheet), or last row after current data
    UserForm1.Show
     
    'Setup 'Subroutine to Setup column widths / colors etc
     
    append_row = R 'use this to know where to append the new data onto screen for an appended search.. R comes from UserForm.
     
    Dim myRecipient As Outlook.Recipient
     
    'selected in the userform ComboBox list
    If SelectedCalendar = "Select Calendar" Then 'nobody selected, so operate on your own calendar
        Set myfol = ons.GetDefaultFolder(olFolderCalendar) 'Set this to work on own folder
    Else
        Set myRecipient = ons.CreateRecipient(SelectedCalendar)
        myRecipient.Resolve
     
        If myRecipient.Resolved Then
                Set myfol = ons.GetSharedDefaultFolder(myRecipient, olFolderCalendar)
            Else
                MsgBox ("Calendar Issue, Program Halted")
                End  'end if calendar not resolved
        End If
    End If
     
    Range("A4:N4").Value = Array("DATE", "CUSTOMER", "SUBJECT", "LOCATION", "CUSTOMER TYPE or DISTRIBUTOR MEETING", "FACE To FACE / TEAMS", "DISTRIBUTOR Or ALONE", "DISTRIBUTOR VISIT TYPE", "CUSTOMER ATTENDEES", "DISTRIBUTOR ATTENDEES", "OUR ATTENDEES", "REQUIRED ATTENDEES", "CALENDAR OWNER", "MEET ID")
     
    'check calendar has some items inside / is shared
     
    On Error GoTo ErrorHandler
     
    lrow = 0 'array row start)
    ReDim Preserve data_array(1 To 14, lrow) '(be aware the array is transposed, as ReDim Preserve only works on last dimension)
     
    '***  GET THIS DYNAMICALLY FROM LAST ROW OF DATA (comes from userform button) in case of New, or Appended data search *****
    If R = 5 Then
        appt_id = 1 'set first appointment ID number
    Else
        appt_id = Cells(R - 1, 14).Value + 1
    End If
     
     
    R = 0 ' now reset R as first row in array
     
    For Each myapt In myfol.Items 'check each calendar Appointment) Then
     
        'Year(Now())   Year(Now())-1  this year last year
      If InStr(myapt.Start, Year(Now())) > 0 Or InStr(myapt.Start, (Year(Now())) - 1) > 0 Then ' if appt is this year/last year
     
     
        data_array(1, R) = myapt.Start
     
        data_array(3, R) = myapt.Subject
     
        data_array(4, R) = myapt.Location
     
        data_array(12, R) = LCase(myapt.RequiredAttendees)
     
        data_array(13, R) = SelectedCalendar
     
        data_array(14, R) = appt_id
     
        appt_id = appt_id + 1 ' update appointment ID code
     
         ReDim Preserve data_array(1 To 14, R + 1)
     
         R = R + 1
     End If 'End Appt year checking
     
    Next 'Calendar Appointment
     
    Set o = Nothing
    Set ons = Nothing
    Set myfol = Nothing
    Set myapt = Nothing
    Set myrpnt = Nothing
     
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.EnableEvents = True
     
    'store data on screen
    Range(Cells(append_row, 1), Cells(append_row + UBound(data_array, 2), 14)) = WorksheetFunction.Transpose(data_array) 'function to transpose data back into rows due to RedimPreserve operating across only
     
     
    MsgBox ("start : " & start_time & "  finish : " & Now())
     
    Erase data_array
     
     
    End
     
    ErrorHandler:
        MsgBox ("Calendar Not Shared")
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
        Application.EnableEvents = True
        End
     
    End Sub

  14. #14
    Membre du Club
    Homme Profil pro
    Ressources humaines
    Inscrit en
    Février 2019
    Messages
    177
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 51
    Localisation : France, Doubs (Franche Comté)

    Informations professionnelles :
    Activité : Ressources humaines

    Informations forums :
    Inscription : Février 2019
    Messages : 177
    Points : 45
    Points
    45
    Par défaut
    Bonjour,

    j'ai effectué des recherches, mais je parviens a trouver de solution.
    est-il possible d'alimenter le tableau (My Arr) avec les données des calendriers partagés ?

    Je vous remer-cie pour votre aide.

  15. #15
    Membre du Club
    Homme Profil pro
    Ressources humaines
    Inscrit en
    Février 2019
    Messages
    177
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 51
    Localisation : France, Doubs (Franche Comté)

    Informations professionnelles :
    Activité : Ressources humaines

    Informations forums :
    Inscription : Février 2019
    Messages : 177
    Points : 45
    Points
    45
    Par défaut
    J'ai essayé avec la macro ci-dessous.
    Avec cette macro je ne récupère que mon calendrier. Je ne parviens pas à récupérer les calendriers partagés.
    De plus mes rendez-vous ne sont pas affichés dans la feuille "calend".
    Faut-il des droits spécifique avec cette macro ?
    Merci à vous.

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    Option Explicit
     
    Public Sub ListAppointments()
     
        On Error GoTo ErrHand:
     
        Application.ScreenUpdating = False
     
        'This is an enumeration value in context of getDefaultSharedFolder
        Const olFolderCalendar As Byte = 9
        Const olExchange As Byte = 0
     
        Dim OLApp As Object: Set OLApp = CreateObject("Outlook.Application")
        Dim compte As Object, récipient As Object
        Dim calendriers_partagés As Object, calendrier_partagé As Object
        Dim filtre As String
        Dim rdvts_trouvés As Object, olApt As Object
        Dim NextRow As Long
        Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("calend")
        Dim FromDate As Date
        Dim ToDate As Date
        Dim myArr()
     
        FromDate = CDate(InputBox("Enter the start date (format: dd/mm/yyyy)"))
        ToDate = CDate(InputBox("Enter the end date(format: dd/mm/yyyy)"))
     
        Worksheets("calend").Cells.ClearContents
        ws.Range("A1:E1").Value2 = Array("Subject", "Start", "End", "Location", "Name")
     
        For Each compte In OLApp.Session.Accounts
            If compte.AccountType = olExchange Then
                Set récipient = OLApp.Session.CreateRecipient(compte.DisplayName)
                Set calendriers_partagés = OLApp.Session.GetSharedDefaultFolder(récipient, olFolderCalendar)
                If Not calendriers_partagés Is Nothing Then GoSub Stockage_rdvts
            End If
        Next compte
     
        'Write all records to a worksheet from an array, this is much faster
        If UBound(myArr) > -1 Then ws.Range("A2").Resize(UBound(myArr), 5).Value = Application.Index(myArr, 0, 0) _
        Else MsgBox "no appointment found"
     
        'AutoFit
        ws.Columns.AutoFit
     
        Set OLApp = Nothing
        On Error GoTo 0
     
    cleanExit:
        Application.ScreenUpdating = True
        Exit Sub
     
    Stockage_rdvts:
        For Each calendrier_partagé In calendriers_partagés.Folders
     
            'filtrage des rdvs correspondant à la fourchette de dates
            filtre = "[Start] > '" & FromDate & "'" & "And" & "[Start] < '" & ToDate + 1 & "'"
            Set rdvts_trouvés = calendrier_partagé.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 myArr(NextRow)
                    myArr(NextRow) = Array(olApt.Subject, olApt.Start, olApt.End, olApt.Location, calendrier_partagé.Name)
                    NextRow = NextRow + 1
                End If
            Next olApt
     
        Next calendrier_partagé
     
        Return
     
    ErrHand:
        'Add error handler
        Resume cleanExit
    End Sub

Discussions similaires

  1. [OL-365] Inscrire des RDV dans Outlook (calendrier partagé) via Excel macro
    Par Lolote83 dans le forum VBA Outlook
    Réponses: 4
    Dernier message: 08/12/2023, 22h12
  2. Réponses: 46
    Dernier message: 10/12/2020, 10h14
  3. Executer macro sur calendrier Outlook
    Par Raikko68 dans le forum VBA Outlook
    Réponses: 0
    Dernier message: 04/08/2010, 15h22
  4. Réponses: 0
    Dernier message: 03/08/2009, 12h51
  5. Outlook - calendrier partagé - decalage d'1 heure
    Par delphine_lep dans le forum Outlook
    Réponses: 2
    Dernier message: 17/08/2005, 18h28

Partager

Partager
  • Envoyer la discussion sur Viadeo
  • Envoyer la discussion sur Twitter
  • Envoyer la discussion sur Google
  • Envoyer la discussion sur Facebook
  • Envoyer la discussion sur Digg
  • Envoyer la discussion sur Delicious
  • Envoyer la discussion sur MySpace
  • Envoyer la discussion sur Yahoo