BlueSky9
Messages postés6Date d'inscriptionlundi 16 avril 2007StatutMembreDernière intervention25 mars 2014
-
Modifié par Whismeril le 25/03/2014 à 06:38
Whismeril
Messages postés19029Date d'inscriptionmardi 11 mars 2003StatutContributeurDernière intervention26 avril 2024
-
25 mars 2014 à 06:40
Bonjour,
Je suis en train d'essayer de pouvoir créer, modifier et supprimer des événements dans un calendrier google à partir de vb6.
J'ai trouvé un code sur internet qui fais la connexion au calendrier google, j'ai réussi à adapter le code pour récupérer les événements et les infos dont j'ai besoin. Maintenant, je voudrais être capable de modifier un événement précis ou le supprimer. Est-ce que quelqu'un peut m'aider, je ne suis pas très à l'aise avec ce genre de code et je me considère débutant en programmation.
Voici mon code actuel et merci pour l'aide que vous pourrez m'apporter :
Dim xmlCals As MSXML2.IXMLDOMNodeList ' Liste des agendas.
Option Explicit
Public bFinAttente As Boolean
Public stReponse As String
Dim stAuthCode As String
Public stRetHeader As String
Private Sub cdAfflst_Click()
AfficheListe True
WebBrowser1.Navigate2 "[https://www.google.com/calendar/render]"
Dim WshShell As Object
Set WshShell = CreateObject("WScript.Shell")
WshShell.SendKeys "{Enter}"
WshShell.SendKeys "{Enter}"
End Sub
Function GooEnvoi(stCde As String, stURl As String, Optional stFormData As String = "") As Boolean
Dim stHeaders As String
stHeaders = "Authorization: GoogleLogin auth=" & stAuthCode & _
"Content-Type:application/atom+xml"
bFinAttente = False
Inet1.Execute stURl, stCde, stFormData, stHeaders
Do Until bFinAttente = True
DoEvents
Loop
GooEnvoi = Mid(stRetHeader, 10, 2) = "20" ' ("HTTP/1.1 201 Created" ou "HTTP/1.1 200 OK" )
End Function
Private Sub Command1_Click()
Command1.Enabled = False
If GooAuthentification("MonEmail", "MonMotDePasse") Then
MsgBox "Connection OK : " & vbCrLf & stReponse
Command1.Caption = "Connecté"
Else
MsgBox "Erreur connexion : " & vbCrLf & stReponse
Command1.Caption = "Connection"
End If
Command1.Enabled = True
End Sub
Private Sub Inet1_StateChanged(ByVal State As Integer)
' Récupère la réponse du serveur à l'aide de la
' méthode GetChunk lorsque State = 12.
Select Case State
' ... Les autres cas ne sont pas décrits ici.
Case icRequestSent '6 , sur envoi requête Raz des variables string en retour
stReponse = ""
stRetHeader = ""
Case icError ' 11
'MsgBox "Une erreur s'est produite lors de la communication avec l'ordinateur hôte", vbCritical, "Erreur"
stReponse = "#-Erreur-Hote-BadAuthentication#"
bFinAttente = True
Case icResponseCompleted '12
Dim vtData As Variant ' Variable Data.
Dim strData As String: strData = ""
Dim bDone As Boolean: bDone = False
vtData = Inet1.GetChunk(1024, icString)
stRetHeader = Inet1.GetHeader()
DoEvents
Do While Not bDone
strData = strData & vtData
DoEvents
' Lecture du segment suivant.
vtData = Inet1.GetChunk(1024, icString)
If Len(vtData) = 0 Then
bDone = True
End If
Loop
stReponse = strData
bFinAttente = True
End Select
End Sub
'
' Authentification
'
Function GooAuthentification(stEmail As String, stPassword As String) As Boolean
Dim stURl As String
Dim stSource As String
Dim stFormData As String
Dim stHeaders As String
stSource = App.CompanyName & "-" & App.EXEName & "-" & App.Major & "." & App.Minor
stURl = "[https://www.google.com/accounts/ClientLogin]"
stFormData = "Email=" & stEmail & "&Passwd=" & stPassword & "&source=" & stSource & "&service=cl"
stHeaders = "Content-Type:application/x-www-form-urlencoded"
Inet1.Execute stURl, "POST", stFormData, stHeaders
'Mise à 0 flag d'attente réponse
bFinAttente = False
Do Until bFinAttente = True
DoEvents
Loop
If InStr(1, stRetHeader, "200 OK") > 0 Then
stAuthCode = Right(stReponse, Len(stReponse) - InStrRev(stReponse, "Auth=") - 4)
GooAuthentification = True
Else
GooAuthentification = False
End If
End Function
Private Sub Command2_Click()
If GooEnvoi(txtCde, txtUrl, EncodeUtf8(txtData)) Then
MsgBox "Envoi OK :" & vbCrLf & stReponse
Else
MsgBox "Réponse NOK :" & vbCrLf & stReponse
End If
End Sub
Sub AfficheListe(bProprietaire As Boolean)
Dim xmlEntry As IXMLDOMElement
Dim xmlReponse As New MSXML2.DOMDocument ' Réponse du serveur google.
Dim stURl As String
lstCals.Clear
stURl = IIf(bProprietaire, "[http://www.google.com/calendar/feeds/default/owncalendars/full]" _
, "[http://www.google.com/calendar/feeds/default/allcalendars/full]")
If GooEnvoi("GET", stURl) Then
If xmlReponse.loadXML(stReponse) Then
Set xmlCals = xmlReponse.selectNodes("/feed/entry")
For Each xmlEntry In xmlReponse.selectNodes("/feed/entry")
lstCals.AddItem DecodeUtf8(xmlEntry.selectSingleNode("title").Text)
Next
End If
End If
End Sub
Private Sub LstCals_Click()
Dim stURl As String
stURl = xmlCals(lstCals.ListIndex).selectSingleNode("content").Attributes.getNamedItem("src").Text
ListeEvents stURl
End Sub
'
' Affiche la liste des événments du calendrier sélectionné
'
Private Sub ListeEvents(stURl As String)
Dim xmlDocEvents As New MSXML2.DOMDocument
Dim xmlEntry As IXMLDOMElement
Dim xmlEvents As MSXML2.IXMLDOMNodeList
Dim DateDebut As Date
Dim DateFin As Date
Dim stTitre As String
LstEvents.Clear
If GooEnvoi("GET", stURl) Then
LstEvents.Clear
If xmlDocEvents.loadXML(stReponse) Then
Set xmlEvents = xmlDocEvents.selectNodes("/feed/entry")
For Each xmlEntry In xmlEvents
If stTitre = DecodeUtf8(xmlEntry.selectSingleNode("title").Text) Then
End If
DateDebut = xsDateTime(xmlEntry.selectSingleNode("gd:when").Attributes.getNamedItem("startTime").Text)
DateFin = xsDateTime(xmlEntry.selectSingleNode("gd:when").Attributes.getNamedItem("endTime").Text)
stTitre = DecodeUtf8(xmlEntry.selectSingleNode("title").Text)
txtDescripEvent = DecodeUtf8(xmlEntry.selectSingleNode("content").Text)
LstEvents.AddItem DateDebut & " au " & DateFin & " : " & stTitre & " : " & txtDescripEvent & " ; "
'xmlEntry.selectSingleNode("gd:where").Attributes.getNamedItem("valueString").Text
Next
End If
End If
End Sub
Function xsDateTime(st As String) As Date
Dim t As Date
If Len(st) > 12 Then
t = TimeValue(Mid(st, 12, 8))
End If
xsDateTime = DateSerial(Left(st, 4), Mid(st, 6, 2), Mid(st, 9, 2)) + t
End Function
'---------------------------------------------------------------------------------------
' Ajout d'un événement
'
Private Sub cdAjEvent_Click()
Dim stFormData As String
Dim stURl As String
Dim stDeb As String
Dim stFin As String
'stDeb = Format(dtPKdu.Value, "yyyy-mm-ddTHH:MM:00.000Z")
'stFin = Format(dtPkau.Value, "yyyy-mm-ddTHH:MM:00.000Z")
stDeb = Format(dtPKdu.Value, "yyyy-mm-dd")
stFin = Format(dtPkau.Value, "yyyy-mm-dd")
stURl = xmlCals.Item(lstCals.ListIndex).selectSingleNode("content").Attributes.getNamedItem("src").Text
stFormData = "<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'>" & EncodeUtf8(txtObjet) & "</title>" & _
" <content type='text'>" & EncodeUtf8(txtDescripEvent) & "</content>" & _
" <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='" & EncodeUtf8(txtLieuEvent) & "'></gd:where>" & _
" <gd:when startTime='" & stDeb & "'" & _
" endTime='" & stFin & "'></gd:when>" & _
" </entry>"
If GooEnvoi("POST", stURl, stFormData) Then
MsgBox "Ajout ok"
Else
MsgBox "Erreur "
End If
End Sub
