Prova modificando
da
Result = ShellExecute(0&, vbNullString, myURL, _
vbNullString, vbNullString, vbNormalFocus)
a:
Result = ShellExecute(0&, vbNullString, myURL, _
vbNullString, vbNullString, 3)
Moderatori: Anthony47, Flash30005
#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
#If VBA7 Then
Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
(ByVal hwnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
Declare PtrSafe Function GetForegroundWindow Lib "user32" () As Long
#Else
Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
(ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Declare Function GetForegroundWindow Lib "user32" () 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
Dim mmm As Integer
'
Set dSh = Sheets(StatID)
dSh.Range("A:B").ClearContents
'
TmpFile = "C:\PROVA" & "\myStation.html" '<<<-1 Vedi Testo
'
wHand = GetForegroundWindow()
Debug.Print "Start ", "Active: " & AWCaption(wHand)
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, 3&) 'vbNormalFocus)
If Result < 32 Then
MsgBox "Errore in apertura Pagina web"
Exit Sub
End If
Sleep 100
Debug.Print Format(Now, "hh:mm:ss"), "Result=" & Result
wHand = GetForegroundWindow()
Debug.Print "Browser?.", "Active: " & AWCaption(wHand)
Application.DisplayAlerts = False
'
Sleep 8000 '<<<-2 VEDI TESTO
Application.SendKeys "^s", True
Sleep 2000
wHand = GetForegroundWindow()
Debug.Print "Save As??", "Active: " & AWCaption(wHand)
skfile = TmpFile & "~"
Application.SendKeys skfile, True
Sleep 200
wHand = GetForegroundWindow()
Debug.Print "Post ~ ", "Active: " & AWCaption(wHand)
Debug.Print Format(Now, "hh:mm:ss"), TmpFile
Sleep 3000
Application.SendKeys "^w"
Sleep 500
wHand = GetForegroundWindow()
Debug.Print "Browser?:", "Active: " & AWCaption(wHand)
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
wHand = GetForegroundWindow()
Debug.Print "Excel? ", "Active: " & AWCaption(wHand)
End Sub
Function AWCaption(ByVal cHand As Long) As String
Dim cTxt As String * 255
GetWindowText cHand, cTxt, Len(cTxt)
AWCaption = Trim(cTxt)
End Function
Start Active: Microsoft Excel - TEST
>>> 1976
12:35:53 Result=42
Browser?. Active: Microsoft Excel - TEST
Save As?? Active: Stazioni Rete Linea Meteo – Mozilla Firefox
Post ~ Active: Stazioni Rete Linea Meteo – Mozilla Firefox
12:36:03 C:\PROVA\myStation.html
Browser?: Active: Stazioni Rete Linea Meteo – Mozilla Firefox
Start Active: Microsoft Visual Basic - TEST.xls [in esecuzione] - [Modulo1 (codice)]
>>> 1976
13:41:56 Result=42
Browser?. Active: Microsoft Visual Basic - TEST.xls [in esecuzione] - [Modulo1 (codice)]
Save As?? Active: Stazioni Rete Linea Meteo – Mozilla Firefox
Post ~ Active: Stazioni Rete Linea Meteo – Mozilla Firefox
13:42:14 C:\ABC\myStation.html
Browser?: Active: Stazioni Rete Linea Meteo – Mozilla Firefox
#If VBA7 Then '!!! ON TOP OF THE VBA MODULE !!!!
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
#Else
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
Sub DaReteMir()
Dim IE As Object, myURLb As String, myID As Object
Dim I As Long, skArr, myTim As Single, dSh As Worksheet
'
Set dSh = Sheets("SheetA") '<<< Il foglio "parametri"
'
myURLb = "https://retemir.regione.marche.it/meteo/stazioni?codstaz="
Set IE = CreateObject("InternetExplorer.Application")
myTim = Timer
Debug.Print Format(Timer - myTim, "hh:mm:ss"), ">>>"
For I = 5 To dSh.Cells(Rows.Count, "A").End(xlUp).Row
dSh.Cells(I, 2).Resize(1, 6).ClearContents
dSh.Cells(I, 2).Value = "##Cerca##"
If dSh.Cells(I, 1) <> "" Then
reVai:
With IE
Debug.Print Format(Timer - myTim, "0.00"), myURLb & dSh.Cells(I, "A")
.navigate myURLb & dSh.Cells(I, "A")
.Visible = True
'' Stop '*** VEDI Testo
Do While .Busy: DoEvents: Loop 'Attesa not busy
Do While .readyState <> 4: DoEvents: Loop 'Attesa documento
End With
'
myStart = Timer 'attesa addizionale
Sleep 500
If IE.LocationURL = "https://retemir.regione.marche.it/login" Then
'eventuale Login:
Debug.Print Format(Timer - myTim, "0.00"), "Eseguo Login"
Set myID = IE.document.getElementById("loginform")
myID.getElementsByTagName("input")(0).Value = dSh.Range("B1").Value
myID.getElementsByTagName("input")(1).Value = dSh.Range("B2").Value
Sleep 100
IE.document.getElementById("btn-login-extended").Click
Sleep 3000
runlin = True
GoTo reVai
End If
Debug.Print Format(Timer - myTim, "0.00"), "Arrivato su: " & IE.LocationURL
If IE.LocationURL <> (myURLb & dSh.Cells(I, 1)) And runlin Then
MsgBox ("Destinazione non raggiunta, operazione terminata")
Debug.Print myURL, IE.LocationURL
GoTo ExitA
End If
'Importa dati di Stazione:
Set mycoll = Nothing
For J = 1 To 10
Set mycoll = IE.document.getElementsByClassName("leaflet-popup-content")
Debug.Print Format(Timer - myTim, "0.00"), "Typename(myColl): " & TypeName(mycoll)
Debug.Print " ", "Typename(myColl): " & TypeName(mycoll)
Debug.Print " ", "Items in myColl: " & mycoll.Length
If mycoll.Length > 0 Then Exit For
Debug.Print " ", "Loop J=" & J
Sleep 200
Next J
If mycoll.Length > 0 Then
On Error Resume Next
skArr = Array("Stazione", "Ultimo agg.", "Total Rain Today :", "Rain Intensity :", "Air Temperature :", "Relative Umidity :")
Debug.Print Format(Timer - myTim, "0.00"), "Ubound(mySplit): " & UBound(mySplit)
dSh.Cells(4, 2).Resize(1, 6) = skArr
mySplit = Split(mycoll(0).innerText, Chr(10), , vbTextCompare)
dSh.Cells(I, 2) = mySplit(1)
dSh.Cells(I, 3) = Replace(mySplit(3), skArr(1), "", , , vbTextCompare)
dSh.Cells(I, 4) = Replace(mySplit(4), skArr(2), "", , , vbTextCompare)
dSh.Cells(I, 5) = Replace(mySplit(5), skArr(3), "", , , vbTextCompare)
dSh.Cells(I, 6) = Replace(mySplit(6), skArr(4), "", , , vbTextCompare)
dSh.Cells(I, 7) = Replace(mySplit(7), skArr(5), "", , , vbTextCompare)
On Error GoTo 0
End If
End If
Next I
'Chiudi IE e completa
Debug.Print Format(Timer - myTim, "0.00"), "Completato"
ExitA:
IE.Quit
Set IE = Nothing
End Sub
#If VBA7 Then '!!! ON TOP OF THE VBA MODULE !!!!
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
#Else
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
Sub DaReteMir()
Dim IE As Object, myURLb As String, myID As Object
Dim I As Long, skArr, myTim As Single, dSh As Worksheet
Dim ArrSk(1 To 3)
'
Set dSh = Sheets("SheetA") '<<< Il foglio "parametri"
'
myURLb = "https://retemir.regione.marche.it/meteo/stazioni?codstaz="
Set IE = CreateObject("InternetExplorer.Application")
myTim = Timer
Debug.Print Format(Timer - myTim, "hh:mm:ss"), ">>>"
skArr = Array("Stazione", "Ultimo agg.", "Total Rain Today :", "Rain Intensity :", "Air Temperature :", "Relative Umidity :")
skArr1 = Array("Stazione", "Ultimo agg.", "Total Rain Todaly :", "Intensità Pioggia :", "Temperatura Aria :", "Umidità Relativa :")
skArr2 = Array("Stazione", "Ultimo agg.", "Pioggia TOT Oggi :", "Intensità di Pioggia :", "Temperatura Aria :", "Umidità Relativa :")
ArrSk(1) = skArr
ArrSk(2) = skArr1
ArrSk(3) = skArr2
For I = 5 To dSh.Cells(Rows.Count, "A").End(xlUp).Row
dSh.Cells(I, 2).Resize(1, 6).ClearContents
dSh.Cells(I, 2).Value = "##Cerca##"
If dSh.Cells(I, 1) <> "" Then
reVai:
With IE
Debug.Print Format(Timer - myTim, "0.00"), myURLb & dSh.Cells(I, "A")
.navigate myURLb & dSh.Cells(I, "A")
.Visible = True
'' Stop '*** VEDI Testo
Do While .Busy: DoEvents: Loop 'Attesa not busy
Do While .readyState <> 4: DoEvents: Loop 'Attesa documento
End With
'
myStart = Timer 'attesa addizionale
Sleep 500
If IE.LocationURL = "https://retemir.regione.marche.it/login" Then
'eventuale Login:
Debug.Print Format(Timer - myTim, "0.00"), "Eseguo Login"
Set myID = IE.document.getElementById("loginform")
myID.getElementsByTagName("input")(0).Value = dSh.Range("B1").Value
myID.getElementsByTagName("input")(1).Value = dSh.Range("B2").Value
Sleep 100
IE.document.getElementById("btn-login-extended").Click
Sleep 3000
runlin = True
GoTo reVai
End If
Debug.Print Format(Timer - myTim, "0.00"), "Arrivato su: " & IE.LocationURL
If IE.LocationURL <> (myURLb & dSh.Cells(I, 1)) And runlin Then
MsgBox ("Destinazione non raggiunta, operazione terminata")
Debug.Print myURL, IE.LocationURL
GoTo ExitA
End If
'Importa dati di Stazione:
Set myColl = Nothing
For J = 1 To 10
Set myColl = IE.document.getElementsByClassName("leaflet-popup-content")
If myColl.Length > 0 Then Exit For
Sleep 200
Next J
Debug.Print Format(Timer - myTim, "0.00"), "Typename(myColl): " & TypeName(myColl)
Debug.Print " ", "Items in myColl: " & myColl.Length
Debug.Print " ", "Loop J=" & J
If myColl.Length > 0 Then
On Error Resume Next
Debug.Print Format(Timer - myTim, "0.00"), "Ubound(mySplit): " & UBound(mySplit)
dSh.Cells(4, 2).Resize(1, 6) = skArr
mySplit = Split(myColl(0).innerText, Chr(10), , vbTextCompare)
dSh.Cells(I, 2) = mySplit(1)
dSh.Cells(I, 3) = GimmeVal(ArrSk, 1, myColl(0).innerText)
dSh.Cells(I, 4) = GimmeVal(ArrSk, 2, myColl(0).innerText)
dSh.Cells(I, 5) = GimmeVal(ArrSk, 3, myColl(0).innerText)
dSh.Cells(I, 6) = GimmeVal(ArrSk, 4, myColl(0).innerText)
dSh.Cells(I, 7) = GimmeVal(ArrSk, 5, myColl(0).innerText)
On Error GoTo 0
End If
End If
Next I
'Chiudi IE e completa
Debug.Print Format(Timer - myTim, "0.00"), "Completato"
ExitA:
IE.Quit
Set IE = Nothing
End Sub
Function GimmeVal(ByRef ArrArr, ByVal iInd As Long, ByVal InnerT As String) As Variant
Dim myPos As Long, I As Long, UpTo As Long
If Len(InnerT) < 5 Then Exit Function
For I = 1 To 3
' Set larr = ArrArr(I)
myPos = InStr(1, InnerT, ArrArr(I)(iInd), vbTextCompare)
If myPos > 0 Then Exit For
Next I
If myPos = 0 Then Exit Function
UpTo = InStr(myPos, InnerT & Chr(10), Chr(10), vbTextCompare)
GimmeVal = Mid(InnerT, myPos + Len(ArrArr(I)(iInd)), UpTo - myPos - Len(ArrArr(I)(iInd)))
End Function
Torna a Applicazioni Office Windows
Problema con copia dati senza formattazione Autore: systemcrack |
Forum: Applicazioni Office Windows Risposte: 9 |
Macro copia dati colonne non contigue su un altro file excel Autore: systemcrack |
Forum: Applicazioni Office Windows Risposte: 5 |
scrivere una parola in ComboBox e caricarla filtrando i dati Autore: ricky53 |
Forum: Applicazioni Office Windows Risposte: 3 |
Visitano il forum: Nessuno e 23 ospiti