GADENSEB
XLDnaute Impliqué
Bonjour le Forum,
cela faisait un moment !!!
J'ai une macro qui ne fonctionne plus !!! grrrr
cette macro me permettait de générer des rdv dans mon GoogleAgenda....
Mais là elle ne veut plus marcher.....
Schéma :
La date est passée au format GoogleAgenda puis création du rdv puis flag.
La modif de la date et le flag marche nikel, mais de création de rdv dans GoogleAgenda
Si qqn à une idée, je suis preneur !!
Bonne soirée
Seb
Dim i, j As Integer
cela faisait un moment !!!
J'ai une macro qui ne fonctionne plus !!! grrrr
cette macro me permettait de générer des rdv dans mon GoogleAgenda....
Mais là elle ne veut plus marcher.....
Schéma :
La date est passée au format GoogleAgenda puis création du rdv puis flag.
La modif de la date et le flag marche nikel, mais de création de rdv dans GoogleAgenda
Si qqn à une idée, je suis preneur !!
Bonne soirée
Seb
Dim i, j As Integer
Code:
Sub GOOGLEAGENDA()
With Worksheets("BASE EMPLOI")
'Convertit la DATERELANCE en Format de DATE pour GOOGLEAGENDA
j = .Range("A2").End(xlDown).Row
For i = 2 To j
.Cells(i, "D") = "'" & Format(.Cells(i, "C"), "yyyy-mm-dd")
On Error Resume Next
j = .Range("A2").End(xlDown).Row
'For i = 2 To j
If .Cells(i, 5).Value <> "OK" And .Cells(i, 4).Value <> "" Then
'================================== PARAMETRES GOOGLE AGENDA ==================================
Email = "xxxxxxxxxxxxxxx"
Passwd = "xxxxxxxxxxxxxxxxxxxxxx"
authUrl = "https://www.google.com/accounts/ClientLogin"
CALENDARURL = "http://www.google.com/calendar/feeds/default/private/full"
MAILINVITE = "xxxxxxxxxxxxxxxxxxxxxxxxxxxx"
LIEU = "xxxxxxxxxxxxxxxxxxxxxxxxxxx"
Sujet = Range("A" & i).Value & " - " & Range("B" & i).Value
DESCRIPTIONRDV = Range("B" & i).Value
NOMINVITE = "Agenda Emploi"
DATEDEBUT = Range("D" & i).Value & "T14:00:00.000Z"
DATEFIN = Range("D" & 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, 5).Value = "OK"
End If
Next
End With
End Sub