Copier un choix d'événement d'un calendrier personnel sur un calendrier commun existant

**Thom2702** · 08/12/2016, 15h34

Bonjour,

Je rencontre un problème sur lequel je souhaite solliciter votre aide.
Sur le plan professionnel, je gère mon calendrier via Outlook... J'ai créé un calendrier commun pour l'équipe afin de pouvoir y insérer les congés de chacun...

Néanmoins, pour éviter une double saisie par les personnes (saisir les congés à la fois dans leur planning personnel et sur le calendrier commun) je souhaiterais mettre en place une macro qui sélectionnerai les évènements dont le libellé comporterait "congés" et les coller dans le calendrier commun....

J'ai déjà travaillé sur la macro....
Je parviens à copier coller TOUS LES événements... pas uniquement les événements comportant "congés" dans le libellé par exemple....

Voici 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
Sub test()
 
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
 
'Pour chaque evenements, on va le copier dans l'autre calendrier
For Each EvenCalend In MonDoss.Items
    'On defini les variables de l'evenement, debut, fin, sujet etc.
    Sujet = EvenCalend.Subject
    DateDeb = EvenCalend.Start
    DateFin = EvenCalend.End
    Texte = EvenCalend.Body
    Lieu = EvenCalend.Location
 
    'On fait pointer sur le secon calendrier, celui ou on va copier les infos.
    Set MonDoss2 = MonNameSpace.GetDefaultFolder(olFolderCalendar)
    Set MonSousDoss = MonDoss2.Folders(1)
 
    'On cree un nouvel evenement sur le second calendrier
    Set MonObj = MonSousDoss.Items.Add(olAppointmentItem)
 
    'On affecte les variables precedentes a début, fin, sujet etc.
    MonObj.Start = DateDeb
    MonObj.End = DateFin
    MonObj.Subject = Sujet
    MonObj.Body = Texte
    MonObj.Location = Lieu
 
    'On ferme et on sauvegarde.
    MonObj.Close olSave
 
    'MonObj.Display
 
Next EvenCalend
 
End Sub

Merci pour votre aide préciseuse!!!
Bien à vous

**Oliv-** · 08/12/2016, 16h40

salut,

tu peux tester

Code :

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

1
2
3
4
if instr(1,Sujet,"Congé", vbTextCompare) > 0 then
 
 
end if

tu peux aussi procéder par copier coller de ton rdv dans l'autre dossier

Code :

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

1
2
set MonObj =EvenCalend.copy
Monobj.move MonSousDoss

et ne pas oublié d'ajouter le nom du user, pour savoir qui est en congés

**Thom2702** · 08/12/2016, 17h19

Bonsoir Oliv,

Cela ne fonctionne pas...
J'ai sans doute fait une erreur ??
Merci pour ton retour,

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
Sub test()
 
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
 
'Pour chaque evenements, on va le copier dans l'autre calendrier
 
For Each EvenCalend In MonDoss.Items
    If InStr(1, Sujet, "Congés", vbTextCompare) > 0 Then
 
    'On defini les variables de l'evenement, debut, fin, sujet etc.
    Sujet = EvenCalend.Subject
    DateDeb = EvenCalend.Start
    DateFin = EvenCalend.End
    Texte = EvenCalend.Body
    Lieu = EvenCalend.Location
 
    'On fait pointer sur le second calendrier, celui ou on va copier les infos.
    Set MonDoss2 = MonNameSpace.GetDefaultFolder(olFolderCalendar)
    Set MonSousDoss = MonDoss2.Folders(1)
 
    'On cree un nouvel evenement sur le second calendrier
    Set MonObj = MonSousDoss.Items.Add(olAppointmentItem)
 
    'On affecte les variables precedentes a début, fin, sujet etc.
    MonObj.Start = DateDeb
    MonObj.End = DateFin
    MonObj.Subject = Sujet
    MonObj.Body = Texte
    MonObj.Location = Lieu
 
    'On ferme et on sauvegarde.
    MonObj.Close olSave
 
    'MonObj.Display
 
End If
 
Next EvenCalend
 
End Sub

**Oliv-** · 09/12/2016, 15h01

SALUT

Code :

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

