[OL-2003] Syncronisation google agenda

[Leonhart]

Bonjour,

Je souhaite synchroniser les rendez-vous de mon calendrier Outlook avec mon calendrier Google. Or, je n'ai pas la possibilité d'utiliser un logiciel ou plugin externe (ordinateur du boulot, tout ca, tout ca ).

Du coup, je me rabat sur une macro Outlook qui me permettrai d'envoyer les rendez-vous des 7 prochains jours a mon compte gmail. Mais je n'ai pas trouvé comment envoyer un rendez-vous en entier, a la place, je creer un mail avec les informations du rdv en esperant que la detection syntaxique crée correctement le rdv sur google calc.

Ce qui n'est pas le cas, evidement.

Voici le code :

Code :

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
 
Sub export()
 
Dim objOutlook As New Outlook.Application
Dim objOutlookAppt As Outlook.AppointmentItem
Dim objOutlookCalendar As Outlook.Items
Dim objOutlookNameSpace As Outlook.NameSpace
 
Dim DaysToSync As Integer
Dim Dest As String
Dim Subject As String
Dim Date_deb() As String
 
' TO BE ADAPTED
'#################################################
Dest = "compte@gmail.com"
DaysToSync = 7
'#################################################
 
Set objOutlookNameSpace = objOutlook.GetNamespace("MAPI")
Set objOutlookCalendar = objOutlookNameSpace.GetDefaultFolder(olFolderCalendar).Items
 
objOutlookCalendar.Sort "[Start]"
objOutlookCalendar.IncludeRecurrences = True
 
DateDebut = Date
DateFin = DateAdd("d", DaysToSync, DateDebut)
DateDebut = Replace(DateDebut, ".", "/")
DateFin = Replace(DateFin, ".", "/")
 
Set objOutlookAppt = objOutlookCalendar.Find("[Start] >= '" & DateDebut & "' and [Start] <= '" & DateFin & "'")
 
'-------------------------------------------------------------------'
'                                                                   '
While TypeName(objOutlookAppt) <> "Nothing"
 
        Date_deb = Split(CStr(objOutlookAppt.Start), " ")
 
        If UBound(Date_deb) = 1 Then
            Hour_deb = Split(Date_deb(1), ":")
            DateDebut = Hour_deb(0) & ":" & Hour_deb(1)
        End If
 
 
        Subject = objOutlookAppt.Subject & " at " & objOutlookAppt.Location & " on " & Date_deb(0) & " at " & DateDebut
 
        Set Mail_Object = CreateObject("Outlook.Application")
        Set Mail_Single = Mail_Object.CreateItem(0)
        With Mail_Single
            .Subject = Subject
            .To = Dest
            .Send
        End With
 
 
    Set objOutlookAppt = objOutlookCalendar.FindNext
 
Wend
'                                                                   '
'-------------------------------------------------------------------'
 
End Sub

Ma question etant : Comment envoyé directement le RDV outlook a Gmail ?
Bonus : Avez vous une idee pour eviter d'envoyer deux fois le meme rendez-vous a Gmail suite a deux synchronisation ?

Merci bien !

[jimay]

Hello,

As-tu jeté un oeil à ceci ?

ça pourrait ptêt être utile ?

GL & HF

[Leonhart]

Comme bien souvent, c'etait tout bete.
Voici le code :

Code :

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
Sub export()
 
Dim objOutlook As New Outlook.Application
Dim objOutlookAppt As Outlook.AppointmentItem
Dim objOutlookAppt_tbs As Outlook.AppointmentItem
Dim objOutlookCalendar As Outlook.Items
Dim objOutlookNameSpace As Outlook.NameSpace
 
Dim DaysToSync As Integer
Dim Dest As String
Dim Subject As String
Dim Date_deb() As String
 
' TO BE ADAPTED
'#################################################
Dest = "xxx@gmail.com"
DaysToSync = 7
'#################################################
 
Set objOutlookNameSpace = objOutlook.GetNamespace("MAPI")
Set objOutlookCalendar = objOutlookNameSpace.GetDefaultFolder(olFolderCalendar).Items
 
objOutlookCalendar.Sort "[Start]"
objOutlookCalendar.IncludeRecurrences = True
 
