Création automatisée de rendez-vous depuis lecture de fichier de données .txt

**buggzbeny** · 10/09/2017, 10h43

Bonjour à tous,

Je parcours votre forum depuis longtemps et cela m'a beaucoup aidé à développer des macros sous excel / outlook pour ma conjointe qui travaille dans une association.
Cependant la je cale complètement et n'arrive pas à mes fins !

Je vous présente le contexte :

Ils ont un outil (base de donnée) ou ils saisissent les rendez-vous, puis saisissent à la main les rendez-vous dans le calendrier outlook. L'idée était de leur simplifier la vie.

Ils peuvent faire une extraction de cet outil qui sort un fichier .txt contenant les données.
Ensuite dans outlook, ils auraient un bouton dans le ruban permettant d'aller chercher le fichier texte extrait pour saisir de manière automatisée les rendez-vous dans le calendrier outlook.

J'ai déjà bien avancé sur le programme, puisque j'ai fait un bouton parcourir qui leur permettra d'aller chercher le fichier texte dans le répertoire de leur choix avec vérification qu'il s'agit bien d'un fichier issu de l'extraction de leur base de donnée.
Ensuite en macro je transforme le fichier .txt avec comme séparateur "tabulation" en tableau temporaire .xslx contenant l'entête et une ligne par rendez-vous me permettant de lire plus facilement depuis outlook
Enfin j'arrive déjà à générer un rendez-vous dans outlook pour chaque numéro de visite, avec le coprs du message correspondant.

Nom : Capture2.JPG
Affichages : 430
Taille : 90,6 Ko

Nom : Capture2.JPG
Affichages : 430
Taille : 90,6 Ko

La ou je coince :

il peut y avoir plusieurs raisons de visite dans un même rendez-vous sur la journée, du coup dans le fichier excel, il y a donc plusieurs lignes avec le même numéro de visite en colonne A, mais des valeurs différentes dans les colonnes suivantes.
Il faut donc qu'apparaissent dans le corps du rendez-vous les différentes raisons de visite.
Ce que j'ai fait ne contient qu'une seule des lignes d'une visite (la première) même s'il y a plusieurs lignes.

J'ai essayé de recopier chaque ligne correspondant a un numéro de visite en doublon dans une feuille a part, et faire ainsi autant de feuille que de numéro de visite différent pour ensuite lire feuille par feuille pour générer mes rendez vous mais je n'ai pas réussi.

Du coup je sèche ...

Voici déjà mon code actuel (pas très propre mais complètement fonctionnel

)

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
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
 
Private Sub valider_lecture_Click()
 
 
'Declaration des variables
Dim XlApp, XlClasseur
Dim derniere_ligne As Long
 
 
'répertoire de stockage du fichier excel temporaire
repertoire_temporaire = "c:\test\"
 
'Récupération du nom d'utilisateur en cours de session
Userlogin = Environ("USERNAME")
 
'Chemin complet du fichier excel temporaire
fichier_excel_temp = repertoire_temporaire & "temp-" & Userlogin & ".xlsx"
 
'Création d'un Excel
Set XlApp = CreateObject("Excel.Application")
 
'teste si un fichier à bien été selectionné, si aucun selectionné quitte la macro
If fichier_txt.Value = "" Then
    GoTo fin
End If
 
'Ouverture du classeur
Set XlClasseur = XlApp.Workbooks.Add
 
'Enregistrement du fichier excel temporaire
XlClasseur.SaveAs (fichier_excel_temp)
 
'On rend le classeur visible
XlApp.Visible = True
 
Unload formulaire_choix_fichier
 
'Conversion du fichier texte extrait en fichier excel
With XlClasseur.Worksheets("Feuil1").QueryTables.Add(Connection:="TEXT;" & fichier_txt.Value, Destination:=XlClasseur.Worksheets("Feuil1").Range("$A$1"))
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 1252
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 2, 1, 1, 1, 1, 2, 2, 1, 1, 1, 2, 1, 1, _
        1, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
End With
 
XlClasseur.Save
 
XlClasseur.Worksheets("Feuil2").Delete
XlClasseur.Worksheets("Feuil3").Delete
 
'Recherche de la dernière ligne du tableau
derniere_ligne = XlClasseur.Worksheets("Feuil1").Range("A" & XlClasseur.Worksheets("Feuil1").Rows.Count).End(xlUp).Row
 
For i = 2 To derniere_ligne
 
 
    If XlClasseur.Worksheets("Feuil1").Range("A" & i - 1) <> XlClasseur.Worksheets("Feuil1").Range("A" & i) Then
 
numero_visite = XlClasseur.Worksheets("Feuil1").Range("A" & i)
raison_sociale = XlClasseur.Worksheets("Feuil1").Range("C" & i)
adresse1 = XlClasseur.Worksheets("Feuil1").Range("D" & i)
adresse2 = XlClasseur.Worksheets("Feuil1").Range("E" & i)
code_postal = XlClasseur.Worksheets("Feuil1").Range("F" & i)
commune = XlClasseur.Worksheets("Feuil1").Range("G" & i)
departement = XlClasseur.Worksheets("Feuil1").Range("H" & i) 
raison_visite = XlClasseur.Worksheets("Feuil1").Range("I" & i)
produit = XlClasseur.Worksheets("Feuil1").Range("J" & i)
date_debut = XlClasseur.Worksheets("Feuil1").Range("L" & i)
date_debut = CDate(date_debut)
heure_debut_temp = XlClasseur.Worksheets("Feuil1").Range("M" & i)
heure_debut_temp = CDbl(heure_debut_temp * 24)
heure_debut_temp = Format(heure_debut_temp, "#.00")
Dim D As Single, Resultat, e
    'Pour l'exemple
    e = CStr(Round((heure_debut_temp - Int(heure_debut_temp)) / 100 * 60, 2)) & "0"
    heure_debut = CStr(Int(heure_debut_temp)) & ":" & Mid(e, 3, 2)
If Len(heure_debut) < 4 Then
    heure_debut = heure_debut & "00"
End If
temps_prevu_temp = XlClasseur.Worksheets("Feuil1").Range("K" & i)
temps_prevu = (temps_prevu_temp * 8) * 60
 