1
2
3
4
5
6
7
For Each EvenCalend In MonDoss.Items
 
'On defini les variables de l'evenement, debut, fin, sujet etc.
Sujet = EvenCalend.Subject
 
 
If InStr(1, Sujet, "Congés", vbTextCompare) > 0 Then

**Thom2702** · 13/12/2016, 08h15

Envoyé par Oliv-

SALUT

Code :

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

1
2
3
4
5
6
7
For Each EvenCalend In MonDoss.Items
 
'On defini les variables de l'evenement, debut, fin, sujet etc.
Sujet = EvenCalend.Subject
 
 
If InStr(1, Sujet, "Congés", vbTextCompare) > 0 Then

Salut Oliv,

Tout d'abord désolé pour le temps de réponse... Début de semaine assez agité!!

vivement Noël !!
Je viens de tester le code, cela fonctionne parfaitement!! Merci beaucoup!!
Par contre, juste une dernière demande que je n'arrive pas à résoudre non plus (je crois avoir dépassé mes compétences limitées en VBA!!)

Lorsque je fais tourner la macro, il me recopie à chaque fois l'évènement... Ce qui fait que je me retrouve avec des doublons voire triplons en fonction du nombre de fois où j'exécute la macro...
Comment puis-je faire pour qu'il ne me recopie pas l'évènement s'il existe déjà dans le calendrier de destination stp ??

Code :

Sub test()

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

'Pour chaque événements, on va le copier dans l'autre calendrier

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
DateFin = EvenCalend.End
Texte = EvenCalend.Body
Lieu = EvenCalend.Location

'On fait pointer sur le second calendrier, celui où l'on va copier les infos.
Set MonDoss2 = MonNameSpace.GetDefaultFolder(olFolderCalendar)
Set MonSousDoss = MonDoss2.Folders(1)

'On créé un nouvel événement sur le second calendrier
Set MonObj = MonSousDoss.Items.Add(olAppointmentItem)

'On affecte les variables précédentes à début, fin, sujet etc.
MonObj.Start = DateDeb
MonObj.End = DateFin
MonObj.Subject = Sujet
MonObj.Body = Texte
MonObj.Location = Lieu

'On ferme et on sauvegarde.
MonObj.Close olSave

'MonObj.Display

End If

Next EvenCalend

End Sub

**Oliv-** · 13/12/2016, 14h55

Bonjour il faut utiliser la balise code c'est l'icone #

Tu dois vérifier si le rdv existe dans le calendrier commun

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
Sub test()
 
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
 
'Pour chaque événements, on va le copier dans l'autre calendrier
 
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
DateFin = EvenCalend.End
Texte = EvenCalend.Body
Lieu = EvenCalend.Location
 
'On fait pointer sur le second calendrier, celui où l'on va copier les infos.
Set MonDoss2 = MonNameSpace.GetDefaultFolder(olFolderCalendar)
Set MonSousDoss = MonDoss2.Folders(1)
 
if fc_AppointmentExist (EvenCalend.Start,EvenCalend.subject,MonSousDoss)=false then 
'On créé un nouvel événement sur le second calendrier
Set MonObj = MonSousDoss.Items.Add(olAppointmentItem)
 
'On affecte les variables précédentes à début, fin, sujet etc.
MonObj.Start = DateDeb
MonObj.End = DateFin
MonObj.Subject = Sujet
MonObj.Body = Texte
MonObj.Location = Lieu
 
'On ferme et on sauvegarde.
MonObj.Close olSave
 
'MonObj.Display
End if
 
End If
 
Next EvenCalend
 
End Sub

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
Private Sub test_fc_AppointmentExist()
    Dim strDate
    Dim MyAgendaFolder As Outlook.Folder
    strDate = VBA.Format(Date - 1, "Short Date") & " 11:00 am"
    Set MyAgendaFolder = Application.GetNamespace("mapi").GetDefaultFolder(olFolderCalendar)
    MsgBox fc_AppointmentExist(CDate(strDate), "#123#PDF", MyAgendaFolder)
 
