envoyer des rendez-vous depuis excel vers google agenda automatiquement

[Xave_be]

Bonjour la communauté,

Je suis à la recherche du macro pour pouvoir envoyer d'excel vers Google agenda.

La macro que j'utilise pour le moment envoie les rendez-vous d'excel vers outlook mais je n'arrive pas a synchroniser vers Google agenda

Comment puis-je faire?

Merci d'avance,

 

[GADENSEB]

bonjour,
Il a des années (avec la version 2 du langage de prog google) je passé par cett macro et cela marché au poil mais depuis qu'il sont passé au V3 cela ne fonctionne plus du tout.....
C'est pénible car moi aussi j'en ais besoin ...

si tu trouves une autre version je suis preneur !!!!

a+ Seb

Dim I, j As Integer

Sub GoogleAgenda()


With Worksheets("BASE EMPLOI")




On Error Resume Next
j = .Range("A2").End(xlDown).Row
For I = 2 To j
'Convertit la DATERELANCE en Format de DATE pour GOOGLEAGENDA
'.Cells(i, "AP") = "'" & Format(.Cells(i, "AL"), "yyyy-mm-dd")


If .Cells(I, 43) <> "ok" And .Cells(I, 42) <> "" Then

'================================== PARAMETRES GOOGLE AGENDA ==================================
Email = "XXXXXXXXXX@GMAIL.COM"
Passwd = "XXXXXXXXXXXX"
authUrl = "https://www.google.com/accounts/ClientLogin"
CALENDARURL = "http://www.google.com/calendar/feeds/default/private/full"
MAILINVITE = "XXXXXXXXXXXXXXXXXXXXXXXXXX"
LIEU = "XXXXXXXXXXXXXXXXXXXXX"


sujet = Range("C" & I).Value & " - " & Range("AF" & I).Value
DESCRIPTIONRDV = Range("AF" & I).Value
NOMINVITE = "Agenda Emploi"
DATEDEBUT = Range("AP" & I).Value & "T14:00:00.000Z"
DATEFIN = Range("AP" & I).Value & "T15:15:00.000Z"



'================================== CREATION D'UN EVENEMENT ==================================
calendarEntry = "<?xml version='1.0' ?><entry xmlns='http://www.w3.org/2005/Atom' " _
& "xmlns:gd='http://schemas.google.com/g/2005'>" _
& "<category scheme='http://schemas.google.com/g/2005#kind' " _
& "term='http://schemas.google.com/g/2005#event'></category>" _
& "<title type='text'>" & sujet & "</title>" _
& "<content type='text'>" & DESCRIPTIONRDV & "</content>" _
& "<author>" _
& "<name>" & NOMINVITE & "</name>" _
& "<email>" & MAILINVITE & "</email>" _
& "</author>" _
& "<gd:transparency " _
& "value='http://schemas.google.com/g/2005#event.opaque'>" _
& "</gd:transparency>" _
& "<gd:eventStatus " _
& "value='http://schemas.google.com/g/2005#event.confirmed'>" _
& "</gd:eventStatus>" _
& "<gd:where valueString='" & LIEU & "'></gd:where>" _
& "<gd:when startTime='" & DATEDEBUT & "' " _
& "endTime='" & DATEFIN & "'></gd:when>" _
& "</entry>"
'================================== AUTHENTIFICATION ==================================
Set objHTTP = CreateObject("Microsoft.XMLHTTP")
objHTTP.Open "POST", authUrl, False
objHTTP.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
objHTTP.send "Email=" + Email + "&Passwd=" + Passwd + "&service=cl&source=Gulp-CalGulp-1.05"
strAuthTokens = objHTTP.responseText
strAuthTokens = Replace(strAuthTokens, vbCr, "")
strAuthTokens = Replace(strAuthTokens, vbLf, "")
strAuthTokens = Replace(strAuthTokens, vbCrLf, "")
strAuthTokens = Replace(strAuthTokens, "SID", "&SID", 1, 1)
strAuthTokens = Replace(strAuthTokens, "LSID", "&LSID")
strAuthTokens = Replace(strAuthTokens, "Auth", "&Auth")
strAuthTokens = Right(strAuthTokens, Len(strAuthTokens) - Len("Auth=") - InStr(strAuthTokens, "Auth=") + 1)
Set objHTTP = Nothing
'================================== REDIRECT ==================================
Set objHTTP = CreateObject("Microsoft.XMLHTTP")
objHTTP.Open "POST", CALENDARURL, False
objHTTP.setRequestHeader "Content-Type", "application/atom+xml"
objHTTP.setRequestHeader "X-If-No-Redirect", "True"
objHTTP.setRequestHeader "Authorization", "GoogleLogin auth=" & strAuthTokens
objHTTP.send calendarEntry
'objHTTP.status should be 412
'================================== POST TO THE NEW URL ==================================
headers = objHTTP.getAllResponseHeaders()
strResponse = objHTTP.responseText
redirectStringPos = InStr(headers, "X-Redirect-Location:")
redirectStringLength = InStr(InStr(headers, "X-Redirect-Location:"), headers, vbCrLf) - InStr(headers, "X-Redirect-Location:")
redirectUrl = Replace(Mid(headers, redirectStringPos, redirectStringLength), "X-Redirect-Location: ", "")
Set objHTTP = CreateObject("Microsoft.XMLHTTP")
objHTTP.Open "POST", redirectUrl, False
objHTTP.setRequestHeader "Authorization", "GoogleLogin auth=" & strAuthTokens
objHTTP.setRequestHeader "Content-Type", "application/atom+xml"
objHTTP.send calendarEntry
'objHTTP.status should be 201

'If objHTTP.Status = 201 Then
'  MsgBox "Event saved"


End If
.Cells(I, 43) = "OK"
Next

End With

End Sub

Sub RDV_Calendrier()
'Nécessite d'activer la référence "Microsoft Outlook xx.x Object Library"
Dim OkApp As New Outlook.Application
Dim Rdv As Outlook.AppointmentItem
Dim I As Integer

With Worksheets("BASE EMPLOI")
j = .Range("A2").End(xlDown).Row

For I = 2 To j

Set Rdv = OkApp.CreateItem(olAppointmentItem)


.Cells(I, "AP") = Format(.Cells(I, "AL"), "m/d/yyyy")



If .Cells(I, "AQ") = "" Then

    Rdv.MeetingStatus = olMeeting
    Rdv.Subject = .Cells(I, "c").Value & " - " & .Cells(I, "AF").Value & " - " & .Cells(I, "AN").Value 'Sujet de la tâche
    Rdv.body = .Cells(I, "G").Value & " " & .Cells(I, "H").Value & " - " & .Cells(I, "J").Value & " - " & .Cells(I, "L").Value                 'Corps de la Relance
    Rdv.Location = "xxxxxxxxxxxxx"
    Rdv.Start = .Cells(I, "AL") & " 14:00"
    Rdv.Duration = 30 'minutes
    Rdv.Categories = "EMPLOI"
    Rdv.Save



.Cells(I, "AQ") = "OK"
Set OkApp = Nothing
End If
Next I
End With
End Sub