Mise à jour d'appointment outlook

Le 20/04/2022 à 05:38

Salut Forum,

je post dans cette section car je pense qu'il est consulté 1000 fois plus que les autres sur ce forum.
La réponse est tout autant valide dans excel, je pense que j'aborde souvent des sujets peu ou pas discutés

Depuis MSProject j'essaie de mettre à jour des appointments

Par contre je n'y arrive pas

voici mon code jusqu'à présent

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
    Dim rdvcheck As Outlook.AppointmentItem
    Dim Fournisseur As Outlook.Recipient
    Dim ChoixCategorie As Variant, ChoixExport As Variant
    Set calendrier = dic_calendriers(Me.ComboBox1.Value)

    Set pj = ActiveProject

If ComboBox3.ListIndex = 0 Then
    Set ChoixExport = ActiveProject
ElseIf ComboBox3.ListIndex = 1 Then
    Set ChoixExport = ActiveSelection
End If

    For Each t In ChoixExport.Tasks

If Me.CheckBox1.Value = True Then
    ChoixCategorie = Me.ComboBox2.Value
ElseIf Me.CheckBox1.Value = False Then
    ChoixCategorie = t.Text3
End If

     For Each rdvcheck In calendrier.Items

   If InStr(rdvcheck.subject, t.Name) <> 0 And InStr(rdvcheck.Categories, t.Text3) <> 0 Then

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

    ElseIf InStr(rdvcheck.subject, t.Name) = 0 And InStr(rdvcheck.Categories, t.Text3) = 0 Then

               Set rdv = calendrier.Items.Add

        With rdv
            .subject = t.Name
            .Start = t.Start
            .End = t.Finish
            .Categories = ChoixCategorie
            .Recipients.Add (t.Text1)
            .Location = t.Text2
            .MeetingStatus = olMeeting
            '.Display
            '.Send
            .Save
        End With

        End If

Next rdvcheck

    Next t

End Sub

J'ai pris un bout de code sur le site d'ExtendOffice

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

Merci de m'aider, je pense que c'est un problême de boucle

8userform1.frm (5.19 Ko)
5userform1.frx (3.52 Ko)

http://www.crflix.ca/docs/test.mpp

Le 20/04/2022 à 09:26

Bonjour,

Il y a déjà un problème de base. Dans le code du Userform1 que vous joignez, il est fait référence aux Combobox1,Combobox2,Combobox3 qui n'existent pas ....

Le 20/04/2022 à 14:02

Bonjour Thev,

j'ignore pourquoi cela n'apparait pas, mais il est bien évident que les 3 combobox existent...

image

ici mon : Global.MPT

Merci de ton aide précieuse!

Sinon voici le code complet du Userform1

'// ... 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 CheckBox1_Click()
If Me.CheckBox1.Value = True Then Me.ComboBox2.Enabled = True
If Me.CheckBox1.Value = False Then Me.ComboBox2.Enabled = False
End Sub

Private Sub ComboBox2_Change()

End Sub

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

    With Me.ComboBox3
        .AddItem "Projet entier"
        .AddItem "Tâches Sélectionnées"
    End With

Me.ComboBox1.ListIndex = 4
Me.ComboBox3.ListIndex = 0

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
    Dim rdvcheck As Outlook.AppointmentItem
    Dim Fournisseur As Outlook.Recipient
    Dim ChoixCategorie As Variant, ChoixExport As Variant
    Set calendrier = dic_calendriers(Me.ComboBox1.Value)

    Set pj = ActiveProject

If ComboBox3.ListIndex = 0 Then
    Set ChoixExport = ActiveProject
ElseIf ComboBox3.ListIndex = 1 Then
    Set ChoixExport = ActiveSelection
End If

    For Each t In ChoixExport.Tasks

If Me.CheckBox1.Value = True Then
    ChoixCategorie = Me.ComboBox2.Value
ElseIf Me.CheckBox1.Value = False Then
    ChoixCategorie = t.Text3
End If

     For Each rdvcheck In calendrier.Items

   If InStr(rdvcheck.subject, t.Name) <> 0 And InStr(rdvcheck.Categories, ChoixCategorie) <> 0 Then

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

    ElseIf InStr(rdvcheck.subject, t.Name) = 0 And InStr(rdvcheck.Categories, ChoixCategorie) = 0 Then

               Set rdv = calendrier.Items.Add

        With rdv
            .subject = t.Name
            .Start = t.Start
            .End = t.Finish
            .Categories = ChoixCategorie
            .Recipients.Add (t.Text1)
            .Location = t.Text2
            .MeetingStatus = olMeeting
            '.Display
            '.Send
            .Save
        End With

        End If