DateDebut = Date
DateFin = DateAdd("d", DaysToSync, DateDebut)
DateDebut = Replace(DateDebut, ".", "/")
DateFin = Replace(DateFin, ".", "/")
 
Set objOutlookAppt = objOutlookCalendar.Find("[Start] >= '" & DateDebut & "' and [Start] <= '" & DateFin & "'")
 
'-------------------------------------------------------------------'
'                                                                   '
While TypeName(objOutlookAppt) <> "Nothing"
 
        Set objOutlookAppt_tbd = Outlook.CreateItem(olAppointmentItem)
        objOutlookAppt_tbd.Subject = objOutlookAppt.Subject
        objOutlookAppt_tbd.Location = objOutlookAppt.Location
        objOutlookAppt_tbd.MeetingStatus = olMeeting
        objOutlookAppt_tbd.Start = objOutlookAppt.Start
        objOutlookAppt_tbd.End = objOutlookAppt.End
        objOutlookAppt_tbd.RequiredAttendees = "baptistegrand.info@gmail.com"
        objOutlookAppt_tbd.Body = objOutlookAppt.Body
        MsgBox objOutlookAppt.Subject
        objOutlookAppt_tbd.Send
 
 
    Set objOutlookAppt_tbd = Nothing
    Set objOutlookAppt = objOutlookCalendar.FindNext
 
Wend
'                                                                   '
'-------------------------------------------------------------------'
 
End Sub

Reste plus qu'a trouver un moyen de ne pas synchroniser deux fois le meme RDV.

Merci,

[Leonhart]

Et voici la solution finale.

La macro pose une categorie sur les mails deja synchronisés pour ne pas les ajouter plusieurs fois au calendrier Gmail.

Code :

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
Sub export()
 
Dim objOutlook As New Outlook.Application
Dim objOutlookAppt As Outlook.AppointmentItem
Dim objOutlookAppt_tbs As Outlook.AppointmentItem
Dim objOutlookCalendar As Outlook.Items
Dim objOutlookNameSpace As Outlook.NameSpace
 
Dim DaysToSync As Integer
Dim Dest As String
Dim Subject As String
Dim Date_deb() As String
 
' TO BE ADAPTED
'#################################################
Dest = "XXX@gmail.com"
DaysToSync = 14
'#################################################
 
Set objOutlookNameSpace = objOutlook.GetNamespace("MAPI")
Set objOutlookCalendar = objOutlookNameSpace.GetDefaultFolder(olFolderCalendar).Items
 
objOutlookCalendar.Sort "[Start]"
objOutlookCalendar.IncludeRecurrences = True
 
DateDebut = Date
DateFin = DateAdd("d", DaysToSync, DateDebut)
DateDebut = Replace(DateDebut, ".", "/")
DateFin = Replace(DateFin, ".", "/")
 
Set objOutlookAppt = objOutlookCalendar.Find("[Start] >= '" & DateDebut & "' and [Start] <= '" & DateFin & "'")
 
'-------------------------------------------------------------------'
'                                                                   '
While TypeName(objOutlookAppt) <> "Nothing"
 
    If objOutlookAppt.Categories <> "Synchronized" Then
 
        Set objOutlookAppt_tbd = Outlook.CreateItem(olAppointmentItem)
        objOutlookAppt_tbd.Subject = objOutlookAppt.Subject
        objOutlookAppt_tbd.Location = objOutlookAppt.Location
        objOutlookAppt_tbd.MeetingStatus = olMeeting
        objOutlookAppt_tbd.Start = objOutlookAppt.Start
        objOutlookAppt_tbd.End = objOutlookAppt.End
        objOutlookAppt_tbd.RequiredAttendees = Dest
        objOutlookAppt_tbd.Body = objOutlookAppt.Body
        objOutlookAppt_tbd.Send
        objOutlookAppt_tbd.Delete
 
        objOutlookAppt.Categories = "Synchronized"
        objOutlookAppt.Save
 
    End If
 
    Set objOutlookAppt_tbd = Nothing
    Set objOutlookAppt = objOutlookCalendar.FindNext
 
Wend
'                                                                   '
'-------------------------------------------------------------------'
 
End Sub

En esperant que ca sera utile a d'autre !