[XL-2010] Optimisation Code / Google Agenda

Re bonjour le Forum,
Je cherche à optimiser mon code !

Plusieurs idées que je déployerais au fur et a mesure :

La 1ére

Cette bdd gére mon google Agenda

Avec l'usf BASEEMPLOI, je rentre les infos dans la BDD
Puis avec l'onglet "BASE EMPLOI" je génére mon googleagenda via la macro GOOGLEAGENDA()

je voudrais que la macro soit incluse dans le code de l'usf BASEEMPLOI commence quand je valide la saisie, le googleagenda est aussi tôt généré.....

Qui à une idée ?

Bonne aprem

Seb

Dans un premier temps les dates doivent être transformées gràce à ce code de l'onglet BASE EMPLOI

Code:

1
2
3
4
5
6
7
8
9
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
'Convertit la DATERELANCE en Format de DATE pour GOOGLEAGENDA
j = Range("A1").End(xlDown).Row
For i = 2 To j
  Cells(i, "AP") = "'" & Format(Cells(i, "AL"), "yyyy-mm-dd")
 Cells(i, "A") = Cells(i, "B") & "-" & Cells(i, "C") & "-" & Cells(i, "AF") & "-" & Cells(i, "BB")
Next
End Sub

Puis une macro de sélection des lignes à utiliser

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Private Sub GERERAGENDA_Click()
 
'Private Sub AGENDA()
 
On Error Resume Next
j = Range("A2").End(xlDown).Row
 
For i = 2 To j
If Cells(i, 43).Value <> "OK" And Cells(i, 42).Value <> "" Then
GOOGLEAGENDA
Cells(i, 43).Value = "OK"
End If
Next
 
End Sub

Puis le GoogleAgenda

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
Sub GOOGLEAGENDA()
 
 
'================================== PARAMETRES GOOGLE AGENDA ==================================
Email = "XXX@gmail.com"
Passwd = "XXXX"
authUrl = "https://www.google.com/accounts/ClientLogin"
CALENDARURL = "http://www.google.com/calendar/feeds/default/private/full"
MAILINVITE = "XXXX@free.fr"
LIEU = "XXXXXXXXXXXXXXX"
 
 
 
sujet = Range("C" & i).Value & " - " & Range("AF" & i).Value
DESCRIPTIONRDV = Range("AF" & i).Value
NOMINVITE = "Agenda Emploi"
 
DATEDEBUT = Range("AP" & i).Value & "T13:00:00.000Z"
'DATEDEBUT = Range("F" & i).Value
'& "<gd:when startTime='2014-05-09T13:00:00.000Z' " _
Sheets("Feuil1").Range(int1 & "255" & ":" & int2 & "255").Select
'ConcRange = CStr(rngCell.Value)
DATEFIN = Range("AP" & i).Value & "T17:00:00.000Z"
'DATEFIN = Range("F" & i).Value
'& "endTime='2014-05-09T17:00:00.000Z'></gd:when>" _
 
 
'================================== CREATION D'UN EVENEMENT ==================================
calendarEntry = "<?xml version='1.0' ?><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'>" & sujet & "</title>" _
& "<content type='text'>" & DESCRIPTIONRDV & "</content>" _
& "<author>" _
& "<name>" & NOMINVITE & "</name>" _
& "<email>" & MAILINVITE & "</email>" _
& "</author>" _
& "<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='" & LIEU & "'></gd:where>" _
& "<gd:when startTime='" & DATEDEBUT & "' " _
& "endTime='" & DATEFIN & "'></gd:when>" _
& "</entry>" _
'================================== AUTHENTIFICATION ==================================
Set objHTTP = CreateObject("Microsoft.XMLHTTP")
objHTTP.Open "POST", authUrl, False
objHTTP.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
objHTTP.send "Email=" + Email + "&Passwd=" + Passwd + "&service=cl&source=Gulp-CalGulp-1.05"
strAuthTokens = objHTTP.responseText
strAuthTokens = Replace(strAuthTokens, vbCr, "")
strAuthTokens = Replace(strAuthTokens, vbLf, "")
strAuthTokens = Replace(strAuthTokens, vbCrLf, "")
strAuthTokens = Replace(strAuthTokens, "SID", "&SID", 1, 1)
strAuthTokens = Replace(strAuthTokens, "LSID", "&LSID")
strAuthTokens = Replace(strAuthTokens, "Auth", "&Auth")
strAuthTokens = Right(strAuthTokens, Len(strAuthTokens) - Len("Auth=") - InStr(strAuthTokens, "Auth=") + 1)
Set objHTTP = Nothing
 
'================================== REDIRECT ==================================
Set objHTTP = CreateObject("Microsoft.XMLHTTP")
objHTTP.Open "POST", CALENDARURL, False
objHTTP.setRequestHeader "Content-Type", "application/atom+xml"
objHTTP.setRequestHeader "X-If-No-Redirect", "True"
objHTTP.setRequestHeader "Authorization", "GoogleLogin auth=" & strAuthTokens
objHTTP.send calendarEntry
'objHTTP.status should be 412
 
'================================== POST TO THE NEW URL ==================================
headers = objHTTP.getAllResponseHeaders()
strResponse = objHTTP.responseText
redirectStringPos = InStr(headers, "X-Redirect-Location:")
redirectStringLength = InStr(InStr(headers, "X-Redirect-Location:"), headers, vbCrLf) - InStr(headers, "X-Redirect-Location:")
redirectUrl = Replace(Mid(headers, redirectStringPos, redirectStringLength), "X-Redirect-Location: ", "")
 
Set objHTTP = CreateObject("Microsoft.XMLHTTP")
objHTTP.Open "POST", redirectUrl, False
objHTTP.setRequestHeader "Authorization", "GoogleLogin auth=" & strAuthTokens
objHTTP.setRequestHeader "Content-Type", "application/atom+xml"
objHTTP.send calendarEntry
'objHTTP.status should be 201
 
'If objHTTP.Status = 201 Then
 '  MsgBox "Event saved"
'End If
 
End Sub

Pièce jointe 150657

Bonsoir,
Je modifie le titre de mon poste pour moi s'il ya plus de motivés :ptdr:

Bonne soirée

Seb