Supprimer des rendez-vous outlook 2016 via excel
karinoss
Messages postés
3
Statut
Membre
-
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
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
1 réponse
-
Bonjour,
Voir ceci:
http://www.rechercheunbondeveloppeur.com/2014/06/gerer-rendez-vous-outlook-depuis-Excel-avec-vba.php
-
-
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 -
-
