Twitter iPhone pliant OnePlus 11 PS5 Disney+ Orange Livebox Windows 11

Suppression de RDV dans Outlook.

7 réponses
Avatar
Poulpor
Code trouvé sous
:http://www.vbfrance.com/codes/OUTLOOK-ENVOI-MAIL-AJOUT-MODIFICATION-SUPRRESION-RENDEZ-VOUS_30302.aspx

Bonjour,

J'ai donc adapté ce code pour détruire des rendez-vous dans Outlook depuis
Excel :
En gros :
- je filtre les rendez-vous entre deux dates
- je teste chaque rendez-vous pour savoir si je le détruis par rapport à mes
critères
- si oui, je détruis et je passe au suivant
- si non, je passe au suivant

Le problème vient du fait que lorsque j'ai N RDV détruits, le while ne
balaie pas les N derniers rendez-vous, trouvant 'Nothing' prématurément.

J'ai beau essayer de chercher des exemples, réfléchir par d'autres moyens
(les rdv sont taggués par EntryID, conditionner Findnext qu'à la destruction
du rdv), c'est un échec cuisant d'une journée que nous dirons stérile.

La seule similtude avec un autre problème est la destruction de lignes dans
Excel : il est plus facile de commencer de la dernière et de remonter

Alors si quelqu'un a des idées, je suis tres preneur.






Sub SupprRDV(SERVICE)

Dim objOutlook As New Outlook.Application
Dim objOutlookAppt As Outlook.AppointmentItem
Dim objOutlookCalendar As Outlook.Items
Dim objOutlookNameSpace As Outlook.NameSpace
Dim DateDebut, DateFin As Date
Dim Compteur As Integer

Compteur = 0


Set objOutlookNameSpace = objOutlook.GetNamespace("MAPI")
Set objOutlookCalendar =
objOutlookNameSpace.GetDefaultFolder(olFolderCalendar).Items
objOutlookCalendar.Sort "[Start]"
objOutlookCalendar.IncludeRecurrences = True



DateDebut = Sheets("Calendrier").Cells(8, 6).Value
DateFin = DateSerial(Year(DateDebut), Month(DateDebut) + 1, 1) - 1

