Here is what I got working - Login/Find Calendar/Delete Entry/Add
Entry
Public Sub DoGoogle()
Dim strURL As String, strFormData As String, strHeaders As String
Dim myEmail As String, myPassword As String, mySource As String
Dim POS1 As Long
Dim POSS As Long
Dim POSE As Long
Dim CK As Long
Dim strURLa As String
mySource = "Access"
'First we need to authenticate the user as a Google account
holder.
strURL = "https://www.google.com/accounts/ClientLogin";
strFormData = "accountType=HOSTED_OR_GOOGLE&Email=" & myEmail
& "&Passwd=" & myPassword & "&source=" & mySource & "&service=cl"
strHeaders = "Content-Type:application/x-www-form-urlencoded"
Inet1.Execute strURL, "POST", strFormData, strHeaders
'wait for server response - should include the auth token
Responded = False
Do Until Responded = True
DoEvents
Loop
'ensure password was correct according to Google
If InStr(Response, "BadAuthentication") Then 'password
didn't work
MsgBox "Google refused authorization. Please check your
email address and password and try again.", vbCritical, "Error"
Exit Sub 'quit
End If
'extract Google authorization token
AuthCode = Right(Response, Len(Response) - InStrRev(Response,
"Auth=") - 4)
'*********************
'Get list of calendars
'*********************
strURL = "http://www.google.com/calendar/feeds/default/
allcalendars/full"
strHeaders = "Authorization: GoogleLogin auth=" & AuthCode & _
"Content-Type:application/atom+xml"
Responded = False
Inet1.Execute strURL, "GET", , strHeaders
'wait for server response - should confirm event
Do Until Responded = True
DoEvents
Loop
If (InStr(Inet1.GetHeader, "200 OK") > 0) Then
POS1 = InStr(1, Response, "<title type='text'>MY CALENDAR</
title>")
POS1 = InStr(POS1, Response, "href")
POSS = InStr(POS1, Response, "'")
POSS = POSS + 1
POSE = InStr(POSS, Response, "'")
strURLa = Mid(Response, POSS, POSE - POSS)
End If
'*********************
'*********************
strURL = Nz(Me.GKEY, 0)
If Len(Trim(strURL)) > 1 Then
'now post the event in order for Google to give us a
session id.
strHeaders = "Authorization: GoogleLogin auth=" & AuthCode
& _
"Content-Type:application/atom+xml"
Responded = False
Inet1.Execute strURL, "DELETE", , strHeaders
'wait for server response - should confirm event
Do Until Responded = True
DoEvents
Loop
End If
'now post the event in order for Google to give us a session
id.
'strURL = "http://www.google.com/calendar/feeds/default/
private/full"
strFormData = getEventCode
strHeaders = "Authorization: GoogleLogin auth=" & AuthCode & _
"Content-Type:application/atom+xml"
Responded = False
Inet1.Execute strURLa, "POST", strFormData, strHeaders
'wait for server response - should confirm event
Do Until Responded = True
DoEvents
Loop
If (InStr(Inet1.GetHeader, "201 Created") > 0) Then
'Save the edit key
POS1 = 1
POS1 = InStr(POS1, Response, "edit")
POS1 = InStr(POS1, Response, "href")
POSS = InStr(POS1, Response, "'")
POSS = POSS + 1
POSE = InStr(POSS, Response, "'")
Me.GKEY = Mid(Response, POSS, POSE - POSS)
sDT = Me.DATE
' MsgBox "Event added" & Inet1.GetHeader, , "Success"
Else
MsgBox "Event not added. Please check your input and try
again." & vbCrLf & Inet1.GetHeader, vbCritical, "Failed"
End If
End Sub
Private Sub Inet1_StateChanged(ByVal STATE As Integer)
Dim vtData As Variant ' Data variable.
Dim outputString As String
Select Case STATE
' ... Other cases not shown.
Case icError ' 11
MsgBox "An error occured. Check both your and the server's
internet connection is working.", vbCritical, "Error"
Case icResponseCompleted ' 12
' Open a file to write to.
' Get the first chunk. NOTE: specify a Byte
' array (icByteArray) to retrieve a binary file.
vtData = Inet1.GetChunk(1024, icString)
Do While LenB(vtData) > 0
outputString = outputString + vtData
' Get next chunk.
vtData = Inet1.GetChunk(1024, icString)
Loop
Response = outputString
Responded = True
End Select
End Sub
Private Function getEventCode() As String
getEventCode = "<entry xmlns='http://www.w3.org/2005/Atom'" & vbCrLf &
_
"xmlns:gd='http://schemas.google.com/g/2005'>" & vbCrLf & _
" <category scheme='http://schemas.google.com/g/2005#kind'" & vbCrLf
& _
"term='http://schemas.google.com/g/2005#event'></category>" & vbCrLf
& _
" <title type='text'>" & NAME & " *****STAFF***** " & Staff & "</
title>" & vbCrLf & _
"<content type='text'>" & Staff & "</content>" & vbCrLf & _
"<author>" & vbCrLf & _
"<name>" & "DAN" & "</name>" & vbCrLf & _
"<email>" & "[EMAIL PROTECTED]" & "</email>" & vbCrLf & _
"</author>" & vbCrLf & _
"<gd:transparency" & vbCrLf & _
"value='http://schemas.google.com/g/2005#event.opaque'>" & vbCrLf
& _
"</gd:transparency>" & vbCrLf & _
"<gd:eventStatus" & vbCrLf & _
"value='http://schemas.google.com/g/2005#event.confirmed'>" &
vbCrLf & _
"</gd:eventStatus>" & vbCrLf & _
"<gd:where valueString='" & "Onsite" & "'></gd:where>" & vbCrLf & _
"<gd:when startTime='" & formattedDate & "T" & TIMEIN & ".000" &
Offset & "'" & vbCrLf & _
"endTime='" & formattedDate & "T" & TIMEOUT & ".000" & Offset &
"'></gd:when>" & vbCrLf & _
"</entry>"
End Function
--~--~---------~--~----~------------~-------~--~----~
You received this message because you are subscribed to the Google Groups
"Google Calendar Data API" group.
To post to this group, send email to
[email protected]
To unsubscribe from this group, send email to [EMAIL PROTECTED]
For more options, visit this group at
http://groups.google.com/group/google-calendar-help-dataapi?hl=en
-~----------~----~----~----~------~----~------~--~---
