Discussion :

[emilier]

Bonjour à tous, et merci pour votre aide.
Je galère et sans solution, je m'adresse a vous.

Je souhaite créer un code VBA OUTLOOK me permettant de dupliquer les rendez vous sur un calendrier (celui actif au moment du lancement du code c'est a dire Application.ActiveExplorer.CurrentFolder) a X semaine(s) suivante(s). le X étant une information stockée dans le libellé du rendez vous (genre Nomdurendezvous-3 pour répétition toutes les 3 semaines).

L'idée que j'imaginais est se positionner, sur le calendrier, sur le jour a dupliquer et de lancer une macro.
S'il y a une boite de dialogue validant "nombre de jour a dupliqué" (par défaut 1) et "ajout semaine à l'intervalle de passage par défaut" (par défaut : 0) ce serait un plus trés agréable.

La macro scan les rendez vous du jour (et des jours suivants si chiffre différent de 0 dans la boite de dialogue ) , pour chaque rendez vous trouvé , identifie l'intervalle du dit rendez-vous (-3 par exemple, exprimé en semaine, donc récup du chiffre a postériori du tiret), et duplique intégralement le rendez vous trouvé X (intervalle par défaut + ajout semaine de la boite de dialogue) semaines suivantes.
Idéalement, la macro rajoute
- dans le "body" du rendez vous dupliqué, en première ligne, en plus du texte contenu, la mention "Créé par MacroAuto le (date)" avec intervalle de répétition de X semaines" (x étant l'intervalle retrouvé pour créer la nouvelle date)
- Dans le libellé du rendez vous d'origine, en tout premier caractère, un "*" indiquant que le rendez vous a déja été dupliqué.

Merci pour votre partage de compétence.

NB : Certain d'entre vous penseront sans doute que cela ressemble beaucoup à de la périodicité. Mais dans outlook, on ne peut pas modifier l'intervalle comme on le souhaite (exemple : passage toutes les 3 semaines, mais quand on veut une semaine de vacances, alors l'intervalle est de 4 semaines ponctuellement). D’où cette idée de duplication de rendez vous, qui permet plus facilement de réadapter les intervalles de contacts, et de garder des info sur le rendez vous (dans le body)

[emilier]

Voyant que mon besoin n'étant pas vraiment moteur d'idées des lecteurs du forum... j'ai bricolé ce code qui peut être, servira a quelqu'un. Alors je partage (puisqu'il fonctionne...)

Le principe : on lance un userform avec champ datedébut, datefin, interval, décalage.

Quelques controle dans la macro : vérification datefin > datedébut, intervalle entre date maxi de 15 jours.


Code de sur bouton lancer:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
Public Sub LancerMacroPourCopieRendezvous(DateDebut As Date, DateFin As Date, Decalage As Integer, CopieForcee)
 
    'Déclarations des variables et objets
    Dim objApply As Outlook.Application
    Dim objNameSpace As Outlook.NameSpace
    Dim objFolder As Outlook.MAPIFolder
    Dim objCalendrier As Outlook.AppointmentItem
    Dim intNbr As Integer
    Dim strStream As String
    Dim objFSO As New Scripting.FileSystemObject
    Dim fsoFichier As Scripting.TextStream
    'Dim DateDebut As Date
    'Dim DateFin As Date
 
    Set objApply = Outlook.Application
    Set objNameSpace = objApply.GetNamespace("MAPI")
    Set objFolder = Application.ActiveExplorer.CurrentFolder
 
If DateDebut > DateFin Then
MsgBox "procédure impossible car la date de début est Supérieure à la date de fin"
Exit Sub
End If
 
 
If DateDebut <= DateFin - 15 Then
MsgBox "procédure impossible car l'intervalle entre les 2 dates est supérieur à 2 semaines"
Exit Sub
End If
 
 
    Compte = 0
 
    For intNbr = 1 To objFolder.Items.Count
 
 
    Set objCalendrier = objFolder.Items.Item(intNbr)
 
 
If objCalendrier.Start < DateDebut Then GoTo line1
If objCalendrier.Start < DateFin + 1 Then
 
'Evenement sur chaque rendez vous rencontré dans la limite mini maxi des bornes dates
 
If CopieForcee = False Then
 
If Left(objCalendrier.Subject, 1) = "*" Then GoTo line1
 
End If
 
 
Position = InStr(objCalendrier.Subject, "-")
If Position = 0 Then GoTo line1 'Ne duplique rien s'il ne trouve pas le tiret qui est gage de répétition
RepetSemaine = Mid(objCalendrier.Subject, Position + 1, 1)
If IsNumeric(RepetSemaine) = False Then
MsgBox "Le rendez vous suivant : " & objCalendrier.Subject & " en date du :" & objCalendrier.Start & " ne sera pas copié, car il ne contient pas les éléments pour connaitre la répétition en nombre de semaine. La procédure va suivre pour les autres rendez vous de la période."
End If
 
Call CréationRendezvous(objCalendrier.Subject, objCalendrier.Start, objCalendrier.End, objCalendrier.Body, objCalendrier.Location, objCalendrier.Categories, objCalendrier.Importance, objCalendrier.BusyStatus, RepetSemaine, Decalage)
objCalendrier.Subject = "*" & objCalendrier.Subject
objCalendrier.Save
Compte = Compte + 1
End If
 
 
line1:
 
 
Next
 
 
 
Line10:
 
    MsgBox "Procédure terminée avec succès, " & Compte & " rendez vous ont étés dupliqués."
 
End Sub
[/I][/INDENT]
 
 
Code pour la création par "duplication" : 
 
[INDENT][I]Public Sub CréationRendezvous(Sujet, DateDeb, DateFin, Body, Lieu, Categorie, Importance, BusyStatus, RepetSemaine, Decalage)
 
Set MonApp = Outlook.Application
Set MonNameSpace = MonApp.GetNamespace("MAPI")
 
    'On cree un nouvel evenement sur le calendrier actif
 
    Set MonObj = Application.ActiveExplorer.CurrentFolder.Items.Add(olAppointmentItem)
 
    'On affecte les variables precedentes a début, fin, sujet etc.
 
    MonObj.Start = DateDeb + (RepetSemaine + Decalage) * 7
    MonObj.End = DateFin + (RepetSemaine + Decalage) * 7
    MonObj.Subject = Sujet
    MonObj.Body = "Création par MacroAuto le " & Date & " - Précédente occurance le : " & DateDeb & " (Repetition : " & RepetSemaine & "+" & Decalage & " Semaines)" & vbCrLf & Body
    MonObj.Location = Lieu
    MonObj.Importance = Importance
    MonObj.BusyStatus = BusyStatus
    MonObj.Organizer = "MacroAutomatique"
 
        'Il faut s'interroger s'il ne serait pas plus simple de copier l'objet... mais faute de compétence....
        'Evenementjournéeouinon = objCalendrier.AllDayEvent
        'JourDebutEvenement = objCalendrier.Start
        'JourFinEvenement = objCalendrier.End
        'titreEvenement = objCalendrier.Subject
        'LocalisationEvement = objCalendrier.Location
        'objCalendrier.Organizer
        'Organisateur = "MacroAutomatique"
        'ImportanceEvenement = objCalendrier.Importance
        'CatégorieEvenement = objCalendrier.Categories
        'BusyStatutEvenement = objCalendrier.BusyStatus
        'SensitivityEvenement = objCalendrier.Sensitivity
        'CorpsEvenement = objCalendrier.Body
 
     'On ferme et on sauvegarde.
    MonObj.Close olSave
 
End sub

Merci aux différents contributeurs a qui j'ai trés largement copié leur code et donc compétence !