Next rdvcheck

    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
Le 20/04/2022 à 19:36

Bonsoir,

Le seul problème me parait être l'utilisation de la fonction "Replace" qui concerne des chaînes de caractère alors qu'il s'agit de dates qui sont des nombres dans Excel. Par ailleurs, une indentation correcte de votre code permet une meilleure lisibilité et évite des erreurs de compilation.

ci-dessous code modifié et corectement indenté :

Private Sub CommandButton1_Click()
    Dim rdv As Outlook.AppointmentItem
    Dim calendrier As Outlook.Folder
    Dim t As Task
    Dim pj As Project
    Dim rdvcheck As Outlook.AppointmentItem
    Dim Fournisseur As Outlook.Recipient
    Dim ChoixCategorie As Variant, ChoixExport As Variant
    Set calendrier = dic_calendriers(Me.ComboBox1.Value)

    Set pj = ActiveProject

    If ComboBox3.ListIndex = 0 Then
        Set ChoixExport = ActiveProject
    ElseIf ComboBox3.ListIndex = 1 Then
        Set ChoixExport = ActiveSelection
    End If

    For Each t In ChoixExport.Tasks

        If Me.CheckBox1.Value = True Then
            ChoixCategorie = Me.ComboBox2.Value
        ElseIf Me.CheckBox1.Value = False Then
            ChoixCategorie = t.Text3
        End If

        For Each rdvcheck In calendrier.Items

            If InStr(rdvcheck.Subject, t.Name) <> 0 And InStr(rdvcheck.Categories, ChoixCategorie) <> 0 Then
                rdvcheck.Start = t.Start
                rdvcheck.End = t.Finish
               'rdvcheck.Send
                rdvcheck.Save
                MsgBox rdvcheck.Subject

            ElseIf InStr(rdvcheck.Subject, t.Name) = 0 And InStr(rdvcheck.Categories, ChoixCategorie) = 0 Then

                Set rdv = calendrier.Items.Add

                With rdv
                    .Subject = t.Name
                    .Start = t.Start
                    .End = t.Finish
                    .Categories = ChoixCategorie
                    .Recipients.Add (t.Text1)
                    .Location = t.Text2
                    .MeetingStatus = olMeeting
                    '.Display
                    '.Send
                    .Save
                End With

            End If

        Next rdvcheck

    Next t

End Sub
Le 21/04/2022 à 13:04

Bonjour Thev,

merci d'avoir épurer et corriger le code

les rendez-vous existants se modifient bien, par contre s'ils n'existent pas ( = 0 ) rien ne se passe..

aurais-tu une piste?

Le 21/04/2022 à 20:14

Bonsoir,

par contre s'ils n'existent pas ( = 0 ) rien ne se passe..

Curieux. Je viens de retester et le rendez-vous est bien créé. Du coup, essaie tout simplement de remplacer

ElseIf InStr(rdvcheck.Subject, t.Name) = 0 And InStr(rdvcheck.Categories, ChoixCategorie) = 0 Then

par

Else
Le 22/04/2022 à 00:00

Bonjour Thev,

bizzarement pas beaucoup mieux, en executant la procedure .. j'ai comme senti la soupe chaude

image

j'ai forcé l'arret apres 1 ou 2 secondes

Le 22/04/2022 à 10:30

Bonjour,

ci-dessous un code qui devrait mieux convenir:

Private Sub CommandButton1_Click()
    Dim calendrier As Outlook.Folder
    Dim rdvs_trouvés As Outlook.Items
    Dim rdv As Outlook.AppointmentItem
    Dim filtre As String
    Dim tâche As Task
    Dim pj As Project
    Dim Fournisseur As Outlook.Recipient
    Dim ChoixCategorie As Variant, ChoixExport As Variant
    Dim n As Integer

    Set calendrier = dic_calendriers(Me.ComboBox1.Value)

    Set pj = ActiveProject

    If ComboBox3.ListIndex = 0 Then
        Set ChoixExport = ActiveProject
    ElseIf ComboBox3.ListIndex = 1 Then
        Set ChoixExport = ActiveSelection
    End If

    For Each tâche In ChoixExport.Tasks

        If Me.CheckBox1.Value = True Then
            ChoixCategorie = Me.ComboBox2.Value
        ElseIf Me.CheckBox1.Value = False Then
            ChoixCategorie = tâche.Text3
        End If

        '// recherche des rendez-vous correspondant au nom de la tâche
        filtre = "@SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " like '%" & tâche.Name & "%'"
        Set rdvs_trouvés = calendrier.Items.Restrict(filtre)

        '// analyse des rendez-vous trouvés
        n = 0
        For Each rdv In rdvs_trouvés
            'mise à jour du premier trouvé et suppression des autres
            n = n + 1
            If n = 1 Then
                rdv.Start = tâche.Start
                rdv.End = tâche.Finish
                rdv.Categories = ChoixCategorie
                rdv.Save
            Else
                rdv.Delete
            End If
        Next rdv

        If n = 0 Then
            'ajout du rendez-vous si aucun trouvé
            Set rdv = calendrier.Items.Add

            With rdv
                .Subject = tâche.Name
                .Start = tâche.Start
                .End = tâche.Finish
                .Categories = ChoixCategorie
                .Recipients.Add (tâche.Text1)
                .Location = tâche.Text2
                .MeetingStatus = olMeeting
                '.Display
                '.Send
                .Save
            End With
        End If

    Next tâche