'Creation du RDV et Ecriture du contenu
Dim olAppt As AppointmentItem
Set olAppt = Application.CreateItem(olAppointmentItem)
With olAppt
    .MeetingStatus = olMeeting
    .Subject = "Contrôle : " & raison_sociale & " (" & departement & ")"
    .Start = date_debut & "    " & heure_debut & ":00"
    .Duration = temps_prevu 'durée de rdv, en minutes
    .Body = "Rendez vous de la visite" & numero_visite & " :" & vbCrLf & " pour la raison " & raison_visite & " pour le produit " & produit 'corps du texte de la réunion
    .Location = adresse1 & " " & adresse2 & " " & code_postal & " " & commune 'Lieu du rdv
    'on sauvegarde et ferme
    .Save
End With
 
Set olAppt = Nothing
 
 
    End If
 
 
Next
 
 
 
 
 
 
XlClasseur.Close True
'On quitte Excel
XlApp.Quit
'On libère la mémoire des variables
Set XlClasseur = Nothing
Set XlApp = Nothing
 
 
 
 
fin:
 
 
End Sub

Pourriez vous m'aider à mettre dans le corps du rendez vous le contenu de chaque ligne correspondant à un numéro de visite ?

Exemple de creation d'un rendez vous souhaité avec plusieurs lignes (4 raisons pour une visite):

Nom : Capture.JPG
Affichages : 474
Taille : 114,4 Ko

Nom : Capture.JPG
Affichages : 474
Taille : 114,4 Ko

