Vérifier si une réunion existe et la mettre à jour

Bonjour à tous!

Encore moi qui "struggle" avec le même projet (c'était peut-être au dessus de mes forces).

Grâce entre autres à l'aide de Thev et de Gvialles une petite macro qui permet de relier Microsoft Project à Outlook a vu le jour dans notre communauté.

https://forum.excel-pratique.com/excel/creer-un-appointment-outlook-dans-un-calendrier-specifique-16...

En me référant à cette page

https://www.extendoffice.com/documents/outlook/2397-outlook-calendar-search-and-replace.html

j'essaie de vérifier si une réunion existe dans une catégorie donnée, puis si oui, de mofifier le début et la fin.

Honnêtement, c'Est ce qui répondrait à mes besoins, par contre, il serait préférable de passer à la loupe chaque élément disponible pour pouvoir faire n'importe quel mise jour possible .. (pouvoir passer en revue chaque cellule et faire l'ajout/modifications/supression) s'il-y-a lieu.

Le segment de code que j'essaie est:

 Dim rdvcheck As Outlook.AppointmentItem
    For Each t In pj.Tasks

        For Each rdvcheck In calendrier.Items
    If InStr(rdvcheck.Subject, t.Name) <> 0 And InStr(rdvcheck.Categories, Me.ComboBox2.Value) <> 0 Then

       rdvcheck.Start = Replace(rdvcheck.Start, rdvcheck.Start, t.Start)
       rdvcheck.End = Replace(rdvcheck.End, rdvcheck.End, t.Finish)
       rdvcheck.Send
        rdvcheck.Save

Else
       Set rdv = calendrier.Items.Add

        With rdv
            .Subject = t.Name
            .Start = t.Start
            .End = t.Finish
            .Categories = Me.ComboBox2.Value
            .Recipients = t.Text1
            .Location = t.Text2
            .MeetingStatus = olMeeting
            .Send
            .Save
        End With
        End If
        Next
    Next t

End Sub

Le code complet du USERFORM ICI:

'// ... cocher les références des bibliothèques Microsoft Outlook et Scripting Runtime
Option Explicit

Dim OLApp As Outlook.Application
Dim dic_calendriers As New Dictionary
Dim aCategories() As String

Private Sub UserForm_Initialize()

    On Error Resume Next
    Set OLApp = GetObject(, "Outlook.Application")
    On Error GoTo 0
    If OLApp Is Nothing Then
        Set OLApp = CreateObject("Outlook.Application")
        OLApp.Session.GetDefaultFolder(olFolderInbox).Display
        OLApp.ActiveExplorer.WindowState = olMinimized
    End If

    stocker_calendriers
    Me.ComboBox1.List = dic_calendriers.Keys

    Categories aCategories
    Me.ComboBox2.List = aCategories

End Sub

Private Sub CommandButton1_Click()
'On Error Resume Next
    Dim rdv As Outlook.AppointmentItem
    Dim calendrier As Outlook.Folder
    Dim t As Task
    Dim pj As Project

    Set calendrier = dic_calendriers(Me.ComboBox1.Value)

    Set pj = ActiveProject

    Dim rdvcheck As Outlook.AppointmentItem
    For Each t In pj.Tasks

        For Each rdvcheck In calendrier.Items
    If InStr(rdvcheck.Subject, t.Name) <> 0 And InStr(rdvcheck.Categories, Me.ComboBox2.Value) <> 0 Then

       rdvcheck.Start = Replace(rdvcheck.Start, rdvcheck.Start, t.Start)
       rdvcheck.End = Replace(rdvcheck.End, rdvcheck.End, t.Finish)
       rdvcheck.Send
        rdvcheck.Save

Else
       Set rdv = calendrier.Items.Add

        With rdv
            .Subject = t.Name
            .Start = t.Start
            .End = t.Finish
            .Categories = Me.ComboBox2.Value
            .Recipients = t.Text1
            .Location = t.Text2
            .MeetingStatus = olMeeting
            .Send
            .Save
        End With
        End If
        Next
    Next t

End Sub

Sub Categories(ByRef zCategories() As String)
    Dim olobjCategory As Category
    Dim olstrOutput As String
    ReDim zCategories(0)
    Dim lNb As Long

    If OLApp.Session.Categories.Count > 0 Then

        For Each olobjCategory In OLApp.Session.Categories
           ReDim Preserve zCategories(lNb)
           zCategories(lNb) = olobjCategory.Name
           lNb = lNb + 1
           'olstrOutput = olstrOutput & olobjCategory.Name & vbCrLf
        Next
    End If

    Set olobjCategory = Nothing

 End Sub

Sub stocker_calendriers()
  On Error GoTo Err

    Dim explorateur As Outlook.Explorer
    Dim module As Outlook.NavigationModule
    Dim module_calendrier As Outlook.CalendarModule
    Dim groupe_calendriers As Outlook.NavigationGroup
    Dim calendrier_dossier As Outlook.NavigationFolder
    Dim calendrier As Outlook.Folder
    Dim nom_calendrier As String

    '// assignation explorateur
    Set explorateur = OLApp.ActiveExplorer

    '// stockage des calendriers
    For Each module In explorateur.NavigationPane.Modules
        If module.Class = olCalendarModule Then
            Set module_calendrier = module
            For Each groupe_calendriers In module_calendrier.NavigationGroups
                For Each calendrier_dossier In groupe_calendriers.NavigationFolders

                    'assignation du calendrier
                    Set calendrier = calendrier_dossier.Folder

                    'nom du calendrier
                    nom_calendrier = calendrier.Name & "-" & Split(calendrier.FolderPath, "\")(2)

                    'stockage calendriers dans le dictionnaire des calendriers
                    Set dic_calendriers(nom_calendrier) = calendrier

                Next calendrier_dossier
            Next groupe_calendriers
            Exit For
        End If
    Next module

Err:

End Sub

MERCI ENCORE tout le monde, il semble que coder inter-application soit un peu plus mêlant que je pensais!!!

des idées?

Bonjour Crackwood01

La pratique du "Up" n'est pas bien perçu lorsque qu'il n'y a que 3 heures qui la sépare de la demande, qui plus est nous sommes dimanche !

Merci d'y aller mollo SVP

Bonjour Crackwood01

La pratique du "Up" n'est pas bien perçu lorsque qu'il n'y a que 3 heures qui la sépare de la demande, qui plus est nous sommes dimanche !

Merci d'y aller mollo SVP

Bien reçu!