1) Lavorando nel browser e' possibile inserire l'autenticazione direttamente nella stringa url; esempio:
https://utente1%40gmail.com:PASSWORD1@m ... /feed/atom
(e' necessario simulare la prima @ con la stringa %40, altrimenti non funziona; notate anche l'uso di /a/ invece che /0/, /1/, etc)
La stessa tecnica usata nella Request invece non e' accettata
2) Abilitando le app meno sicure sono stato in grado di accedere a tutti gli accounts; peccato che inizialmente non fossi in grado di revocare una autorizzazione, quindi dopo aver autorizzato un utente non ero in grado di passare a un altro utente se non riavviando il pc.
3) Cercando come fare, mi sono imbattuto in questo articolo:
https://officetricks.com/excel-vba-clear-cache-ie/
Excel VBA Clear Cache – IE browser and xmlhttp requests
Il metodo che lancia RunDll32.exe tramite Shell non ha funzionato; ha invece funzionato il metodo che usa la Function InternetSetOptionStr. Quando dico "ha funzionato" intendo che l'autorizzazione data viene cancellata ed e' necessario, col mio codice, reintrodurre nuovo utente e nuova password.
Pertanto, nel file reperibile al solito link, ho inserito due macro:
Sub NUGMailParse (Nuovo Utente)
Sub GmailParse (e' la vecchia XMLParseGMail; lavora con l'autorizzazione esistente, if any)
In pratica:
-lanciate la Sub NUGMailParse se volete reimpostare l'utente
-lanciate la Sub GmailParse per il refresh del vecchio account
Notate che la macro NON azzera il contenuto del foglio prima di importare i nuovi dati (che quindi finiscono in coda ai precedenti); potrebbe essere utile inserire un Clear in testa alla GmailParse
Per i posteri, il codice delle due macro:
- Codice: Seleziona tutto
'RIGOROSAMENTE IN TESTA AL MODULO:
Declare Function InternetSetOptionStr Lib "wininet.dll" Alias "InternetSetOptionA" _
(ByVal hInternet As Long, ByVal lOption As Long, ByVal sBuffer As String, ByVal lBufferLength As Long) As Integer
Sub NUGMailParse() 'Imposta Account e Password
InternetSetOptionStr 0, 42, sBuf, 0
Call GmailParse
End Sub
- Codice: Seleziona tutto
Sub GmailParse() 'Legge l'account correntemente autorizzato
'Vedi http://www.pc-facile.com/forum/viewtopic.php?f=26&t=110777
'Derivata da http://www.pc-facile.com/forum/viewtopic.php?f=26&t=110596
' ..........................................................................
' >>>>> Richiede il riferimento alla libreria Microsoft XML <<<<<<
' in Menu /Strumenti /Riferimenti, cercare "Microsoft XML V.xx" e Spuntarla
' ..........................................................................
'
Dim MasterN As String, mySplit, myNext As Long
Dim xmlDoc As Object, I As Long
Dim cNCnt As Long, CipCiop As Object, myTim As Single
'Dim Request As New XMLHTTP30
Dim Request As XMLHTTP30
Dim myRic As String
MasterN = "//feed" '<<< Nodo principale
'
Set Request = New XMLHTTP30
Set xmlDoc = New MSXML2.DOMDocument
'
Debug.Print ">>>> GO >>> ", Format(Now, "hh:mm:ss")
myTim = Timer
myRic = "https://mail.google.com/mail/u/0/feed/atom"
Request.Open "GET", myRic
Request.send
'
Do Until Request.readyState = 4
If Timer > (myTim + 60) Or Timer < myTim Then Exit Do
Debug.Print "Do loop: ", myTim, Format(Timer - myTim, "0.00"), Request.readyState
DoEvents
myWait (0.2)
Loop
Debug.Print "End Do: ", myTim, Format(Timer - myTim, "0.00"), Request.readyState
'xmlDoc.LoadXML Request.responseText
Debug.Print ">>>ResponseText..." & Left(Request.responseText, 500) & "...<<<"
Dim Cioppa As String, lrPos As Long, eTagPos As Long
'Operazioni di pulizia del file xml:
Cioppa = Request.responseXML.XML
Cioppa = Replace(Cioppa, "<entry>", Chr(10) & "<entry>", , , vbTextCompare)
'Cioppa = Replace(Cioppa, " version=""0.3"" xmlns=""http://purl.org/atom/ns#""", "", , , vbTextCompare) 'inutile
Debug.Print "Cleaning >>>..."
Do
'elimina "<link "
lrPos = InStr(1, Cioppa, "<link ", vbTextCompare)
If lrPos = 0 Then Exit Do
eTagPos = InStr(lrPos, Cioppa, "/>", vbTextCompare)
If eTagPos > lrPos Then
Debug.Print Mid(Cioppa, lrPos, eTagPos - lrPos + 2)
Cioppa = Replace(Cioppa, Mid(Cioppa, lrPos, eTagPos - lrPos + 2), "", , , vbTextCompare)
End If
DoEvents
Loop
Debug.Print "...<<< Cleaned"
Debug.Print ">>>CioppaCleaned.." & Left(Cioppa, 500) & "...<<<"
'
'prima posizione libera nel foglio:
On Error Resume Next
myNext = 0
myNext = Range("A1:AZ10000").Find(What:="*", After:=Range("A1"), _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
On Error GoTo 0
myNext = myNext + 1
'
xmlDoc.LoadXML (Cioppa) 'Carica xmlDoc
For I = 1 To Cells(1, Columns.Count).End(xlToLeft).Column 'per ogni intestazione colonna
Debug.Print ">Importing nodes: " & Cells(1, I).Value
For cNCnt = 0 To 1000
If InStr(1, Cells(1, I).Value, "#", vbTextCompare) <> 0 Then 'Verifica se "attributo"
mySplit = Split("/" & Cells(1, I).Value, "#", , vbTextCompare) 'Gestion Attributo
If UBound(mySplit) > 0 Then
If Len(mySplit(0)) < 3 Then mySplit(0) = ""
Set CipCiop = Nothing
On Error Resume Next
Set CipCiop = xmlDoc.SelectNodes(MasterN & mySplit(0))(cNCnt).Attributes.getNamedItem(mySplit(1))
On Error GoTo 0
If Not CipCiop Is Nothing Then
Cells(myNext + cNCnt, I) = xmlDoc.SelectNodes(MasterN & mySplit(0))(cNCnt).Attributes.getNamedItem(mySplit(1)).Text
End If
Debug.Print MasterN & mySplit(0) & "#" & mySplit(1), cNCnt, Cells(myNext + cNCnt, I)
End If
Else 'Gestion ItemText
Set CipCiop = Nothing
On Error Resume Next
Set CipCiop = xmlDoc.SelectNodes(MasterN & "/" & Cells(1, I).Value)(cNCnt)
On Error GoTo 0
If Not CipCiop Is Nothing Then
Cells(myNext + cNCnt, I) = xmlDoc.SelectNodes(MasterN & "/" & Cells(1, I).Value)(cNCnt).Text
End If
Debug.Print MasterN & "/" & Cells(1, I).Value, cNCnt, Left(Cells(myNext + cNCnt, I), 80)
End If
If CipCiop Is Nothing Then Exit For
Next cNCnt
DoEvents
Next I
'Fine:
Debug.Print Format(Timer - myTim, "0.00"), "<<<< END"
Set xmlDoc = Nothing
'Call Clear_Cache
'VBA.Shell "RunDll32.exe InetCpl.Cpl, ClearMyTracksByProcess 11", vbHide
MsgBox ("Completata importazione")
End Sub
Sub myWait(myStab As Single)
Dim myStTiM As Single
'
myStTiM = Timer
Do 'wait myStab
DoEvents
If Timer > myStTiM + myStab Or Timer < myStTiM Then Exit Do
Loop
End Sub
Ciao