Set objOutlookAppt = objOutlookCalendar.Find("[Start] >= """ & DateDebut
& """ and [Start] <= """ & DateFin & """ ")

While TypeName(objOutlookAppt) <> "Nothing"

If objOutlookAppt.Categories = "Suivi Calendrier" And
Left(objOutlookAppt.Subject, Len(SERVICE)) = SERVICE Then
objOutlookAppt.Delete
Compteur = Compteur + 1
End If
Set objOutlookAppt = objOutlookCalendar.FindNext

Wend

MsgBox Compteur & " rendez-vous supprimé(s)"

End Sub

7 réponses

Avatar
JLuc
*Bonjour Poulpor*,
J'ai tenté de récuperer le code, mais cette ligne me pose des
problèmes. Comment l'as tu modifiée ?
Set objOutlookAppt = objOutlookCalendar.Find("[Start] >= " " " &
DateDebut & " " " and [Start] <= " " " & DateFin & " " " ")


Code trouvé sous
http://www.vbfrance.com/codes/OUTLOOK-ENVOI-MAIL-AJOUT-MODIFICATION-SUPRRESION-RENDEZ-VOUS_30302.aspx


Bonjour,

J'ai donc adapté ce code pour détruire des rendez-vous dans Outlook depuis
Excel :
En gros :
- je filtre les rendez-vous entre deux dates
- je teste chaque rendez-vous pour savoir si je le détruis par rapport à mes
critères
- si oui, je détruis et je passe au suivant
- si non, je passe au suivant

Le problème vient du fait que lorsque j'ai N RDV détruits, le while ne
balaie pas les N derniers rendez-vous, trouvant 'Nothing' prématurément.

J'ai beau essayer de chercher des exemples, réfléchir par d'autres moyens
(les rdv sont taggués par EntryID, conditionner Findnext qu'à la destruction
du rdv), c'est un échec cuisant d'une journée que nous dirons stérile.

La seule similtude avec un autre problème est la destruction de lignes dans
Excel : il est plus facile de commencer de la dernière et de remonter

Alors si quelqu'un a des idées, je suis tres preneur.






Sub SupprRDV(SERVICE)

Dim objOutlook As New Outlook.Application
Dim objOutlookAppt As Outlook.AppointmentItem
Dim objOutlookCalendar As Outlook.Items
Dim objOutlookNameSpace As Outlook.NameSpace
Dim DateDebut, DateFin As Date
Dim Compteur As Integer

Compteur = 0


Set objOutlookNameSpace = objOutlook.GetNamespace("MAPI")
Set objOutlookCalendar =
objOutlookNameSpace.GetDefaultFolder(olFolderCalendar).Items
objOutlookCalendar.Sort "[Start]"
objOutlookCalendar.IncludeRecurrences = True



DateDebut = Sheets("Calendrier").Cells(8, 6).Value
DateFin = DateSerial(Year(DateDebut), Month(DateDebut) + 1, 1) - 1

Set objOutlookAppt = objOutlookCalendar.Find("[Start] >= """ & DateDebut
& """ and [Start] <= """ & DateFin & """ ")

While TypeName(objOutlookAppt) <> "Nothing"

If objOutlookAppt.Categories = "Suivi Calendrier" And
Left(objOutlookAppt.Subject, Len(SERVICE)) = SERVICE Then
objOutlookAppt.Delete
Compteur = Compteur + 1
End If
Set objOutlookAppt = objOutlookCalendar.FindNext

Wend

MsgBox Compteur & " rendez-vous supprimé(s)"

End Sub


--
____
( O | O )
--
_oooO_ JLuc _Oooo_

O-O


Avatar
Poulpor
Bonjour Jean-Luc,

J'ai eu aussi des problèmes en récupérant le code. C'était juste un problème
d'espace.

J'ai mis le fichier sur cjoint : http://cjoint.com/?fhxbHzcK8P

J'essaie toujours de voir comment contourner le probléme. Ca peut être tres
sympa comme fonction pour un agenda.


Poulpor


*Bonjour Poulpor*,
J'ai tenté de récuperer le code, mais cette ligne me pose des
problèmes. Comment l'as tu modifiée ?
Set objOutlookAppt = objOutlookCalendar.Find("[Start] >= " " " &
DateDebut & " " " and [Start] <= " " " & DateFin & " " " ")


Code trouvé sous
http://www.vbfrance.com/codes/OUTLOOK-ENVOI-MAIL-AJOUT-MODIFICATION-SUPRRESION-RENDEZ-VOUS_30302.aspx


Bonjour,

J'ai donc adapté ce code pour détruire des rendez-vous dans Outlook depuis
Excel :
En gros :
- je filtre les rendez-vous entre deux dates
- je teste chaque rendez-vous pour savoir si je le détruis par rapport à mes
critères
- si oui, je détruis et je passe au suivant
- si non, je passe au suivant

Le problème vient du fait que lorsque j'ai N RDV détruits, le while ne
balaie pas les N derniers rendez-vous, trouvant 'Nothing' prématurément.

J'ai beau essayer de chercher des exemples, réfléchir par d'autres moyens
(les rdv sont taggués par EntryID, conditionner Findnext qu'à la destruction
du rdv), c'est un échec cuisant d'une journée que nous dirons stérile.

La seule similtude avec un autre problème est la destruction de lignes dans
Excel : il est plus facile de commencer de la dernière et de remonter

Alors si quelqu'un a des idées, je suis tres preneur.






Sub SupprRDV(SERVICE)

Dim objOutlook As New Outlook.Application
Dim objOutlookAppt As Outlook.AppointmentItem
Dim objOutlookCalendar As Outlook.Items
Dim objOutlookNameSpace As Outlook.NameSpace
Dim DateDebut, DateFin As Date
Dim Compteur As Integer

Compteur = 0


Set objOutlookNameSpace = objOutlook.GetNamespace("MAPI")
Set objOutlookCalendar =
objOutlookNameSpace.GetDefaultFolder(olFolderCalendar).Items
objOutlookCalendar.Sort "[Start]"
objOutlookCalendar.IncludeRecurrences = True



DateDebut = Sheets("Calendrier").Cells(8, 6).Value
DateFin = DateSerial(Year(DateDebut), Month(DateDebut) + 1, 1) - 1

Set objOutlookAppt = objOutlookCalendar.Find("[Start] >= """ & DateDebut
& """ and [Start] <= """ & DateFin & """ ")

While TypeName(objOutlookAppt) <> "Nothing"

If objOutlookAppt.Categories = "Suivi Calendrier" And
Left(objOutlookAppt.Subject, Len(SERVICE)) = SERVICE Then
objOutlookAppt.Delete
Compteur = Compteur + 1
End If
Set objOutlookAppt = objOutlookCalendar.FindNext

Wend

MsgBox Compteur & " rendez-vous supprimé(s)"

End Sub


--
____
( O | O )
--
_oooO_ JLuc _Oooo_

O-O







Avatar
JLuc
*Bonjour Poulpor*,
J'ai fini par réussir à adapter le code ;-)
Je ne me suis pas encore penché sur ton classeur (çà viendra)
Mais voici le code épuré et je n'ai pas de soucis en fin de boucle

Sub Essai()
'Supprimer un rdv du calendrier

Dim objOutlook As New Outlook.Application
Dim objOutlookAppt As Outlook.AppointmentItem
Dim objOutlookCalendar As Outlook.Items
Dim objOutlookNameSpace As Outlook.NameSpace
Dim DateDebut As String, DateFin As String

Set objOutlookNameSpace = objOutlook.GetNameSpace("MAPI")
Set objOutlookCalendar =
objOutlookNameSpace.GetDefaultFolder(olFolderCalendar).Items
objOutlookCalendar.Sort "[Start]"
'objOutlookCalendar.IncludeReccurrences = True

DateDebut = "01/05/2007 12:00"
DateFin = "31/05/2007 12:00"

Set objOutlookAppt = objOutlookCalendar.Find("[Start] >= '" &
DateDebut & "' and [Start] <= '" & _
DateFin & "'")

While TypeName(objOutlookAppt) <> "Nothing"
If objOutlookAppt.Subject = "RDV recherché pour supprimé" Then
objOutlookAppt.Delete
End If
Set objOutlookAppt = objOutlookCalendar.FindNext
Wend
End Sub

Je sais pas encore si cela peut t'aider, mais c'est toujours un premier
jet :')

Bonjour Jean-Luc,

J'ai eu aussi des problèmes en récupérant le code. C'était juste un problème
d'espace.

J'ai mis le fichier sur cjoint : http://cjoint.com/?fhxbHzcK8P

J'essaie toujours de voir comment contourner le probléme. Ca peut être tres
sympa comme fonction pour un agenda.


Poulpor


--
____
( O | O )
--
_oooO_ JLuc _Oooo_

O-O

Avatar
JLuc
*Bonjour Poulpor*,
J'ai trouvé d'où vient le problème, mais je ne saurai pas te dire le
pourquoi du comment... :/
Cette solution vient du fait que, losque j'ai essayé le code
téléchargé, cette instruction ne passait pas donc je l'avais mise en
commentaire :

objOutlookCalendar.IncludeReccurrences = True

Dans ton code, j'ai fais pareil et çà marche.
J'ai regardé l'aide sur cette instruction, mais c'est assez opaque
Dis moi ce qu'il en est pour toi

Bonjour Jean-Luc,

J'ai eu aussi des problèmes en récupérant le code. C'était juste un problème
d'espace.

J'ai mis le fichier sur cjoint : http://cjoint.com/?fhxbHzcK8P

J'essaie toujours de voir comment contourner le probléme. Ca peut être tres
sympa comme fonction pour un agenda.


Poulpor


*Bonjour Poulpor*,
J'ai tenté de récuperer le code, mais cette ligne me pose des
problèmes. Comment l'as tu modifiée ?
Set objOutlookAppt = objOutlookCalendar.Find("[Start] >= " " " &
DateDebut & " " " and [Start] <= " " " & DateFin & " " " ")


Code trouvé sous
http://www.vbfrance.com/codes/OUTLOOK-ENVOI-MAIL-AJOUT-MODIFICATION-SUPRRESION-RENDEZ-VOUS_30302.aspx


Bonjour,

J'ai donc adapté ce code pour détruire des rendez-vous dans Outlook depuis
Excel :
En gros :
- je filtre les rendez-vous entre deux dates
- je teste chaque rendez-vous pour savoir si je le détruis par rapport à
mes critères
- si oui, je détruis et je passe au suivant
- si non, je passe au suivant

Le problème vient du fait que lorsque j'ai N RDV détruits, le while ne
balaie pas les N derniers rendez-vous, trouvant 'Nothing' prématurément.

J'ai beau essayer de chercher des exemples, réfléchir par d'autres moyens
(les rdv sont taggués par EntryID, conditionner Findnext qu'à la
destruction du rdv), c'est un échec cuisant d'une journée que nous dirons
stérile.

La seule similtude avec un autre problème est la destruction de lignes dans
Excel : il est plus facile de commencer de la dernière et de remonter

Alors si quelqu'un a des idées, je suis tres preneur.






Sub SupprRDV(SERVICE)

Dim objOutlook As New Outlook.Application
Dim objOutlookAppt As Outlook.AppointmentItem
Dim objOutlookCalendar As Outlook.Items
Dim objOutlookNameSpace As Outlook.NameSpace
Dim DateDebut, DateFin As Date
Dim Compteur As Integer

Compteur = 0


Set objOutlookNameSpace = objOutlook.GetNamespace("MAPI")
Set objOutlookCalendar =
objOutlookNameSpace.GetDefaultFolder(olFolderCalendar).Items
objOutlookCalendar.Sort "[Start]"
objOutlookCalendar.IncludeRecurrences = True



DateDebut = Sheets("Calendrier").Cells(8, 6).Value
DateFin = DateSerial(Year(DateDebut), Month(DateDebut) + 1, 1) - 1

Set objOutlookAppt = objOutlookCalendar.Find("[Start] >= """ &
DateDebut & """ and [Start] <= """ & DateFin & """ ")

While TypeName(objOutlookAppt) <> "Nothing"

If objOutlookAppt.Categories = "Suivi Calendrier" And
Left(objOutlookAppt.Subject, Len(SERVICE)) = SERVICE Then
objOutlookAppt.Delete
Compteur = Compteur + 1
End If
Set objOutlookAppt = objOutlookCalendar.FindNext

Wend

MsgBox Compteur & " rendez-vous supprimé(s)"

End Sub


--
____
( O | O )
--
_oooO_ JLuc _Oooo_

O-O






--
____
( O | O )
--
_oooO_ JLuc _Oooo_

O-O




Avatar
Poulpor
Bonsoir Jean-Luc,

Je e propose un test :

- telecharge mon fichier : http://cjoint.com/?fhxbHzcK8P" target="_blank" class="text-blue hover:opacity-90 " style="word-break: break-all;" rel="noopener nofollow">http://cjoint.com/?fhxbHzcK8P
- ajoute les rdv pour le service Financier (FIN)
- supprime les. Tu verras que le nombre de rdv créés n'est pas égal au
nombre de rdv détruits.

Pour objOutlookCalendar.IncludeReccurrences = True, j'ai du aussi corriger
le problème (on ne va quand meme pas tomber sur le bonhomme qui a eu la
gentillesse de partager son code).

Je pense m'y remettre demain. Si j'ai une piste, promis je poste la
solution...mais je ne mes sens pas du tout confiant.

Poulpor


*Bonjour Poulpor*,
J'ai trouvé d'où vient le problème, mais je ne saurai pas te dire le
pourquoi du comment... :/
Cette solution vient du fait que, losque j'ai essayé le code
téléchargé, cette instruction ne passait pas donc je l'avais mise en
commentaire :

objOutlookCalendar.IncludeReccurrences = True

Dans ton code, j'ai fais pareil et çà marche.
J'ai regardé l'aide sur cette instruction, mais c'est assez opaque
Dis moi ce qu'il en est pour toi

Bonjour Jean-Luc,

J'ai eu aussi des problèmes en récupérant le code. C'était juste un problème
d'espace.

J'ai mis le fichier sur cjoint : http://cjoint.com/?fhxbHzcK8P" target="_blank" class="text-blue hover:opacity-90 " style="word-break: break-all;" rel="noopener nofollow">http://cjoint.com/?fhxbHzcK8P

J'essaie toujours de voir comment contourner le probléme. Ca peut être tres
sympa comme fonction pour un agenda.


Poulpor


*Bonjour Poulpor*,
J'ai tenté de récuperer le code, mais cette ligne me pose des
problèmes. Comment l'as tu modifiée ?
Set objOutlookAppt = objOutlookCalendar.Find("[Start] >= " " " &
DateDebut & " " " and [Start] <= " " " & DateFin & " " " ")


Code trouvé sous
http://www.vbfrance.com/codes/OUTLOOK-ENVOI-MAIL-AJOUT-MODIFICATION-SUPRRESION-RENDEZ-VOUS_30302.aspx


Bonjour,

J'ai donc adapté ce code pour détruire des rendez-vous dans Outlook depuis
Excel :
En gros :
- je filtre les rendez-vous entre deux dates
- je teste chaque rendez-vous pour savoir si je le détruis par rapport à
mes critères
- si oui, je détruis et je passe au suivant
- si non, je passe au suivant

Le problème vient du fait que lorsque j'ai N RDV détruits, le while ne
balaie pas les N derniers rendez-vous, trouvant 'Nothing' prématurément.

J'ai beau essayer de chercher des exemples, réfléchir par d'autres moyens
(les rdv sont taggués par EntryID, conditionner Findnext qu'à la
destruction du rdv), c'est un échec cuisant d'une journée que nous dirons
stérile.

La seule similtude avec un autre problème est la destruction de lignes dans
Excel : il est plus facile de commencer de la dernière et de remonter

Alors si quelqu'un a des idées, je suis tres preneur.






Sub SupprRDV(SERVICE)

Dim objOutlook As New Outlook.Application
Dim objOutlookAppt As Outlook.AppointmentItem
Dim objOutlookCalendar As Outlook.Items
Dim objOutlookNameSpace As Outlook.NameSpace
Dim DateDebut, DateFin As Date
Dim Compteur As Integer

Compteur = 0


Set objOutlookNameSpace = objOutlook.GetNamespace("MAPI")
Set objOutlookCalendar =
objOutlookNameSpace.GetDefaultFolder(olFolderCalendar).Items
objOutlookCalendar.Sort "[Start]"
objOutlookCalendar.IncludeRecurrences = True



DateDebut = Sheets("Calendrier").Cells(8, 6).Value
DateFin = DateSerial(Year(DateDebut), Month(DateDebut) + 1, 1) - 1

Set objOutlookAppt = objOutlookCalendar.Find("[Start] >= """ &
DateDebut & """ and [Start] <= """ & DateFin & """ ")

While TypeName(objOutlookAppt) <> "Nothing"

If objOutlookAppt.Categories = "Suivi Calendrier" And
Left(objOutlookAppt.Subject, Len(SERVICE)) = SERVICE Then
objOutlookAppt.Delete
Compteur = Compteur + 1
End If
Set objOutlookAppt = objOutlookCalendar.FindNext

Wend

MsgBox Compteur & " rendez-vous supprimé(s)"

End Sub


--
____
( O | O )
--
_oooO_ JLuc _Oooo_

O-O






--
____
( O | O )
--
_oooO_ JLuc _Oooo_

O-O









Avatar
JLuc
*Bonjour Poulpor*,

Bonsoir Jean-Luc,

Je e propose un test :

- telecharge mon fichier : http://cjoint.com/?fhxbHzcK8P" target="_blank" class="text-blue hover:opacity-90 " style="word-break: break-all;" rel="noopener nofollow">http://cjoint.com/?fhxbHzcK8P
C'est re-fait


- ajoute les rdv pour le service Financier (FIN)
Ok, 14 rdv ajoutés


- supprime les. Tu verras que le nombre de rdv créés n'est pas égal au
nombre de rdv détruits.
C'est vrai !



Pour objOutlookCalendar.IncludeReccurrences = True, j'ai du aussi corriger
le problème (on ne va quand meme pas tomber sur le bonhomme qui a eu la
gentillesse de partager son code).
Après avoir mis cette ligne en commentaire, plus de problèmes ;-)

Perso j'ai Office 2000, peut être des différences ??? Mais je ne crois
pas ;o)


Je pense m'y remettre demain. Si j'ai une piste, promis je poste la
solution...mais je ne mes sens pas du tout confiant.


Voici le code tel qu'il fonctionne chez moi :

Sub SupprRDV(SERVICE)

Dim objOutlook As New Outlook.Application
Dim objOutlookAppt As Outlook.AppointmentItem
Dim objOutlookCalendar As Outlook.Items
Dim objOutlookNameSpace As Outlook.NameSpace
Dim DateDebut, DateFin As Date
Dim Compteur As Integer

Compteur = 0

'On Error Resume Next

Set objOutlookNameSpace = objOutlook.GetNamespace("MAPI")
Set objOutlookCalendar =
objOutlookNameSpace.GetDefaultFolder(olFolderCalendar).Items
objOutlookCalendar.Sort "[Start]"
' objOutlookCalendar.IncludeRecurrences = True



DateDebut = Sheets("Calendrier").Cells(8, 6).Value
DateFin = DateSerial(Year(DateDebut), Month(DateDebut) + 1, 1) - 1

Set objOutlookAppt = objOutlookCalendar.Find("[Start] >= """ &
DateDebut & """ and [Start] <= """ & DateFin & """ ")
While TypeName(objOutlookAppt) <> "Nothing"

If objOutlookAppt.Categories = "Suivi Calendrier" And
Left(objOutlookAppt.Subject, Len(SERVICE)) = SERVICE Then
objOutlookAppt.Delete
Compteur = Compteur + 1
End If
Set objOutlookAppt = objOutlookCalendar.FindNext

Wend

MsgBox Compteur & " rendez-vous supprimé(s)"

End Sub



Poulpor


*Bonjour Poulpor*,
J'ai trouvé d'où vient le problème, mais je ne saurai pas te dire le
pourquoi du comment... :/
Cette solution vient du fait que, losque j'ai essayé le code
téléchargé, cette instruction ne passait pas donc je l'avais mise en
commentaire :

objOutlookCalendar.IncludeReccurrences = True

Dans ton code, j'ai fais pareil et çà marche.
J'ai regardé l'aide sur cette instruction, mais c'est assez opaque
Dis moi ce qu'il en est pour toi

Bonjour Jean-Luc,

J'ai eu aussi des problèmes en récupérant le code. C'était juste un
problème d'espace.

J'ai mis le fichier sur cjoint : http://cjoint.com/?fhxbHzcK8P" target="_blank" class="text-blue hover:opacity-90 " style="word-break: break-all;" rel="noopener nofollow">http://cjoint.com/?fhxbHzcK8P

J'essaie toujours de voir comment contourner le probléme. Ca peut être tres
sympa comme fonction pour un agenda.


Poulpor


*Bonjour Poulpor*,
J'ai tenté de récuperer le code, mais cette ligne me pose des
problèmes. Comment l'as tu modifiée ?
Set objOutlookAppt = objOutlookCalendar.Find("[Start] >= " " " &
DateDebut & " " " and [Start] <= " " " & DateFin & " " " ")


Code trouvé sous
http://www.vbfrance.com/codes/OUTLOOK-ENVOI-MAIL-AJOUT-MODIFICATION-SUPRRESION-RENDEZ-VOUS_30302.aspx


Bonjour,

J'ai donc adapté ce code pour détruire des rendez-vous dans Outlook
depuis Excel :
En gros :
- je filtre les rendez-vous entre deux dates
- je teste chaque rendez-vous pour savoir si je le détruis par rapport à
mes critères
- si oui, je détruis et je passe au suivant
- si non, je passe au suivant

Le problème vient du fait que lorsque j'ai N RDV détruits, le while ne
balaie pas les N derniers rendez-vous, trouvant 'Nothing' prématurément.

J'ai beau essayer de chercher des exemples, réfléchir par d'autres moyens
(les rdv sont taggués par EntryID, conditionner Findnext qu'à la
destruction du rdv), c'est un échec cuisant d'une journée que nous
dirons stérile.

La seule similtude avec un autre problème est la destruction de lignes
dans Excel : il est plus facile de commencer de la dernière et de
remonter

Alors si quelqu'un a des idées, je suis tres preneur.






Sub SupprRDV(SERVICE)

Dim objOutlook As New Outlook.Application
Dim objOutlookAppt As Outlook.AppointmentItem
Dim objOutlookCalendar As Outlook.Items
Dim objOutlookNameSpace As Outlook.NameSpace
Dim DateDebut, DateFin As Date
Dim Compteur As Integer

Compteur = 0


Set objOutlookNameSpace = objOutlook.GetNamespace("MAPI")
Set objOutlookCalendar =
objOutlookNameSpace.GetDefaultFolder(olFolderCalendar).Items
objOutlookCalendar.Sort "[Start]"
objOutlookCalendar.IncludeRecurrences = True



DateDebut = Sheets("Calendrier").Cells(8, 6).Value
DateFin = DateSerial(Year(DateDebut), Month(DateDebut) + 1, 1) - 1

Set objOutlookAppt = objOutlookCalendar.Find("[Start] >= """ &
DateDebut & """ and [Start] <= """ & DateFin & """ ")

While TypeName(objOutlookAppt) <> "Nothing"

If objOutlookAppt.Categories = "Suivi Calendrier" And
Left(objOutlookAppt.Subject, Len(SERVICE)) = SERVICE Then
objOutlookAppt.Delete
Compteur = Compteur + 1
End If
Set objOutlookAppt = objOutlookCalendar.FindNext

Wend

MsgBox Compteur & " rendez-vous supprimé(s)"

End Sub


--
____
( O | O )
--
_oooO_ JLuc _Oooo_

O-O






--
____
( O | O )
--
_oooO_ JLuc _Oooo_

O-O






--
____
( O | O )
--
_oooO_ JLuc _Oooo_

O-O






Avatar
Poulpor
Bonjour JLuc

T'es un vrai acrobate d'excel ! Ca marche en effet : c'est ce
'IncludeRecurrences' qu'il fallait désactiver. Ceci étant, je ne comprends
pas trop ce que cela peut changer.

En tout cas, un gros merci à toi.

Poulpor.


*Bonjour Poulpor*,

Bonsoir Jean-Luc,

Je e propose un test :

- telecharge mon fichier : http://cjoint.com/?fhxbHzcK8P" target="_blank" class="text-blue hover:opacity-90 " style="word-break: break-all;" rel="noopener nofollow">http://cjoint.com/?fhxbHzcK8P
C'est re-fait


- ajoute les rdv pour le service Financier (FIN)
Ok, 14 rdv ajoutés


- supprime les. Tu verras que le nombre de rdv créés n'est pas égal au
nombre de rdv détruits.
C'est vrai !



Pour objOutlookCalendar.IncludeReccurrences = True, j'ai du aussi corriger
le problème (on ne va quand meme pas tomber sur le bonhomme qui a eu la
gentillesse de partager son code).
Après avoir mis cette ligne en commentaire, plus de problèmes ;-)

Perso j'ai Office 2000, peut être des différences ??? Mais je ne crois
pas ;o)


Je pense m'y remettre demain. Si j'ai une piste, promis je poste la
solution...mais je ne mes sens pas du tout confiant.


Voici le code tel qu'il fonctionne chez moi :

Sub SupprRDV(SERVICE)

Dim objOutlook As New Outlook.Application
Dim objOutlookAppt As Outlook.AppointmentItem
Dim objOutlookCalendar As Outlook.Items
Dim objOutlookNameSpace As Outlook.NameSpace
Dim DateDebut, DateFin As Date
Dim Compteur As Integer

Compteur = 0

'On Error Resume Next

Set objOutlookNameSpace = objOutlook.GetNamespace("MAPI")
Set objOutlookCalendar =
objOutlookNameSpace.GetDefaultFolder(olFolderCalendar).Items
objOutlookCalendar.Sort "[Start]"
' objOutlookCalendar.IncludeRecurrences = True



DateDebut = Sheets("Calendrier").Cells(8, 6).Value
DateFin = DateSerial(Year(DateDebut), Month(DateDebut) + 1, 1) - 1

Set objOutlookAppt = objOutlookCalendar.Find("[Start] >= """ &
DateDebut & """ and [Start] <= """ & DateFin & """ ")
While TypeName(objOutlookAppt) <> "Nothing"

If objOutlookAppt.Categories = "Suivi Calendrier" And
Left(objOutlookAppt.Subject, Len(SERVICE)) = SERVICE Then
objOutlookAppt.Delete
Compteur = Compteur + 1
End If
Set objOutlookAppt = objOutlookCalendar.FindNext

Wend

MsgBox Compteur & " rendez-vous supprimé(s)"

End Sub



Poulpor


*Bonjour Poulpor*,
J'ai trouvé d'où vient le problème, mais je ne saurai pas te dire le
pourquoi du comment... :/
Cette solution vient du fait que, losque j'ai essayé le code
téléchargé, cette instruction ne passait pas donc je l'avais mise en
commentaire :

objOutlookCalendar.IncludeReccurrences = True

Dans ton code, j'ai fais pareil et çà marche.
J'ai regardé l'aide sur cette instruction, mais c'est assez opaque
Dis moi ce qu'il en est pour toi

Bonjour Jean-Luc,

J'ai eu aussi des problèmes en récupérant le code. C'était juste un
problème d'espace.

J'ai mis le fichier sur cjoint : http://cjoint.com/?fhxbHzcK8P" target="_blank" class="text-blue hover:opacity-90 " style="word-break: break-all;" rel="noopener nofollow">http://cjoint.com/?fhxbHzcK8P

J'essaie toujours de voir comment contourner le probléme. Ca peut être tres
sympa comme fonction pour un agenda.


Poulpor


*Bonjour Poulpor*,
J'ai tenté de récuperer le code, mais cette ligne me pose des
problèmes. Comment l'as tu modifiée ?
Set objOutlookAppt = objOutlookCalendar.Find("[Start] >= " " " &
DateDebut & " " " and [Start] <= " " " & DateFin & " " " ")


Code trouvé sous
http://www.vbfrance.com/codes/OUTLOOK-ENVOI-MAIL-AJOUT-MODIFICATION-SUPRRESION-RENDEZ-VOUS_30302.aspx


Bonjour,

J'ai donc adapté ce code pour détruire des rendez-vous dans Outlook
depuis Excel :
En gros :
- je filtre les rendez-vous entre deux dates
- je teste chaque rendez-vous pour savoir si je le détruis par rapport à
mes critères
- si oui, je détruis et je passe au suivant
- si non, je passe au suivant

Le problème vient du fait que lorsque j'ai N RDV détruits, le while ne
balaie pas les N derniers rendez-vous, trouvant 'Nothing' prématurément.

J'ai beau essayer de chercher des exemples, réfléchir par d'autres moyens
(les rdv sont taggués par EntryID, conditionner Findnext qu'à la
destruction du rdv), c'est un échec cuisant d'une journée que nous
dirons stérile.

La seule similtude avec un autre problème est la destruction de lignes
dans Excel : il est plus facile de commencer de la dernière et de
remonter

Alors si quelqu'un a des idées, je suis tres preneur.






Sub SupprRDV(SERVICE)

Dim objOutlook As New Outlook.Application
Dim objOutlookAppt As Outlook.AppointmentItem
Dim objOutlookCalendar As Outlook.Items
Dim objOutlookNameSpace As Outlook.NameSpace
Dim DateDebut, DateFin As Date
Dim Compteur As Integer

Compteur = 0


Set objOutlookNameSpace = objOutlook.GetNamespace("MAPI")
Set objOutlookCalendar =
objOutlookNameSpace.GetDefaultFolder(olFolderCalendar).Items
objOutlookCalendar.Sort "[Start]"
objOutlookCalendar.IncludeRecurrences = True



DateDebut = Sheets("Calendrier").Cells(8, 6).Value
DateFin = DateSerial(Year(DateDebut), Month(DateDebut) + 1, 1) - 1

Set objOutlookAppt = objOutlookCalendar.Find("[Start] >= """ &
DateDebut & """ and [Start] <= """ & DateFin & """ ")

While TypeName(objOutlookAppt) <> "Nothing"

If objOutlookAppt.Categories = "Suivi Calendrier" And
Left(objOutlookAppt.Subject, Len(SERVICE)) = SERVICE Then
objOutlookAppt.Delete
Compteur = Compteur + 1
End If
Set objOutlookAppt = objOutlookCalendar.FindNext

Wend

MsgBox Compteur & " rendez-vous supprimé(s)"

End Sub


--
____
( O | O )
--
_oooO_ JLuc _Oooo_

O-O






--
____
( O | O )
--
_oooO_ JLuc _Oooo_

O-O






--
____
( O | O )
--
_oooO_ JLuc _Oooo_

O-O