End Sub
Function fc_AppointmentExist(DateToCheck As Date, Sujet As String, MyAgendaFolder As Outlook.Folder) As Boolean
    Dim searchAgenda As Items
    Dim filtre
     fc_AppointmentExist = False
    Set searchAgenda = MyAgendaFolder.Items
    filtre = "[Start] = '" & Trim(Format(DateToCheck, "ddddd h:nn AMPM")) & "' and [Subject] = '" & Sujet & "'"
    Set searchAgenda = searchAgenda.Restrict(filtre)
    If searchAgenda.Count > 0 Then fc_AppointmentExist = True
 
End Function

Je t'invite à consulter cette page

http://www.slipstick.com/developer/c...dar-using-vba/
qui aborde le sujet différemment, l'usage du GUID peut être intéressant.

**Thom2702** · 13/12/2016, 16h41

ça à l'air bien complet l'information que tu m'as donné...
J'ai testé mais rien à faire, ça ne fonctionne pas...

Je suis assez novice dans tout cela, tu as bien dû le voir!!

Du coup, je me suis "rabattu" sur ton code...
Et là, pareil... ça ne fonctionne pas... il me met une erreur de compilation : "type d'argument ByRef incompatible" au niveau de la ligne 28 :

If fc_AppointmentExist (EvenCalend.Start,EvenCalend.subject,MonSousDoss)=false then

Au niveau de "MonsousDoss"...

