Supprimer des rendez-vous outlook 2016 via excel

karinoss Messages postés 3 Statut Membre -  
karinoss Messages postés 3 Statut Membre -
Bonjour,

Je me permets de vous contacter, car j'ai trouvé sur le forum une macro que j'ai su adapter à mon besoin pour la création et la maj des rdv sur outlook via excel

Par contre je voudrais les supprimer et je ne sais pas comment faire,

Je suis une grande débutante en vba

Voila la macro et je remercie grandement son créateur
-------
<ital>Private Sub Worksheet_Change(ByVal Target As Range)
If UCase(Target) = "OUI" Then
Dim OlApp As Outlook.Application

Dim olAppItem As Outlook.AppointmentItem

Set OlApp = GetObject("", "Outlook.Application")

Set olAppItem = OlApp.CreateItem(olAppointmentItem)

With olAppItem

.Start = Range("c" & Target.Row).Value
.Subject = Range("g" & Target.Row).Value
.Location = Range("h" & Target.Row).Value
.Body = Range("k" & Target.Row).Value
.Duration = 60
.ReminderSet = True
.Save

End With
End If
If UCase(Target) = "TERMINE" Then
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myOlApp.ActiveExplorer.CurrentFolder = myNameSpace.GetDefaultFolder(olFolderCalendar)
Set outlookitems = myOlApp.ActiveExplorer.CurrentFolder.Items
Cpte = outlookitems.Count

For x = 1 To Cpte
'exemple de test : si le sujet est "toto" alors on supprime le rdv
If outlookitems(x).Subject = Range("g" & Target.Row).Value Then
outlookitems(x).Delete
End If
Next x
End If
If UCase(Target) = "TERMINE" Then

Set OlApp = GetObject("", "Outlook.Application")

Set olAppItem = OlApp.CreateItem(olAppointmentItem)

With olAppItem
.Start = Range("c" & Target.Row).Value
.Subject = Range("g" & Target.Row).Value
.Location = Range("h" & Target.Row).Value
.Body = Range("k" & Target.Row).Value
.Duration = 60
.ReminderSet = True
.Save

End With
End If
End Sub

<ital>--------------------------------------------------------

Dans la macro il y a
For x = 1 To Cpte
'exemple de test : si le sujet est "toto" alors on supprime le rdv
If outlookitems(x).Subject = Range("g" & Target.Row).Value Then
outlookitems(x).Delete
End If
Next x
End If

partie que je n'ai pas su adapter à mon fichier

une vision de mon fichier



Merci beaucoup à la ou les personnes qui prendront le temps de lire ma demande

Je vous souhaite une agréable journée
A voir également:

1 réponse

Réponse 1 / 1
cs_Le Pivert Messages postés 8437 Statut Contributeur 729
 
Bonjour,

Voir ceci:

http://www.rechercheunbondeveloppeur.com/2014/06/gerer-rendez-vous-outlook-depuis-Excel-avec-vba.php
0
karinoss Messages postés 3 Statut Membre
 
Merci d'avoir pris le temps, j'irai voir
@+ Karinoss

Si quelqu'un a la réponse concrête à ma demande je suis preneuse
A bientot
0
cs_Le Pivert Messages postés 8437 Statut Contributeur 729
 
Si tu veux du concret, voilà du concret suivant le site cité plus haut. A toi de l'adapter a tes données: 

Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Application.Intersect(Target, Range("K2:K3")) Is Nothing Then
On Error Resume Next
If Target.Value = "OUI" Then
Dim oOutlook As Outlook.Application
    Dim oAppointment As Outlook.AppointmentItem
    Dim namespaceOutlook As Outlook.Namespace
    Dim DossierCalendrier As Outlook.MAPIFolder
 'gestion d'erreurs
    On Error GoTo Err_Execution
    'on crée ensuite les objets
    Set oOutlook = CreateObject("Outlook.Application")
    Set namespaceOutlook = oOutlook.GetNamespace("MAPI")

    'définit le dossier calendrier
    'GetDefaultFolder renvoit le calendrier du compte actif
    Set DossierCalendrier = namespaceOutlook.GetDefaultFolder(olFolderCalendar)
    
    'on crée un nouveau rendez-vous
    Set oAppointment = DossierCalendrier.Items.Add
    
    'on renseigne ensuite les principaux paramètres
    With oAppointment
        .Start = "21/03/2018  15:30:00"
        .Subject = Range("g" & Target.Row).Value
        .Location = Range("h" & Target.Row).Value
        .Body = Range("k" & Target.Row).Value
        .Duration = 60
        .ReminderSet = True
        .Save
        .Close (olSave)
    End With
    
    'Libération des variables.
    Set oAppointment = Nothing
    Set oOutlook = Nothing
    MsgBox "RDV réussi"
'Fin_Execution:
    Exit Sub
'Err_Execution:
    MsgBox Err.Description, vbExclamation
    Resume Fin_Execution
ElseIf Target.Value = "TERMINER" Then
'déclaration des variables
  'on déclare un objet collection qui va contenir tous les rdv correspondat aux critères de filtre
    Dim collectionAppointments As Outlook.Items
    Dim sFilter As String
    'gestion d'erreurs
   ' On Error GoTo Err_Execution
    
    'on crée ensuite les objets
    Set oOutlook = CreateObject("Outlook.Application")
    Set namespaceOutlook = oOutlook.GetNamespace("MAPI")

    'définit le dossier calendrier
    Set DossierCalendrier = namespaceOutlook.GetDefaultFolder(olFolderCalendar)

    'on définit les critères de filtre
    'la date doit être formaté au format Outlook
    sFilter = "[Start] > '" & Format("21/03/2018  15:30:00", "ddddd h:nn AMPM") & "'"
    
    'on recupère tous les rdv correspondant aux critères avec la méthode restrict
    Set collectionAppointments = DossierCalendrier.Items.Restrict(sFilter)
    
    'boucle sur tous les rdv trouvés
    For Each oAppointment In collectionAppointments
        'si le sujet correspond on supprime le rdv
        If oAppointment.Subject = "TOTO" Then
            oAppointment.Delete
        End If
    Next

    'Libération des variables.
    Set oAppointment = Nothing
    Set oOutlook = Nothing
MsgBox "RDV supprimé"
Fin_Execution:
    Exit Sub
Err_Execution:
    MsgBox Err.Description, vbExclamation
    Resume Fin_Execution

End If
End If
End Sub



@+ Le Pivert
0
karinoss Messages postés 3 Statut Membre
 
Bonjour, grand grand merci @Le Pivert, je teste dans la journée
@+ Karinoss
0