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