Discussion :

[yeti7984]

bonjour

je souhaite dans le fichier joint pouvoir créer automatiquement via une macro des rendez vous dans outlook .

si on prends par exemple la feuille "-12f"

voila ce que je voudrais qu'il y ai dans les rendez vous :


objet : "match :" + colonne E "-" + colonne F
emplacement : colonne J
heure début : colonne C
heure fin : colonne d + 1h
date : colonne B

je n'ai pas trouvé sur le forum de réponse qui me permette d'avancer

je vous remercie d'avance pour votre aide

tableau entraineurs .xls

[yeti7984]

j'ai avancé un peu sur la macro

voir la macro rdv du fichier ci dessous

par contre j'ai un soucis au niveau de la date et heure .... ( start et duration)

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
Sub Rdv()
'
' Macro3 Macro
'
 
'
 
Dim derl As Integer
Dim i As Integer
 
derl = Range("b" & Rows.Count).End(xlUp).Row
 
 
For i = 11 To derl
 
    If Cells(i, 2) > 0 Then
 
Dim OkApp As New Outlook.Application
Dim Rdv As Outlook.AppointmentItem
 
Set Rdv = OkApp.CreateItem(olAppointmentItem)
 
With Rdv
    .MeetingStatus = olMeeting
    .Subject = Cells(3, 6) & " : " & Cells(i, 5) & " - " & Cells(i, 6)
    .Location = Cells(i, 10)
    .Start = #Cells(i, 2) & Cells(i, 3)
    .Duration =???????
    .Categories = "Handball"
    .Save
End With
 
Set OkApp = Nothing
 
 
 
    End If
 
 
Next
 
End Sub

voila le fichier mise a jour
tableau entraineurs .xls

[yeti7984]

eureka j'ai trouvé(avec de l'aide) , un problème de formatage de date, cela fonctionne.

par contre ce pose un problème :

ce fichier va être mise a jours assez régulièrement, il faudrait que je contrôle que le rendez vous n'existe pas déjà ... savez vous comment faire ?

le titre du rdv est unique , peu être peut on faire une comparaison par rapport a ca ?

merci de votre recherche

ps : voici le fichier modifié
handball v 2.1.xls

[yeti7984]

personne ne sait pour les doublons ?

j'ai essayé avec ce code (trouvé sur internet)

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
Set myOlApp = CreateObject("Outlook.Application" )
    Set myNameSpace = myOlApp.GetNamespace("MAPI" )
    Set myOlApp.ActiveExplorer.CurrentFolder = myNameSpace.GetDefaultFolder(olFolderCalendar)
    Set outlookitems = myOlApp.ActiveExplorer.CurrentFolder.Items
    Cpte = outlookitems.Count
 
        For x = 1 To Cpte
            'exemple de test : si le sujet est "toto" alors on supprime le rdv
            If outlookitems(x).Subject = "toto" Then
                outlookitems(x).Delete
            End If
        Next x

mais il me met une erreur index de la matrice en dehors des limites ( j'ai bien sur modifié le code pour l'adapter a mon cas )

voir la macro "rdv" du fichier joint et a jours ( la macro est a lancée une fois sur la feuille "-12f"

la je ne comprends pas ????? please

[yeti7984]

me revoila ...

j'avance a petit pas mais j'avance

j'ai trouvé une autre façon pour détecter un doublon , qui vu les commentaires ou je l'ai trouvé devrait fonctionner ... mais pas chez moi il me créé toujours les doublons

j'ai vraiment besoin d'une âme charitable pour me donner un coup de main

voici le code de la macro :

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
Sub Rdv()
'
' Macro3 Macro
'
 
'
 
Dim derl As Integer
Dim i As Integer
Dim heure As Date
Dim jours As Date
Dim depart As Date
Dim objet As String
Dim debmatch As Date
Dim finrdv As Date
 
 
 
derl = Range("b" & Rows.Count).End(xlUp).Row
 
 
For i = 11 To derl
 
    If Cells(i, 2) > 0 Then
 
heure = Cells(i, 3)
jours = Replace(Replace(Replace(Replace(Cells(i, 2), "samedi  ", ""), "dimanche  ", ""), "  ", "/"), " ", "/")
depart = jours + heure
objet = Cells(3, 6) & " : " & Cells(i, 5) & " - " & Cells(i, 6)
debmatch = Cells(i, 4)
finrdv = jours + Cells(i, 4) + CDate("01:00:00")
 
 
'-----------------------------
        Dim OutlApp As New Outlook.Application
        Dim OutlMapi As Outlook.Namespace
        Dim OutlFolder As Outlook.MAPIFolder
        Dim OutlAppointment As Outlook.AppointmentItem
        Dim OutlItems As Outlook.Items
        Dim DateDebut As String
 
 
 
        Set OutlMapi = OutlApp.GetNamespace("MAPI")
        Set OutlFolder = OutlMapi.GetDefaultFolder(olFolderCalendar)
        Set OutlItems = OutlFolder.Items
 
 
            On Error Resume Next
 
        Set OutlAppointment = OutlItems.Find("[start] = '" & depart & "'")
 
            On Error GoTo 0
 
'----- si pas de rendez vous a la date indiquée -------
            If OutlAppointment Is Nothing Then
 
 
'-----------------------------------
 
Dim OkApp As New Outlook.Application
Dim Rdv As Outlook.AppointmentItem
 
 
Set Rdv = OkApp.CreateItem(olAppointmentItem)
 
With Rdv
    .MeetingStatus = olMeeting
    .Subject = objet
    .Body = Cells(i, 1) & Chr(10) & "-début du match : " & debmatch & Chr(10) & Chr(10) & Chr(10) & Chr(10) & "-* entraineur : " & Cells(4, 3) & Chr(10) & "-* numéro entraineur : " & Cells(5, 3) & Chr(10) & "-* parent référent : " & Cells(6, 3) & Chr(10) & "-* téléphone référent : " & Cells(7, 3)
    .Location = Cells(i, 10)
    .Start = depart
    .End = finrdv
    .Categories = Cells(3, 6)
    .ReminderSet = False 'pas de rappel
    .Save
 
End With
 
Set OkApp = Nothing
 
 
 
    End If
    End If
 
 
 
Next i
 
 
End Sub

et voici le fichier avec les dernières modifications