Le fichier .xlsx contenant les données (très simplifié car contient normalement beaucoup plus de colonnes et d'infos dedans ... )

projet-Outlook.xlsx

Un grand merci d'avance !

**buggzbeny** · 10/09/2017, 11h37

Je vous ai mis le fichier Excel mais la macro est bien développée dans Outlook...

**buggzbeny** · 10/09/2017, 22h30

Après avoir passé l'après midi dessus ... je me réponds à moi-même !

J'ai fait une boucle for imbriquée dans la première, je ne sais pas si c'était le plus facile ... mais ca fonctionne !

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
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
Private Sub valider_lecture_TXT_Click()
 
 
'Declaration des variables
Dim XlApp, XlClasseur
Dim derniere_ligne As Long
 
 
'répertoire de stockage du fichier excel temporaire
repertoire_temporaire = "c:\test\"
 
'Récupération du nom d'utilisateur en cours de session
Userlogin = Environ("USERNAME")
 
'Chemin complet du fichier excel temporaire
fichier_excel_temp = repertoire_temporaire & "tempTXT-" & Userlogin & ".xlsx"
 
'Création d'un Excel
Set XlApp = CreateObject("Excel.Application")
 
'teste si un fichier à bien été selectionné, si aucun selectionné quitte la macro
If fichier_TXT.Value = "" Then
    GoTo fin
End If
 
'Ouverture du classeur
Set XlClasseur = XlApp.Workbooks.Add
 
'Enregistrement du fichier excel temporaire
XlClasseur.SaveAs (fichier_excel_temp)
 
'On rend le classeur visible
XlApp.Visible = True
 
Unload formulaire_TXT
 
'Conversion du fichier texte extrait de TXT en fichier excel
With XlClasseur.Worksheets("Feuil1").QueryTables.Add(Connection:="TEXT;" & fichier_TXT.Value, Destination:=XlClasseur.Worksheets("Feuil1").Range("$A$1"))
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 1252
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 2, 1, 1, 1, 1, 2, 2, 1, 1, 1, 2, 1, 1, _
        1, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
End With
 
XlClasseur.Save
 
XlClasseur.Worksheets("Feuil2").Delete
XlClasseur.Worksheets("Feuil3").Delete
 
'Recherche de la dernière ligne du tableau
derniere_ligne = XlClasseur.Worksheets("Feuil1").Range("A" & XlClasseur.Worksheets("Feuil1").Rows.Count).End(xlUp).Row
 
For i = 2 To derniere_ligne
 
    numero_visite = ""
 
    If XlClasseur.Worksheets("Feuil1").Range("A" & i + 1) <> XlClasseur.Worksheets("Feuil1").Range("A" & i) Then
 
        'If XlClasseur.Worksheets("Feuil1").Range("A" & i - 1) <> XlClasseur.Worksheets("Feuil1").Range("A" & i) Then
 
            numero_visite = XlClasseur.Worksheets("Feuil1").Range("A" & i)
            raison_sociale = XlClasseur.Worksheets("Feuil1").Range("C" & i)
            departement = XlClasseur.Worksheets("Feuil1").Range("L" & i)
            adresse1 = XlClasseur.Worksheets("Feuil1").Range("G" & i)
            adresse2 = XlClasseur.Worksheets("Feuil1").Range("H" & i)
            code_postal = XlClasseur.Worksheets("Feuil1").Range("I" & i)
            commune = XlClasseur.Worksheets("Feuil1").Range("J" & i)
            responsable = XlClasseur.Worksheets("Feuil1").Range("M" & i)
            telephone1 = XlClasseur.Worksheets("Feuil1").Range("N" & i)
            telephone2 = XlClasseur.Worksheets("Feuil1").Range("O" & i)
            mail = XlClasseur.Worksheets("Feuil1").Range("Q" & i)
            date_debut = XlClasseur.Worksheets("Feuil1").Range("AM" & i)
            date_debut = CDate(date_debut)
            heure_debut_temp = XlClasseur.Worksheets("Feuil1").Range("AO" & i)
            heure_debut_temp = CDbl(heure_debut_temp * 24)
            heure_debut_temp = Format(heure_debut_temp, "#.00")
            Dim D As Single, Resultat, e
            'Pour l'exemple
            e = CStr(Round((heure_debut_temp - Int(heure_debut_temp)) / 100 * 60, 2)) & "0"
            heure_debut = CStr(Int(heure_debut_temp)) & ":" & Mid(e, 3, 2)
            If Len(heure_debut) < 4 Then
                heure_debut = heure_debut & "00"
            End If
            temps_prevu_temp = XlClasseur.Worksheets("Feuil1").Range("AJ" & i)
            temps_prevu = (temps_prevu_temp * 8) * 60
            corps_rdv = "Numéro de visite : " & numero_visite & vbCrLf & vbCrLf  'corps du texte de la réunion
            corps_rdv = corps_rdv & "Contact : " & vbCrLf
            corps_rdv = corps_rdv & responsable
            If telephone1 <> "" Then
                corps_rdv = corps_rdv & "   " & telephone1
            End If
            If telephone2 <> "" Then
                corps_rdv = corps_rdv & "   " & telephone2
            End If
            If mail <> "" Then
                corps_rdv = corps_rdv & "   " & mail
            End If
            corps_rdv = corps_rdv & vbCrLf & vbCrLf
            corps_rdv = corps_rdv & "Durée de la visite (j) : " & temps_prevu_temp & vbCrLf & vbCrLf
            corps_rdv = corps_rdv & "Contenu de la visite : " & vbCrLf
            corps_rdv = corps_rdv & " " & XlClasseur.Worksheets("Feuil1").Range("y" & i)
 
        'End If
 
 
    Else
            'If XlClasseur.Worksheets("Feuil1").Range("A" & i - 1) <> XlClasseur.Worksheets("Feuil1").Range("A" & i) Then
 
            numero_visite = XlClasseur.Worksheets("Feuil1").Range("A" & i)
            raison_sociale = XlClasseur.Worksheets("Feuil1").Range("C" & i)
            departement = XlClasseur.Worksheets("Feuil1").Range("L" & i)
            adresse1 = XlClasseur.Worksheets("Feuil1").Range("G" & i)
            adresse2 = XlClasseur.Worksheets("Feuil1").Range("H" & i)
            code_postal = XlClasseur.Worksheets("Feuil1").Range("I" & i)
            commune = XlClasseur.Worksheets("Feuil1").Range("J" & i)
            responsable = XlClasseur.Worksheets("Feuil1").Range("M" & i)
            telephone1 = XlClasseur.Worksheets("Feuil1").Range("N" & i)
            telephone2 = XlClasseur.Worksheets("Feuil1").Range("O" & i)
            mail = XlClasseur.Worksheets("Feuil1").Range("Q" & i)
            date_debut = XlClasseur.Worksheets("Feuil1").Range("AM" & i)
            date_debut = CDate(date_debut)
            heure_debut_temp = XlClasseur.Worksheets("Feuil1").Range("AO" & i)
            heure_debut_temp = CDbl(heure_debut_temp * 24)
            heure_debut_temp = Format(heure_debut_temp, "#.00")
            'Pour l'exemple
            e = CStr(Round((heure_debut_temp - Int(heure_debut_temp)) / 100 * 60, 2)) & "0"
            heure_debut = CStr(Int(heure_debut_temp)) & ":" & Mid(e, 3, 2)
            If Len(heure_debut) < 4 Then
                heure_debut = heure_debut & "00"
            End If
            temps_prevu_temp = XlClasseur.Worksheets("Feuil1").Range("AJ" & i)
            temps_prevu = (temps_prevu_temp * 8) * 60
            corps_rdv = "Numéro de visite : " & numero_visite & vbCrLf & vbCrLf  'corps du texte de la réunion
            corps_rdv = corps_rdv & "Contact : " & vbCrLf
            corps_rdv = corps_rdv & responsable
            If telephone1 <> "" Then
                corps_rdv = corps_rdv & "   " & telephone1
            End If
            If telephone2 <> "" Then
                corps_rdv = corps_rdv & "   " & telephone2
            End If
            If mail <> "" Then
                corps_rdv = corps_rdv & "   " & mail
            End If
            corps_rdv = corps_rdv & vbCrLf & vbCrLf
            corps_rdv = corps_rdv & "Durée de la visite (j) : " & temps_prevu_temp & vbCrLf & vbCrLf
            corps_rdv = corps_rdv & "Contenu de la visite : " & vbCrLf
 
 
            For J = i To derniere_ligne
 
                If XlClasseur.Worksheets("Feuil1").Range("A" & J) = XlClasseur.Worksheets("Feuil1").Range("A" & i) Then
 
                    corps_rdv = corps_rdv & " " & XlClasseur.Worksheets("Feuil1").Range("y" & J) & vbCrLf 'corps du texte de la réunion
                    num_ligne = J
 
                End If
 
 
            Next
 
            i = num_ligne '- 1
 
    End If
 
    If numero_visite <> "" Then
 
            'Creation du RDV et Ecriture du contenu
            Dim olAppt As AppointmentItem
            Set olAppt = Application.CreateItem(olAppointmentItem)
            With olAppt
                .MeetingStatus = olMeeting
                'Sujet on récupère l'utilisateur en cours de session
                .Subject = "Contrôle : " & raison_sociale & " (" & departement & ")"
                .Start = date_debut & "    " & heure_debut & ":00"
                '.End = date_depart.Value & "    " & heure_fin.Value & ":00"
                .Duration = temps_prevu 'durée de rdv, en minutes
                .Body = corps_rdv
                .Location = adresse1 & " " & adresse2 & " " & code_postal & " " & commune 'Lieu du rdv
                'on sauvegarde et ferme
                .Save
            End With
            Set olAppt = Nothing
    End If
 
 
 
Next
 
 
 
 
 
 
XlClasseur.Close True
'On quitte Excel
XlApp.Quit
'On libère la mémoire des variables
Set XlClasseur = Nothing
Set XlApp = Nothing
 
 
 
 
fin:
 
 
End Sub

Maintenant autre question ... si j'importe deux fois le même fichier txt cela me crée deux fois les rendez-vous !
Savez vous s'il y a moyen de vérifier que le rendez-vous existe déjà avant de le créer ?

Vérifications a faire :

- numéro de visite
- jour de visite
- heure de départ

Car un rendez vous ayant un numéro de visite unique peut avoir été décalé dans le temps. Il faudrait alors supprimer l'ancien et mettre le nouveau à la place.

**Oliv-** · 11/09/2017, 10h44

Salut,

Il faut que tu puisses identifier à coup sûr ton RDV! moi j'indiquerai dans le Subject :

Code :

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

   .Subject = "Contrôle : " & raison_sociale & " (" & departement & ") #" & numero_visite

ce qui te permettra de chercher via ce numéro de visite le # est là pour rendre unique cette info.

Regarde le code dans ce sujet
https://www.developpez.net/forums/d1...t/#post8831383

**buggzbeny** · 11/09/2017, 11h58

Envoyé par Oliv-

Salut,

Il faut que tu puisses identifier à coup sûr ton RDV! moi j'indiquerai dans le Subject :

Code :

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

   .Subject = "Contrôle : " & raison_sociale & " (" & departement & ") #" & numero_visite

ce qui te permettra de chercher via ce numéro de visite le # est là pour rendre unique cette info.

Regarde le code dans ce sujet
https://www.developpez.net/forums/d1...t/#post8831383

ok merci !
J'avais pensé également faire apparaitre le numéro de visite dans le sujet du rdv ce qui me permettais de retrouver plus facilement le RDV.
Le # n'a pas de fonction particulière ? c'est juste pour concaténer le numéro de visite avec afin d'avoir un numero de visite sous la forme #seriedechiffre afin d'éviter d'avoir un retour d'un sujet contenant une série de chiffre identique c'est ca ?

Par contre du coup, il peut y avoir un rendez-vous qui a été décalé, auquel cas le numéro de visite de leur logiciel reste inchangé, simplement la date de planification qui sera modifiée, soit par le jour, soit l'heure voire les deux.
C'est cette partie de ton code qui me permettra la comparaison ?

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
Set MonApp = Outlook.Application
Set MonNameSpace = MonApp.GetNamespace("MAPI")
 
'On pointe sur le calendrier pour chercher les valeurs a copier
Set MonDoss = MonNameSpace.GetDefaultFolder(olFolderCalendar) 'ou le GetSharedDefaultFolder
 
 
 
For Each EvenCalend In MonDoss.Items
 
      'On definit les variables de l'événement, debut, fin, sujet etc.
      Sujet = EvenCalend.Subject
      If InStr(1, Sujet, "Congés", vbTextCompare) > 0 Then    
 
            'On definit les variables de l'événement, début, fin, sujet etc.
            Sujet = EvenCalend.Subject
            DateDeb = EvenCalend.Start
      end if
Next EvenCalend

If InStr(1, Sujet, "Congés", vbTextCompare) > 0 Then ------> c'est la que je fais ma recherche sur le numéro de visite en changeant "congés" par ma variable "numero_visite" lue du fichier excel ?

et je fais des comparaisons entre :

DateDeb = EvenCalend.Start -----> ma variable date_debut & " " & heure_debut & ":00" lue du fichier excel ?

En gros avant ma creation de RDV :

lecture du calendrier à la recherche d'un RDV avec le même numéro de visite

if numero de visite trouvé alors
if comparaison .start <> ma variable excel
Creation du rendez-vous et suppression de l'ancien ? ou je peux uniquement le déplacer avec le nouveau .start ?
end if
else
creation du rdv
end if

En tout cas merci d'avance pour ton aide !!!

PS: pas trop pourri mon code ??? Je suis absolument pas du tout programmeur car autodidacte en la matière ... du coup je me demande parfois si je me complique pas la tache pour rien avec certaines de mes macros ...
J'ai pas fini de tout commenter, j'ai envoyé la version brute après avoir trouvé la solution, il faut que je fasse un peu de nettoyage dedans ...

**Oliv-** · 11/09/2017, 13h47

Envoyé par buggzbeny

ok merci !
J'avais pensé également faire apparaitre le numéro de visite dans le sujet du rdv ce qui me permettais de retrouver plus facilement le RDV.
Le # n'a pas de fonction particulière ? c'est juste pour concaténer le numéro de visite avec afin d'avoir un numero de visite sous la forme #seriedechiffre afin d'éviter d'avoir un retour d'un sujet contenant une série de chiffre identique c'est ca ?

OUI

Par contre du coup, il peut y avoir un rendez-vous qui a été décalé, auquel cas le numéro de visite de leur logiciel reste inchangé, simplement la date de planification qui sera modifiée, soit par le jour, soit l'heure voire les deux.
C'est cette partie de ton code qui me permettra la comparaison ?

Plutot l'utilisation de la fonction? MAIS TELLE QUELLE elle n'accepte que les sujets identiques (je vais la modifier...)
l'idée c'est pour gagner du temps d'utiliser restrict pour limiter le nombre de rdv à comparer, soit sur le sujet ou la période

Code :

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

1
2
3
4
5
6
7
if fc_AppointmentExist (EvenCalend.Start,EvenCalend.subject,MonSousDoss)=True then
 
'Existe donc suppression de l'ancien
 
End if
 
' ICI CREATION DU RDV

If InStr(1, Sujet, "Congés", vbTextCompare) > 0 Then ------> c'est la que je fais ma recherche sur le numéro de visite en changeant "congés" par ma variable "numero_visite" lue du fichier excel ?

et je fais des comparaisons entre :

DateDeb = EvenCalend.Start -----> ma variable date_debut & " " & heure_debut & ":00" lue du fichier excel ?

En gros avant ma creation de RDV :

lecture du calendrier à la recherche d'un RDV avec le même numéro de visite

if numero de visite trouvé alors
if comparaison .start <> ma variable excel
Creation du rendez-vous et suppression de l'ancien ? ou je peux uniquement le déplacer avec le nouveau .start ?
end if
else
creation du rdv
end if

En tout cas merci d'avance pour ton aide !!!

PS: pas trop pourri mon code ??? Je suis absolument pas du tout programmeur car autodidacte en la matière ... du coup je me demande parfois si je me complique pas la tache pour rien avec certaines de mes macros ...
J'ai pas fini de tout commenter, j'ai envoyé la version brute après avoir trouvé la solution, il faut que je fasse un peu de nettoyage dedans ...

**buggzbeny** · 11/09/2017, 20h51

Re moi !

Tu vas me prendre pour une buse mais je n'arrive pas à utiliser ta fonction

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
If numero_visite <> "" Then
 
            Set MonApp = Outlook.Application
            Set MonNameSpace = MonApp.GetNamespace("MAPI")
            Dim MonSousDoss As Outlook.Folder
 
            'On pointe sur le calendrier pour chercher les valeurs a copier
            Set MonDoss = MonNameSpace.GetDefaultFolder(olFolderCalendar) 'ou le GetSharedDefaultFolder
            Set MonSousDoss = MonDoss.Folders(1)
 
 
            If fc_AppointmentExist("Contrôle : " & raison_sociale & " (" & departement & ") #" & numero_visite, MonSousDoss) = True Then
 
                'Call DeleteAppointments(EvenCalend_Subject)
                MsgBox ("existe")
 
            End If
 
            'Creation du RDV et Ecriture du contenu
            Dim outlookAppt As AppointmentItem
            Set outlookAppt = Application.CreateItem(olAppointmentItem)
            With outlookAppt
                .MeetingStatus = olMeeting
                'Sujet on récupère l'utilisateur en cours de session
                .Subject = "Contrôle : " & raison_sociale & " (" & departement & ") #" & numero_visite
                .Start = date_debut & "    " & heure_debut & ":00"
                '.End = date_depart.Value & "    " & heure_fin.Value & ":00"
                .Duration = temps_prevu 'durée de rdv, en minutes
                .Body = corps_rdv
                .Location = adresse1 & " " & adresse2 & " " & code_postal & " " & commune 'Lieu du rdv
                'on sauvegarde et ferme
                .Save
            End With
            Set outlookAppt = Nothing
    End If

J'ai modifié la fonction de cette manière :

Code :

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

1
2
3
4
5
6
7
8
9
10
Function fc_AppointmentExist(Sujet As String, MyAgendaFolder As Outlook.Folder) As Boolean
    Dim searchAgenda As Items
    Dim filtre
     fc_AppointmentExist = False
    Set searchAgenda = MyAgendaFolder.Items
    filtre = "[Subject] = '" & Sujet & "'"
    Set searchAgenda = searchAgenda.Restrict(filtre)
    If searchAgenda.Count > 0 Then fc_AppointmentExist = True
 
End Function

je ne cherche que le sujet qui dans tous les cas est unique ... malgrè que le rendez vous existe déjà ... la fonction ne le trouve pas puisqu'il ne m'affiche pas le msgbox ...

peux tu m'aider ? merci !

**buggzbeny** · 11/09/2017, 22h58

Je t'ai fait une infidélité !!!!

J'ai trouvé sur un site une macro pour modifier un rendez vous existant que j'ai inséré dans mon code :

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
 
    If numero_visite <> "" Then
 
 
            'déclaration des variables
            Dim oOutlook As Outlook.Application
            Dim oAppointment As Outlook.AppointmentItem
 
            Dim namespaceOutlook As Outlook.NameSpace
            Dim DossierCalendrier As Outlook.MAPIFolder
 
            Dim sFilter As String
 
            '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)
 
            sujetrdv = "Contrôle : " & raison_sociale & " (" & departement & ") #" & numero_visite
            'on définit les critères de filtre afin de retrouver le rdv créé
            sFilter = "[Subject] = '" & sujetrdv & "' "
 
            'on cherche le ou les rdv correspondant aux critères
            Set oAppointment = DossierCalendrier.Items.Find(sFilter)
 
            'si au moins un rdv a été trouvé
            If Not oAppointment Is Nothing Then
               With oAppointment
                    .Start = date_debut & "    " & heure_debut & ":00"
                    '.End = date_depart.Value & "    " & heure_fin.Value & ":00"
                    .Duration = temps_prevu 'durée de rdv, en minutes
                    .Body = corps_rdv
                    .Location = adresse1 & " " & adresse2 & " " & code_postal & " " & commune 'Lieu du rdv
                    'on sauvegarde et ferme
                    .Save
                End With
                Set oAppointment = Nothing
 
            Else
 
                'Creation du RDV et Ecriture du contenu
                Dim outlookAppt As AppointmentItem
                Set outlookAppt = Application.CreateItem(olAppointmentItem)
                With outlookAppt
                    .MeetingStatus = olMeeting
                    'Sujet on récupère l'utilisateur en cours de session
                    .Subject = "Contrôle : " & raison_sociale & " (" & departement & ") #" & numero_visite
                    .Start = date_debut & "    " & heure_debut & ":00"
                    '.End = date_depart.Value & "    " & heure_fin.Value & ":00"
                    .Duration = temps_prevu 'durée de rdv, en minutes
                    .Body = corps_rdv
                    .Location = adresse1 & " " & adresse2 & " " & code_postal & " " & commune 'Lieu du rdv
                    'on sauvegarde et ferme
                    .Save
                End With
                Set outlookAppt = Nothing
            End If
 
 
 
    End If

Il modifie un rendez-vous existant si l'heure et/ou date ont changé et j'ai rajouté un else pour la création s'il n'existe pas ... et ca fonctionne !

J'ai plus qu'a bien commenter mon code et nettoyer tous mes tests ...

En tout cas merci beaucoup pour ton aide !

**Oliv-** · 12/09/2017, 10h09

Envoyé par buggzbeny

Re moi !

Tu vas me prendre pour une buse mais je n'arrive pas à utiliser ta fonction

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
If numero_visite <> "" Then
 
            Set MonApp = Outlook.Application
            Set MonNameSpace = MonApp.GetNamespace("MAPI")
            Dim MonSousDoss As Outlook.Folder
 
            'On pointe sur le calendrier pour chercher les valeurs a copier
            Set MonDoss = MonNameSpace.GetDefaultFolder(olFolderCalendar) 'ou le GetSharedDefaultFolder
            Set MonSousDoss = MonDoss.Folders(1)
 
 
            If fc_AppointmentExist("Contrôle : " & raison_sociale & " (" & departement & ") #" & numero_visite, MonSousDoss) = True Then
 
                'Call DeleteAppointments(EvenCalend_Subject)
                MsgBox ("existe")
 
            End If
 
            'Creation du RDV et Ecriture du contenu
            Dim outlookAppt As AppointmentItem
            Set outlookAppt = Application.CreateItem(olAppointmentItem)
            With outlookAppt
                .MeetingStatus = olMeeting
                'Sujet on récupère l'utilisateur en cours de session
                .Subject = "Contrôle : " & raison_sociale & " (" & departement & ") #" & numero_visite
                .Start = date_debut & "    " & heure_debut & ":00"
                '.End = date_depart.Value & "    " & heure_fin.Value & ":00"
                .Duration = temps_prevu 'durée de rdv, en minutes
                .Body = corps_rdv
                .Location = adresse1 & " " & adresse2 & " " & code_postal & " " & commune 'Lieu du rdv
                'on sauvegarde et ferme
                .Save
            End With
            Set outlookAppt = Nothing
    End If

J'ai modifié la fonction de cette manière :

Code :

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

1
2
3
4
5
6
7
8
9
10
Function fc_AppointmentExist(Sujet As String, MyAgendaFolder As Outlook.Folder) As Boolean
    Dim searchAgenda As Items
    Dim filtre
     fc_AppointmentExist = False
    Set searchAgenda = MyAgendaFolder.Items
    filtre = "[Subject] = '" & Sujet & "'"
    Set searchAgenda = searchAgenda.Restrict(filtre)
    If searchAgenda.Count > 0 Then fc_AppointmentExist = True
 
End Function

je ne cherche que le sujet qui dans tous les cas est unique ... malgrè que le rendez vous existe déjà ... la fonction ne le trouve pas puisqu'il ne m'affiche pas le msgbox ...

peux tu m'aider ? merci !

Salut,

Par rapport à ton autre code le suivant, je remarque que tu ne pointe pas sur le même dossier, ton rdv est-il bien dans le sous-dossier de calendrier ?

Effectivement avec cette syntaxe tu doit mettre le sujet exact ! la question que tu dois te poser c'est est-ce que ce Sujet
"Contrôle : " & raison_sociale & " (" & departement & ") #" & numero_visite
est bien unique et ne peut changer !

Sinon pour rechercher "contient" #numero_visite dans le sujet voici un code qui devrait fonctionner

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
Function fc_AppointmentExist(Sujet As String, MyAgendaFolder As Outlook.Folder) As Boolean
    Dim searchAgenda As Items
    Dim filtre
    fc_AppointmentExist = False
    Set searchAgenda = MyAgendaFolder.Items
    filtre = "@SQL=" & Chr(34) _
             & "urn:schemas:httpmail:subject" & Chr(34) _
             & " ci_phrasematch '" & Sujet & "'"
    Set searchAgenda = searchAgenda.Restrict(filtre)
    If searchAgenda.Count > 0 Then fc_AppointmentExist = True
 
End Function

et si aucuns autres changements ne peut intervenir en dehors de ta macro, (comme des notes ajoutées etc) tu peux simplement supprimer le rdv puis le recréer comme s'il n'existait pas.
Pour supprimer

Code :

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

1
2
3
For i= searchAgenda.Count to 1 step -1
searchAgenda(i).delete
Next i

**Oliv-** · 12/09/2017, 10h15

Envoyé par buggzbeny

Je t'ai fait une infidélité !!!!

J'ai trouvé sur un site une macro pour modifier un rendez vous existant que j'ai inséré dans mon code :

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
 
...
            Set oAppointment = DossierCalendrier.Items.Find(sFilter)
 
            'si au moins un rdv a été trouvé
            If Not oAppointment Is Nothing Then
               With oAppointment
                    .Start = date_debut & "    " & heure_debut & ":00"
                    '.End = date_depart.Value & "    " & heure_fin.Value & ":00"
                    .Duration = temps_prevu 'durée de rdv, en minutes
                    .Body = corps_rdv
                    .Location = adresse1 & " " & adresse2 & " " & code_postal & " " & commune 'Lieu du rdv
                    'on sauvegarde et ferme
                    .Save
                End With
                Set oAppointment = Nothing
 
            Else
   ...

Il modifie un rendez-vous existant si l'heure et/ou date ont changé et j'ai rajouté un else pour la création s'il n'existe pas ... et ca fonctionne !

J'ai plus qu'a bien commenter mon code et nettoyer tous mes tests ...

En tout cas merci beaucoup pour ton aide !

Pour info find et restrict utilisent les mêmes filtres, restrict te renvois la collection des items répondant à ce filtre, par contre find te renvoi le PREMIER uniquement, si tu es sûr de l'unicité du rdv c'est très bien comme cela , sinon tu dois utiliser une boucle

findnext

Sub DemoFindNext()
Dim myNameSpace As Outlook.NameSpace
Dim tdystart As Date
Dim tdyend As Date
Dim myAppointments As Outlook.Items
Dim currentAppointment As Outlook.AppointmentItem

Set myNameSpace = Application.GetNamespace("MAPI")
tdystart = VBA.Format(Now, "Short Date")
tdyend = VBA.Format(Now + 1, "Short Date")
Set myAppointments = myNameSpace.GetDefaultFolder(olFolderCalendar).Items
Set currentAppointment = myAppointments.Find("[Start] >= """ & tdystart & """ and [Start] <= """ & tdyend & """")
While TypeName(currentAppointment) <> "Nothing"
MsgBox currentAppointment.Subject
Set currentAppointment = myAppointments.FindNext
Wend
End Sub

**buggzbeny** · 12/09/2017, 10h42

Bonjour,

Oui le sujet de rendez-vous est unique. Effectivement par une (fausse) manipulation le sujet peut être modifié manuellement, dans ce cas la le rendez-vous sera créé en double.
Il faudrait alors que dans le code trouvé sur le net, je ne cherche pas l'intégralité du sujet mais uniquement le #numerodevisite qui lui est unique c'est sur !

Si je prends ton filtre pour chercher la chaine #numerodevisite que j'insère dans le cote que j'ai trouvé hier cela va t il fonctionner ?

Je suis au boulot la et je développe la macro à la maison donc je ne peux pas tester ...

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
   Dim oOutlook As Outlook.Application
            Dim oAppointment As Outlook.AppointmentItem
 
            Dim namespaceOutlook As Outlook.NameSpace
            Dim DossierCalendrier As Outlook.MAPIFolder
 
            Dim sFilter As String
 
            '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)
 
            sujetrdv = "#" & numero_visite
            'on définit les critères de filtre afin de retrouver le rdv créé
            sFilter = "@SQL=" & Chr(34) _
             & "urn:schemas:httpmail:subject" & Chr(34) _
             & " ci_phrasematch '" & sujetrdv & "'"
 
            'on cherche le ou les rdv correspondant aux critères
            Set oAppointment = DossierCalendrier.Items.Find(sFilter)

Ensuite oui il peut y avoir des ajouts de notes faites manuellement, c'est pour cela que j'ai préféré déplacer et non supprimer pour re créer.

Merci beaucoup

**buggzbeny** · 12/09/2017, 23h26

Encore moi !

Est il possible d'ajouter les rendez vous directement aux utilisateurs concernés ?

Y'a bien la notion de participants, mais il faut qu'ils valident le rendez vous pour que ce dernier apparaissent dans leur calendrier personnel ...

Partant du principe que l'utilisateur qui fera l'importation aura les droits d’écriture dans les calendriers des personnels concernés ...

Merci

**Oliv-** · 13/09/2017, 11h02

Bonjour,
Oui il y a 2 façon d'atteindre un calendrier partagé

Soit il est affiché dans tes calendriers / "Calendriers partagés"

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
 
Sub AjoutDansCalendrierPartagé()
'---------------------------------------------------------------------------------------
' Procedure : AjoutDansCalendrierPartagé
' Author    : Oliv
' Date      : 13/09/2017
' Purpose   :
'---------------------------------------------------------------------------------------
'
    Dim OL As Outlook.Application
    If UCase(Application) = "OUTLOOK" Then
        Set OL = Application
    Else
        Set OL = CreateObject("outlook.application")
    End If
    Dim objNS As Outlook.Namespace
    Dim objExpCal As Outlook.Explorer
    Dim objNavMod As Outlook.CalendarModule
    Dim objNavCalPart As Outlook.NavigationFolders
    Dim i, objNavFolder As Outlook.NavigationFolder, FolderPartage As Outlook.Folder
 
 
    Nom = "GsNord Paq" ' attention sensible à la casse
    Set objNS = OL.Session
    Set objExpCal = objNS.GetDefaultFolder(olFolderCalendar).GetExplorer
    Set objNavMod = objExpCal.NavigationPane.Modules.GetNavigationModule(olModuleCalendar)
 
 
    Set objNavCalPart = objNavMod.NavigationGroups.Item("Calendriers partagés").NavigationFolders
 
    Set objNavFolder = objNavCalPart(Nom)
 
    On Error Resume Next
    FoldName = objNavFolder.Folder.Name & "-" & objNavFolder.Folder.FullFolderPath
    If Err Then
        FoldName = "Pas accessible"
        MsgBox objitem & "-->" & FoldName, vbCritical
    Else
        MsgBox Nom & vbCr & FoldName, , "Accès autorisé à "
        Set FolderPartage = objNavFolder.Folder
        'ICI LE TRAITEMENT
        On Error GoTo 0
 
        Dim olcal As Outlook.AppointmentItem
        Set olcal = FolderPartage.Items.Add
        olcal.Subject = "test"
        olcal.Start = Now
        olcal.Duration = 60    'durée de rdv, en minutes
        olcal.Save
 
 
    End If
End Sub

Soit tu le recherches avec le nom de la personne ou son email

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
Private Sub Calendrier_partagé()
    Dim FolderPartage As Folder
    Dim OL As Outlook.Application
    Dim myrecipient As Recipient
    Dim objNS As Outlook.NameSpace
    If UCase(Application) = "OUTLOOK" Then
        Set OL = Application
    Else
        Set OL = CreateObject("outlook.application")
    End If
    Set objNS = OL.Session
    Set myrecipient = objNS.CreateRecipient("SOPHIE@TOTO.com")
 
    myrecipient.Resolve
    If myrecipient.Resolved Then
        Set FolderPartage = _
        objNS.GetSharedDefaultFolder _
                            (myrecipient, olFolderCalendar)
    End If
    On Error Resume Next
    accèsAutorisé = FolderPartage
    If Err Then
        MsgBox myrecipient, vbCritical, "Accès NON autorisé"
    Else
        MsgBox myrecipient & vbCr & FolderPartage, , "Accès autorisé à "
          On Error GoTo 0
        'ICI LE TRAITEMENT
 
    End If
End Sub

tu noteras que dans le cas d'un autre dossier ou n'utilise pas createitem mais add

Code :

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

1
2
3
4
5
6
        Dim olcal As Outlook.AppointmentItem
        Set olcal = FolderPartage.Items.Add
        olcal.Subject = "test"
        olcal.Start = Now
        olcal.Duration = 60    'durée de rdv, en minutes
        olcal.Save

**buggzbeny** · 17/09/2017, 09h20

Bonjour !

Encore encore moi !

Je n'ai pas encore eu l'occasion de tester pour les calendriers des collaborateurs, j'attends que le service informatique donne les droits à ma compagne sur les autres calendriers ...

Par contre une autre question :

Heure de visite 10h00
Duree de la visite : 2 jours de travail soit 2 * 8h = 16h

Si je fais avec la fonction durée il va me faire le rendez-vous de 10h00 à minuit puis ensuite le restant sur le lendemain or les les horaires des bureaux c'est 8h - 18h. Il faudrait donc qu'il me crée sur le premier jour de 10h00 à 18h avec la pause repas du midi soit 7h le premier jour puis ensuite 9h le lendemain de 8h à 18h avec la pause repas également.

Comment faire pour lui intégrer des heures d'ouvertures de bureau ?

Je sais je suis chiant avec mes questions ...

**buggzbeny** · 06/10/2017, 23h00

Encore moi !

J'ai trouvé la solution pour mon calcul d'heures de pause repas... et j'ai pu tester ton code pour l'écriture dans le dossier partagé !

Ca fonctionne (presque) nikel !

Je m'explique ...

Quand je crée le rendez-vous cela fonctionne parfaitement. Par contre quand je veux modifiéer le rendez vous existant rien ne se passe alors qu'il le trouve bien puisqu'il m'affiche le msgbox ...

Du coup je sèche complètement !

Si je modifie manuellement ou le supprime j'ai les droits ... donc je ne comprends pas pourquoi en passant par vba je ne peux pas !!!

ne serait ce pas à cause de la manière de créer le rendez vous avec :

Code :

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

Set olcal = FolderPartage.Items.Add

voici le code :

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
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
    'déclaration des variables
 
        Dim oOutlook As Outlook.Application
        Dim oAppointment As Outlook.AppointmentItem
        Dim namespaceOutlook As Outlook.NameSpace
        Dim DossierCalendrier As Outlook.MAPIFolder
        Dim sFilter As String
        Dim OL As Outlook.Application
 
        If UCase(Application) = "OUTLOOK" Then
            Set OL = Application
        Else
            Set OL = CreateObject("outlook.application")
        End If
        Set OL = New Outlook.Application
        Dim objNS As Outlook.NameSpace
        Dim objExpCal As Outlook.Explorer
        Dim objNavMod As Outlook.CalendarModule
        Dim objNavCalPart As Outlook.NavigationFolders
        Dim objNavFolder As Outlook.NavigationFolder, FolderPartage As Outlook.Folder
 
        Set objNS = OL.Session
        Set objExpCal = objNS.GetDefaultFolder(olFolderCalendar).GetExplorer
        Set objNavMod = objExpCal.NavigationPane.Modules.GetNavigationModule(olModuleCalendar)
 
 
        Set objNavCalPart = objNavMod.NavigationGroups.Item("Calendriers partagés").NavigationFolders
 
        Set objNavFolder = objNavCalPart(controleur_qs)
        Dim olcal As Outlook.AppointmentItem
 
 
        Set olcal = FolderPartage.Items.Add
 
 
 
        On Error Resume Next
        FoldName = objNavFolder.Folder.Name & "-" & objNavFolder.Folder.FullFolderPath
        If Err Then
            MsgBox "Probleme d'acces au calendrier partagé de :" & controleur_qs, vbCritical
        Else
 
             Set FolderPartage = objNavFolder.Folder
 
             sujetrdv = raison_sociale & " (" & departement & ") #" & numero_visite
 
             'on définit les critères de filtre afin de retrouver le rdv créé
 
             sFilter = "[Subject] = '" & sujetrdv & "' "
 
 
             'on cherche le ou les rdv correspondant aux critères
 
             Set olcal = FolderPartage.Items.Find(sFilter)
 
 
             'si au moins un rdv a été trouvé
 
             If Not olcal Is Nothing Then
 
                    msgbox ("TROUVE !!!")
                    'olcal.MeetingStatus = olNonMeeting
                    olcal.Start = date_debut & "    " & heure_debut & ":00"
                    If temps_1j = "ok" Then
 
                        olcal.Duration = duree_visite * 60 'durée de rdv, en minutes
 
                    End If
 
                    If temps_2j = "ok" Then
 
                        olcal.End = date_fin & "    " & heure_fin_finale & ":00"
 
                    End If
 
                    olcal.Body = corps_rdv
 
                    olcal.Location = adresse1 & " " & adresse2 & " " & code_postal & " " & commune 'Lieu du rdv
                    'on sauvegarde et ferme
 
                    olcal.Save
 
 
                 Set olcal = Nothing
              'End With
 
 
            Else
 
 
 
                 If UCase(Application) = "OUTLOOK" Then
                      Set OL = Application
                 Else
                      Set OL = CreateObject("outlook.application")
                 End If
 
 
                 Set objNS = OL.Session
                 Set objExpCal = objNS.GetDefaultFolder(olFolderCalendar).GetExplorer
                 Set objNavMod = objExpCal.NavigationPane.Modules.GetNavigationModule(olModuleCalendar)
 
 
                 Set objNavCalPart = objNavMod.NavigationGroups.Item("Calendriers partagés").NavigationFolders
 
                 Set objNavFolder = objNavCalPart(controleur_qs)
 
                 On Error Resume Next
                 FoldName = objNavFolder.Folder.Name & "-" & objNavFolder.Folder.FullFolderPath
                 If Err Then
                     MsgBox "Probleme d'acces au calendrier partagé de :" & controleur_qs, vbCritical
 
                 Else
 
                     Set FolderPartage = objNavFolder.Folder
                       'ICI LE TRAITEMENT
                     On Error GoTo 0
 
 
                    Set olcal = FolderPartage.Items.Add
                    With olcal
                        .MeetingStatus = olNonMeeting
                        .Subject = raison_sociale & " (" & departement & ") #" & numero_visite
                        .Start = date_debut & "    " & heure_debut & ":00"
 
                         If temps_1j = "ok" Then
 
                             .Duration = duree_visite * 60 'durée de rdv, en minutes
 
                         End If
 
                         If temps_2j = "ok" Then
 
                             .End = date_fin & "    " & heure_fin_finale & ":00"
 
                         End If
 
                         .Body = corps_rdv
 
                         .Location = adresse1 & " " & adresse2 & " " & code_postal & " " & commune 'Lieu du rdv
 
                         'on sauvegarde et ferme
 
                         .Save
                    End With
 
                 End If
 
                 Set olcal = Nothing
             End If

J'ai également essayé de le supprimer en faisant ceci mais sans succès

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
 'on cherche le ou les rdv correspondant aux critères
 
             Set olcal = FolderPartage.Items.Find(sFilter)
 
 
             'si au moins un rdv a été trouvé
 
             If Not olcal Is Nothing Then
 
                    msgbox ("TROUVE !!!")
                    olcal.delete
                    'olcal.MeetingStatus = olNonMeeting
                    olcal.Start = date_debut & "    " & heure_debut & ":00"

Merci d'avance !

**Oliv-** · 07/10/2017, 19h50

salut,
tu as sans doute une erreur dans ton code
déjà il faut commenter les lignes pour voir les messages d'erreur.

' On Error Resume Next

après quand cela fonctionne tu peux le remettre mais sur une partie celle où tu testes if err...

ensuite pour rétablir l’arrêt sur les erreurs tu mets un

Code :

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

on error goto 0

lignes 42 ET 114 de ton code

Création automatisée de rendez-vous depuis lecture de fichier de données .txt

VBA Outlook

Discussions similaires

Partager

Partager