Option Explicit
Dim AuthCode As String
Dim Responded As Boolean
Dim Response As String
Dim EventCode As String
Dim tzoffset As String

Private Sub btnAddEvent_Click()

Dim strURL As String, strFormData As String, strHeaders As String
Dim myEmail As String, myPassword As String, mySource As String

myEmail = txtEmailAddress.Text
myPassword = txtPassword.Text
mySource = "thepoorhouse-example-1"

Dim tz As New CTimeZone
tzoffset = Left(tz.Offset, 3) & ":" & Right(tz.Offset, 2)   'get the local computers timezone offset from GMT

'First we need to authenticate the user as a Google account holder.
strURL = "https://www.google.com/accounts/ClientLogin"
strFormData = "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)

EventCode = getEventCode    'prepare the event code

'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 = EventCode
strHeaders = "Authorization: GoogleLogin auth=" & AuthCode & _
    "Content-Type:application/atom+xml"
    
Responded = False
Inet1.Execute strURL, "POST", strFormData, strHeaders

'wait for server response - should confirm event

Do Until Responded = True
    DoEvents
Loop

If (InStr(Inet1.GetHeader, "201 Created") > 0) Then
    MsgBox "Event added", , "Success"
Else
    MsgBox "Event not added. Please check your input and try again." & vbCrLf & Inet1.GetHeader, vbCritical, "Failed"
End If
'go and check your Google calendar - your event should be there!

End Sub



Private Sub btnExit_Click()
Unload Me

End Sub

Private Sub Form_Load()
txtDate.Text = Date
txtTimeFrom.Text = Time
txtTimeTo.Text = DateAdd("h", 1, Time)

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
Dim formattedDate As String

'change the date into Google's yyyy-mm-dd format
formattedDate = Format(txtDate.Text, "yyyy-mm-dd")

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'>" & txtEventName.Text & "</title>" & vbCrLf & _
  "<content type='text'>" & txtDescription.Text & "</content>" & vbCrLf & _
  "<author>" & vbCrLf & _
    "<name>" & txtYourName.Text & "</name>" & vbCrLf & _
    "<email>" & txtEmailAddress.Text & "</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='" & txtLocation.Text & "'></gd:where>" & vbCrLf & _
  "<gd:when startTime='" & formattedDate & "T" & txtTimeFrom.Text & tzoffset & "'" & vbCrLf & _
    "endTime='" & formattedDate & "T" & txtTimeTo.Text & tzoffset & "'></gd:when>" & vbCrLf & _
"</entry>"


End Function