Private Sub vcGoogleSignIn()
Dim strURL As String, strFormData, strHeaders As String
Dim myEmail As String, myPassword As String, mySource As String, myCalendarID As String
Dim sSessionID As String, myPrivateCalendarID As String, sURL_Get As String
On Error GoTo btnAddEvent_Click_Error
myCalendarID = DLookup("[GoogleCalendar]", "[SettingsTable]")
'myPrivateCalendarID = DLookup("[GooglePrivateURL]", "[SettingsTable]")
myEmail = DLookup("[GoogleEmail]", "[SettingsTable]")
myPassword = DLookup("[GooglePassword]", "[SettingsTable]")
If myEmail = "" Then
MsgBox "The Google email(user id)is missing - cannot sign in", vbExclamation, "Validation Error...."
Exit Sub
End If
If myPassword = "" Then
MsgBox "The Google password is missing - cannot sign in", vbExclamation, "Validation Error...."
Exit Sub
End If
mySource = "MyDB Google Apps Demo"
strURL = "https://www.google.com/accounts/ClientLogin"
strFormData = "Email=" & myEmail & "&Passwd=" & myPassword '& "&source=" & mySource & "&service=cl"
strHeaders = "Content-Type:application/x-www-form-urlencoded"
DoCmd.Hourglass True
Call vcHTTP_POST(strURL, "POST", strFormData, "vcFirst")
Dim iloop As Integer
For iloop = 1 To 100
DoEvents
Next iloop
If InStr(vcResponse, "BadAuthentication") Then
MsgBox "Google refused logon. Confirm e-mail and password.", vbCritical, "Error"
Exit Sub
End If
AuthCode = Trim(Right(vcResponse, Len(vcResponse) - InStrRev(vcResponse, "Auth=") - 4))
lblGoogleStatus.Visible = True
On Error GoTo 0
DoCmd.Hourglass False
Exit Sub
btnAddEvent_Click_Error:
DoCmd.Hourglass False
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure AddTGoogle"
End Sub