Allora…
Pubblico quanto ottenuto solo per curiosita', perche' il risultato e' notevolmente instabile.
Per cercare di "catturare" i dati della stazione, infatti, apro la pagina web tramite il browser di sistema e poi salvo su disco la pagina; ma questo non mi da' nessun controllo sul caricamento, sicche' nel codice ci sono dei tempi di attesa qua e là di parecchi secondi, sperando che siano sufficienti per le operazioni.
Inoltre il comportamento e' diverso sui vari browser; in particolare non funziona su Chrome e IE, mentre ha funzionato (con qualche comportamento instabile) su Firefox ed Edge. Per non aggiungere criticita' ai tempi di esecuzione e' meglio se il browser sia gia' aperto quando si lancera' la macro.
Infine dopo il lancio della macro il pc non deve essere toccato fino al completamento della stessa (cioe' fino a quando non sara' visualizzata nuovamente la finestra Excel); in questa fase sara' attivato il browser, verra' aperta la pagina web in una nuova scheda, si attende circa 8 secondi per dare tempo alla pagina di caricarsi, si attiva il comando Salva, si chiude la scheda del browser, si riattiva Excel. Ogni intervento da mouse o da tastiera e' da evitare.
Il codice comprende delle dichiarazioni iniziali, la Sub GetLineaMeteo (la macro da mandare in esecuzione) e la Sub GetStat
All'interno della Sub GetLineaMeteo va inserito il codice della stazione da importare; teoricamente quindi si possono importare i dati di piu' stazioni (basta inserire nella Sub GetLineaMeteo piu' istruzioni
Call GetStat(NumeroStazione) ). Tuttavia il file deve includere un foglio che abbia il nome di ognuna delle stazioni, perche' ogni stazione importera' sul "suo" foglio la tabella con i dati in tempo reale.
Inoltre all'interno della Sub GetStat va dichiarato una directory di servizio in cui il contenuto della pagina web verra' salvato (vedi riga marcata <<<-1). La directory deve gia' esistere.
La macro raccoglie nel foglio dedicato alla stazione tutti i dati presenti nella tabella; l'utente puo' attingere alla tabella per portare sul suo schema le informazioni desiderate.
Il codice:
- Codice: Seleziona tutto
#If VBA7 Then '!!! ON TOP OF THE VBA MODULE !!!!
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
#Else
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
#If VBA7 Then
Declare PtrSafe Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hWnd As Long, _
ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
#Else
Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hWnd As Long, _
ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
#End If
Sub GetLineaMeteo()
Call GetStat(1976) '<<< Il numero della Stazione VEDI TESTO!
End Sub
Sub GetStat(StatID As String)
Dim TmpFile As String, htDoc As Object, myID As Object, myTabl As Object
Dim dSh As Worksheet, myFile As String, dFile As String, myURL As String
Dim tDtD As Object, tRtR As Object, myRep, iTx
'
Set dSh = Sheets(StatID)
dSh.Range("A:B").ClearContents
'
TmpFile = "C:\PROVA" & "\myStation.html" '<<<-1 Vedi Testo
'
dFile = Replace(TmpFile, ".html", "_files\stazioni.html", , , vbTextCompare)
Debug.Print ">>> " & StatID
myURL = "http://www.lineameteo.it/stazioni.php?id=" & StatID
On Error Resume Next
Kill TmpFile
Kill dFile
Sleep 100
On Error GoTo 0
Result = ShellExecute(0&, vbNullString, myURL, _
vbNullString, vbNullString, vbNormalFocus)
If Result < 32 Then
MsgBox "Errore in apertura Pagina web"
Exit Sub
End If
Debug.Print Format(Now, "hh:mm:ss"), "Result=" & Result
Application.DisplayAlerts = False
'
Sleep 8000 '<<<-2 VEDI TESTO
Application.SendKeys "^s", True
Sleep 2000
skfile = TmpFile & "~"
Application.SendKeys skfile, True
Debug.Print Format(Now, "hh:mm:ss"), TmpFile
Sleep 3000
Application.SendKeys "^w"
Sleep 500
Application.DisplayAlerts = True
'
Set htDoc = CreateObject("HTMLfile") 'late binding alla html obj lib
Set FSO = CreateObject("Scripting.FilesystemObject")
On Error Resume Next
Set PubFile = FSO.OpenTextFile(dFile, 1, False)
If Err.Number <> 0 Then
MsgBox "Errore: " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
"Operazione non completata"
Exit Sub
End If
On Error GoTo 0
'
'Legge file e compila tabella:
htDoc.Open
htDoc.write PubFile.ReadAll
DoEvents
Sleep 100
PubFile.Close
'
On Error Resume Next
For I = 1 To 20
Sleep 500
DoEvents
Set myID = htDoc.getElementById("tabs-1")
If Not myID Is Nothing Then Exit For
Next I
On Error GoTo 0
Debug.Print Format(Now, "hh:mm:ss"), "I=" & I
dSh.Range("A1") = myID.getElementsByTagName("h1")(0).innerText
dSh.Range("A2") = myID.getElementsByTagName("span")(1).innerText
Set myTabl = myID.getElementsByTagName("table")(0)
myRep = Array("Ã", "a'", "Â", " ")
I = 3
For Each tRtR In myTabl.Rows
For Each tDtD In tRtR.Cells
iTx = tDtD.innerText
For k = 0 To UBound(myRep) Step 2
iTx = Replace(iTx, myRep(k), myRep(k + 1), , , vbTextCompare)
Next k
Cells(I + 1, J + 1) = iTx
J = J + 1
Next tDtD
I = I + 1: J = 0
Next tRtR
I = I + 1
dSh.Range("B2").Value = "Aggiornato alle: " & Format(Now, "hh:mm:ss")
AppActivate Application.Caption
End Sub
Va messo in un "Modulo standard" del vba inizialmente vuoto (in modo che le "dichiarazioni" siano assolutamente in testa al Modulo)
Si modificano le istruzioni marcate <<< e <<<-1 (nome della stazione e Directory da usare per il salvataggio della pagina; se non funzionasse (pagina web non salvata o messaggio di errore) si puo' provare a modificare l'istruzione marcata <<<-2 (tempo di attesa prima di provare a salvare la pagina)
Nel caso che proprio non funzionasse la cosa non mi merevigliera'; posso come consolazione pubblicare il video del mio schermo mentre esegue fortunosamente le operazioni, ma il debug puo' solo essere fatto localmente e conuna certa difficolta'.
Buona fortuna a chi vorra' provare, quindi...
Registrazione