A n'y plus rien comprendre :'(
Je m'arrache les cheveux!! Sans doute pour une broutille en plus de cela.
Je ne perds pas espoir !!

Heureusement qu'il y a des âme charitable comme vous !!

Merciiiiiiiiiiii

Envoyé par Oliv-

Bonjour il faut utiliser la balise code c'est l'icone #

Tu dois vérifier si le rdv existe dans le calendrier commun

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
Sub test()
 
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
 
'Pour chaque événements, on va le copier dans l'autre calendrier
 
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
DateFin = EvenCalend.End
Texte = EvenCalend.Body
Lieu = EvenCalend.Location
 
'On fait pointer sur le second calendrier, celui où l'on va copier les infos.
Set MonDoss2 = MonNameSpace.GetDefaultFolder(olFolderCalendar)
Set MonSousDoss = MonDoss2.Folders(1)
 
if fc_AppointmentExist (EvenCalend.Start,EvenCalend.subject,MonSousDoss)=false then 
'On créé un nouvel événement sur le second calendrier
Set MonObj = MonSousDoss.Items.Add(olAppointmentItem)
 
'On affecte les variables précédentes à début, fin, sujet etc.
MonObj.Start = DateDeb
MonObj.End = DateFin
MonObj.Subject = Sujet
MonObj.Body = Texte
MonObj.Location = Lieu
 
'On ferme et on sauvegarde.
MonObj.Close olSave
 
'MonObj.Display
End if
 
End If
 
Next EvenCalend
 
End Sub

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
Private Sub test_fc_AppointmentExist()
    Dim strDate
    Dim MyAgendaFolder As Outlook.Folder
    strDate = VBA.Format(Date - 1, "Short Date") & " 11:00 am"
    Set MyAgendaFolder = Application.GetNamespace("mapi").GetDefaultFolder(olFolderCalendar)
    MsgBox fc_AppointmentExist(CDate(strDate), "#123#PDF", MyAgendaFolder)
 
End Sub
Function fc_AppointmentExist(DateToCheck As Date, Sujet As String, MyAgendaFolder As Outlook.Folder) As Boolean
    Dim searchAgenda As Items
    Dim filtre
     fc_AppointmentExist = False
    Set searchAgenda = MyAgendaFolder.Items
    filtre = "[Start] = '" & Trim(Format(DateToCheck, "ddddd h:nn AMPM")) & "' and [Subject] = '" & Sujet & "'"
    Set searchAgenda = searchAgenda.Restrict(filtre)
    If searchAgenda.Count > 0 Then fc_AppointmentExist = True
 
End Function

Je t'invite à consulter cette page

http://www.slipstick.com/developer/c...dar-using-vba/
qui aborde le sujet différemment, l'usage du GUID peut être intéressant.

**Oliv-** · 13/12/2016, 17h11

essaye en déclarant les variables

Code :

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

dim MonSousDoss as outlook.folder

**Thom2702** · 13/12/2016, 17h16

Super, cela fonctionne parfaitement.

Il me reste à voir le fait de supprimer un congés dans l'agenda de départ... qu'il supprime également dans l'agenda de destination

J'essaye... si j'y arrive pas, je toquerai une dernière dernière dernière fois à ta porte Oliv!!

Merci beaucoup!!! ^^

Envoyé par Oliv-

essaye en déclarant les variables

Code :

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

dim MonSousDoss as outlook.folder

**Thom2702** · 16/12/2016, 09h30

Bonjour,

Je viens de passer quelques heures sur le code et certains éléments me manquent pour affiner la macro.

1 - Je ne parviens pas à faire fonctionner une fonction "OR" dans mon code
=> Je voudrais faire le test si le libellé du sujet contient le mot "congés" alors il me recopie l'événement dans le calendrier partagé MAIS EGALEMENT les événements qui peuvent contenir "ronde" ou encore 'formation"....

2 - J'ai trouvé un "dysfonctionnement" dans certains cas de recopie...
Dans outlook il est possible de créer un événement de congés, d'absence de telle heure à telle heure... Par contre il est également possible de créer un événement pour une journée entière en le mettant dans la case tout en haut du calendrier (juste en dessous du jour + date).. Cf photo

Nom : Capture.JPG
Affichages : 956
Taille : 32,2 Ko

Nom : Capture.JPG
Affichages : 956
Taille : 32,2 Ko

Lorsque l'événement est dans cet emplacement (journée entière), il le recopie bien dans le calendrier partagé... mais dès que j'active la macro, il me le recopie à chaque fois... il ne se pose pas la question de savoir si "il existe alors je ne le recopie pas..."

Je me permets de joindre mon code associé (en utilisant bien la balise CODE - désolé) :

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
Sub Copie_événement()
 
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
 
'Pour chaque événements, on va le copier dans l'autre calendrier.
 
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
DateFin = EvenCalend.End
Texte = EvenCalend.Body
Lieu = EvenCalend.Location
 
'On fait pointer sur le second calendrier, celui où l'on va copier les infos.
Set MonDoss2 = MonNameSpace.GetDefaultFolder(olFolderCalendar)
Set MonSousDoss = MonDoss2.Folders(1)
 
If fc_AppointmentExist(EvenCalend.Start, EvenCalend.Subject, MonSousDoss) = False Then
 
'On créé un nouvel événement sur le second calendrier
Set MonObj = MonSousDoss.Items.Add(olAppointmentItem)
 
'On affecte les variables précédentes à début, fin, sujet etc.
MonObj.Start = DateDeb
MonObj.End = DateFin
MonObj.Subject = Sujet
MonObj.Body = Texte
MonObj.Location = Lieu
 
'On ferme et on sauvegarde.
MonObj.Close olSave
 
End If
End If
Next EvenCalend
 
End Sub
 
 
Private Sub test_fc_AppointmentExist()
    Dim strDate
    Dim MyAgendaFolder As Outlook.Folder
    strDate = VBA.Format(Date - 1, "Short Date") & " 11:00 am"
    Set MyAgendaFolder = Application.GetNamespace("mapi").GetDefaultFolder(olFolderCalendar)
    MsgBox fc_AppointmentExist(CDate(strDate), "#123#PDF", MyAgendaFolder)
 
End Sub
Function fc_AppointmentExist(DateToCheck As Date, Sujet As String, MyAgendaFolder As Outlook.Folder) As Boolean
    Dim searchAgenda As Items
    Dim filtre
     fc_AppointmentExist = False
    Set searchAgenda = MyAgendaFolder.Items
    filtre = "[Start] = '" & Trim(Format(DateToCheck, "ddddd h:nn AMPM")) & "' and [Subject] = '" & Sujet & "'"
    Set searchAgenda = searchAgenda.Restrict(filtre)
    If searchAgenda.Count > 0 Then fc_AppointmentExist = True
 
End Function

Merci pour votre aide,
Merci encore à Oliv

**Oliv-** · 16/12/2016, 10h58

J'ai modifié ma fonction pour tenir compte des rdv sur une journée

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
Function fc_AppointmentExist(DateToCheck As Date, Sujet As String, MyAgendaFolder As Outlook.Folder) As Boolean
    Dim searchAgenda As Items
    Dim filtre
    fc_AppointmentExist = False
    Set searchAgenda = MyAgendaFolder.Items
    If DatePart("h", DateToCheck) + DatePart("n", DateToCheck) = 0 Then
        filtre = "[Start] = '" & Format(DateToCheck, "ddddd") & " 0:00 AM' " & " and [Subject] = '" & Sujet & "'"
 
    Else
        filtre = "[Start] = '" & Trim(Format(DateToCheck, "ddddd h:nn AMPM")) & "' and [Subject] = '" & Sujet & "'"
    End If
    Set searchAgenda = MyAgendaFolder.Items.Restrict(filtre)
    If searchAgenda.Count > 0 Then fc_AppointmentExist = True
 
End Function

pour tester plusieurs mots CONTENUS DANS LE SUJET, remplaces

Code :

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

If InStr(1, Sujet, "Congés", vbTextCompare) > 0 Then

par

Code :

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

If InStr(1, Sujet, "Congés", vbTextCompare) > 0 or InStr(1, Sujet, "formation", vbTextCompare) > 0  or InStr(1, Sujet, "ronde", vbTextCompare) > 0 Then

**Thom2702** · 16/12/2016, 11h11

Merci !!

Alors côté rdv sur une journée cela fonctionne très bien. C'est parfait.

Par contre pour ce qui est de la fonction OR j'ai un message d'erreur lors du lancement de la macro...

Nom : Capture.JPG
Affichages : 923
Taille : 19,8 Ko

Nom : Capture.JPG
Affichages : 923
Taille : 19,8 Ko

Je n'ai jamais eu ce message lol.

**Oliv-** · 16/12/2016, 15h39

faut publier tout ton code !

**Thom2702** · 19/12/2016, 08h09

Envoyé par Oliv-

faut publier tout ton code !

Oupsss désolé.
Voici mon code au complet.

Merci beaucoup!

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
Sub Copie_événement()
 
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
 
'Pour chaque événements, on va le copier dans l'autre calendrier.
 
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 or InStr(1, Sujet, "formation", vbTextCompare) > 0  or InStr(1, Sujet, "ronde", vbTextCompare) > 0 Then
 
'On definit les variables de l'événement, début, fin, sujet etc.
Sujet = EvenCalend.Subject
DateDeb = EvenCalend.Start
DateFin = EvenCalend.End
Texte = EvenCalend.Body
Lieu = EvenCalend.Location
 
'On fait pointer sur le second calendrier, celui où l'on va copier les infos.
Set MonDoss2 = MonNameSpace.GetDefaultFolder(olFolderCalendar)
Set MonSousDoss = MonDoss2.Folders(1)
 
If fc_AppointmentExist(EvenCalend.Start, EvenCalend.Subject, MonSousDoss) = False Then
 
'On créé un nouvel événement sur le second calendrier
Set MonObj = MonSousDoss.Items.Add(olAppointmentItem)
 
'On affecte les variables précédentes à début, fin, sujet etc.
MonObj.Start = DateDeb
MonObj.End = DateFin
MonObj.Subject = Sujet
MonObj.Body = Texte
MonObj.Location = Lieu
 
'On ferme et on sauvegarde.
MonObj.Close olSave
 
End If
End If
Next EvenCalend
 
End Sub
 
 
Private Sub test_fc_AppointmentExist()
    Dim strDate
    Dim MyAgendaFolder As Outlook.Folder
    strDate = VBA.Format(Date - 1, "Short Date") & " 11:00 am"
    Set MyAgendaFolder = Application.GetNamespace("mapi").GetDefaultFolder(olFolderCalendar)
    MsgBox fc_AppointmentExist(CDate(strDate), "#123#PDF", MyAgendaFolder)
 
End Sub
Function fc_AppointmentExist(DateToCheck As Date, Sujet As String, MyAgendaFolder As Outlook.Folder) As Boolean
    Dim searchAgenda As Items
    Dim filtre
    fc_AppointmentExist = False
    Set searchAgenda = MyAgendaFolder.Items
    If DatePart("h", DateToCheck) + DatePart("n", DateToCheck) = 0 Then
        filtre = "[Start] = '" & Format(DateToCheck, "ddddd") & " 0:00 AM' " & " and [Subject] = '" & Sujet & "'"
 
    Else
        filtre = "[Start] = '" & Trim(Format(DateToCheck, "ddddd h:nn AMPM")) & "' and [Subject] = '" & Sujet & "'"
    End If
    Set searchAgenda = MyAgendaFolder.Items.Restrict(filtre)
    If searchAgenda.Count > 0 Then fc_AppointmentExist = True
 
End Function

**Thom2702** · 21/12/2016, 09h35

Envoyé par Oliv-

faut publier tout ton code !

Bonjour Oliv,

As-tu une idée par rapport à mon précédent message stp ?

Merci beaucoup!!
Cordialement,

**Oliv-** · 21/12/2016, 10h29

Bonjour,

Mis à part qu'il manque une déclaration de variable en haut de Copie_événement

sinon cela ne vient pas de là peut être un code dans un autre module où tu aurais fais des tests

Code :

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

1
2
Sub Copie_événement ()
Dim MonSousDoss As Outlook.Folder

et là il vaut mieux donner son nom que son index

Code :

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

Set MonSousDoss = MonDoss2.Folders(1)

Code :

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

Set MonSousDoss = MonDoss2.Folders("toto")

**Thom2702** · 21/12/2016, 10h49

Envoyé par Oliv-

Bonjour,

Mis à part qu'il manque une déclaration de variable en haut de Copie_événement

sinon cela ne vient pas de là peut être un code dans un autre module où tu aurais fais des tests

Code :

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

1
2
Sub Copie_événement ()
Dim MonSousDoss As Outlook.Folder

et là il vaut mieux donner son nom que son index

Code :

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

Set MonSousDoss = MonDoss2.Folders(1)

Code :

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

Set MonSousDoss = MonDoss2.Folders("toto")

Oui étrange... Pourtant je n'ai pas de module.
J'ai uniquement ce code sur ma feuille ThisOutlookSession...

:'( si proche du but, il y a de quoi rager! lol

**Thom2702** · 22/12/2016, 11h12

Je viens de réaliser un diagnostic complémentaire qui pourrait aider dans la réflexion....

Je viens de mettre uniquement le code :

Code :

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

If InStr(1, Sujet, "Congés", vbTextCompare) > 0 Then

Tout fonctionne parfaitement...

Par contre lorsque je remplace le mot "congés" par formation, il me met le message d'erreur déjà cité....
Dès que je change le mot "congés" finalement...

Par exemple, si je mets le mot "test" à la place de "congés" il me met le même message d'erreur mais "Erreur à Exposition".. au lieu de "Erreur à Eau"... Dans mon calendrier je n'ai pas du tout ce genre de terme en plus de ça...

Cela fait des heures que je cherche sans rien trouver !
A se taper la tête contre les murs!

**Oliv-** · 22/12/2016, 11h35

Salut,

Il faut que tu Suive le déroulement de ta macro en mode pas à pas (F8)

Pour voir précisément où se produit l'erreur !

**Thom2702** · 22/12/2016, 12h06

Bonjour Oliv,

J'ai enfin localisé l'erreur...
En fait il s'agit d'un libellé de sujet qu'il ne supporte pas... il n'aime pas l'apostrophe!!!
J'ai modifié tout cela et ça fonctionne parfaitement...

Par contre j'ai un autre soucis.
Je ne sais pas si tu peux m'aider.
Je ne sais pas si je dois cliquer sur résoudre et ouvrir un autre post...

J'ai partagé mon calendrier "commun" avec mes collègues...
Ils voient bien apparaître le calendrier, etc.. ils peuvent faire des modifications dessus, pas de soucis...

Par contre, lorsque je fais un copier coller de la macro sur leur Outlook, et que j'exécute, il me met un message d'erreur : "Index de la matrice en dehors des limites"...

Une idée en plus ?? lol

Copier un choix d'événement d'un calendrier personnel sur un calendrier commun existant

VBA Outlook

Discussions similaires

Partager

Partager