End Sub

NB: Les variables d'une lettre sont en principe réservées aux indices. Pour tout autre variable, utiliser au moins 2 lettres pour leur donner une nomination significative.

Le 22/04/2022 à 15:02

Merci Thev,

le code proposé fonctionne vraiment bien, par contre je dois vérifier 2 critères (categorie), car les noms de rdv sont tous les mêmes c'est la catégorie qui change ..

est-ce que ca serait quelques chose comme ca:

J'Avoue ne pas être familié avec la technique utilisé cette fois-ci

'// recherche des rendez-vous correspondant au nom de la tâche
        filtre = "@SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " like '%" & tâche.Name & "%'"
        filtre2 = "@SQL=" & Chr(34) & "urn:schemas:httpmail:categories" & Chr(34) & " like '%" & ChoixCategorie & "%'"
        Set rdvs_trouvés = calendrier.Items.Restrict(filtre, filtre2)

MERCI!!

Le 22/04/2022 à 18:36

Pour vérifier les 2 critères :

Private Sub CommandButton1_Click()
    Dim calendrier As Outlook.Folder
    Dim rdvs_filtre_1 As Outlook.Items, rdvs_filtres_1_2 As Outlook.Items
    Dim rdv As Outlook.AppointmentItem
    Dim filtre1 As String, filtre2 As String
    Dim tâche As Task
    Dim pj As Project
    Dim Fournisseur As Outlook.Recipient
    Dim ChoixCategorie As Variant, ChoixExport As Variant
    Dim n As Integer

    Set calendrier = dic_calendriers(Me.ComboBox1.Value)

    Set pj = ActiveProject

    If ComboBox3.ListIndex = 0 Then
        Set ChoixExport = ActiveProject
    ElseIf ComboBox3.ListIndex = 1 Then
        Set ChoixExport = ActiveSelection
    End If

    For Each tâche In ChoixExport.Tasks

        If Me.CheckBox1.Value = True Then
            ChoixCategorie = Me.ComboBox2.Value
        ElseIf Me.CheckBox1.Value = False Then
            ChoixCategorie = tâche.Text3
        End If

        '// recherche des rendez-vous correspondant au nom de la tâche et à la catégorie
        filtre1 = "@SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " like '%" & tâche.Name & "%'"
        Set rdvs_filtre_1 = calendrier.Items.Restrict(filtre1)
        filtre2 = " [Categories] = " & Chr(34) & ChoixCategorie & Chr(34)
        Set rdvs_filtres_1_2 = rdvs_filtre_1.Restrict(filtre2)

        '// analyse des rendez-vous trouvés
        n = 0
        For Each rdv In rdvs_filtres_1_2
            'mise à jour du premier trouvé et suppression des autres
            n = n + 1
            If n = 1 Then
                rdv.Start = tâche.Start
                rdv.End = tâche.Finish
                rdv.Categories = ChoixCategorie
                rdv.Save
            Else
                rdv.Delete
            End If
        Next rdv

        If n = 0 Then
            'ajout du rendez-vous si aucun trouvé
            Set rdv = calendrier.Items.Add

            With rdv
                .Subject = tâche.Name
                .Start = tâche.Start
                .End = tâche.Finish
                .Categories = ChoixCategorie
                .Recipients.Add (tâche.Text1)
                .Location = tâche.Text2
                .MeetingStatus = olMeeting
                '.Display
                '.Send
                .Save
            End With
        End If

    Next tâche

End Sub

NB: Le filtre sur le sujet ne peut se faire que via une requête SQL (c'est l'exception) tandis que les autres fonctionnent avec les noms de champ OutlooK

Le 23/04/2022 à 06:51

Super,

je passe ce sujet en résolu.

Merci pour tes judicieux conseils, ton aide m'est très précieuse!

Rechercher des sujets similaires à "mise jour appointment outlook"