Supprimer un événement dans le calendrier google

Signaler
Messages postés
6
Date d'inscription
lundi 16 avril 2007
Statut
Membre
Dernière intervention
25 mars 2014
-
Messages postés
15151
Date d'inscription
mardi 11 mars 2003
Statut
Contributeur
Dernière intervention
27 novembre 2020
-
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 

1 réponse

Messages postés
15151
Date d'inscription
mardi 11 mars 2003
Statut
Contributeur
Dernière intervention
27 novembre 2020
462
Bonjour, voir ici comment utiliser la coloration syntaxique.