Moderatori: Anthony47, Flash30005
di Anthony47 » 13/02/18 00:40
Se per "inserire uno stop" intendi "smettere di importare le altre tabelle" allora nella Sub GetWebTab2AA che usi dovresti aggiungere questa riga in questa posizione:l'unica cosa che mi manca è inserire uno stop dopo aver importato 15 tabelle. Si può fare qualcosa?
mysplit = Split(myItm.ID, "_", , vbTextCompare)
If UBound(mysplit) > 0 Then
jk = jk + 1: If jk > 15 Then Exit For '<<<< AGGIUNGERE QUESTA
mytar = "https://www.diretta.etc etc
di Denis7 » 14/02/18 18:47
Function GetTabRaim222Denis7(ByVal uurrll As String, ByVal ttAAbb As String, myDest As Range) As Variant
'Vedi http://www.pc-facile.com/forum/viewtopic.php?f=26&t=100441&p=642086#p642086
'Variante della Function GetTabRaim222
'Usa Classname per identificare la tabella da importare
'
'restituisce: N°TabellaImportata + TotTabellePresenti/100, se esito regolare
' 0, se esito irregolare
Dim BetFlag As Boolean, myColl, my2Coll, IE As Object, LnkCnt As Long
Dim myRetr As Long, I0 As Long, I As Long, myLink As Object
'
myurl = uurrll '
Set IE = CreateObject("InternetExplorer.Application")
'
Refr:
With IE
'Debug.Print "---------"
.navigate myurl
.Visible = False
End With
'wait for page...
myreS = ieWaitPage(IE, 1, 60) 'sessione, Stab Time, TimeOut time
If myreS <> 0 Then
If myRetr < 5 Then
myRetr = myRetr + 1
GoTo Refr
Else
Rispo = MsgBox("3 errori sulla pagina; recuperare manualmente e poi:" _
& vbCrLf & "-premere OK se recuperato" _
& vbCrLf & "-premere CANCEL se non recuperabile e quindi Abort della raccolta", vbOKCancel)
If Rispo <> vbOK Then GoTo AbortA
End If
End If
myRetr = 0
'
'Leggi le tabelle
myDest.Cells(1, 1).Resize(500, 20).ClearContents
'Stop
DoEvents
''I = 5
Set myColl = IE.document.getElementsByTagName("TABLE")
''Set my2Coll = IE.document.getElementsByTagName("A")
If myColl.Length = 0 Then 'Vedi "Edit" in fondo
GoTo AbortA
End If
' Set myItm = myColl(ttAAbb - 1)
For Each myItm In myColl
I = I + 1
If myItm.className = ttAAbb Then
For Each trtr In myItm.Rows
For Each tdtd In trtr.Cells
myDest.Cells(1, 1).Offset(KK, jj) = tdtd.innerText
jj = jj + 1
Next tdtd
KK = KK + 1: jj = 0
Next trtr
Exit For
End If
Next myItm
GetTabRaim222Denis7 = I + myColl.Length / 100 '>1=Ok
'
'Stop 'Vedi testo
'
fineA:
'Chiusura IE
IE.Quit
Set IE = Nothing
Set myColl = Nothing
Exit Function
'
AbortA:
GetTabRaim222Denis7 = 0 '0=Abort
GoTo fineA
End Function
Sub GetWebTab2AAB()
'prove dep Denis7
Dim IE As Object, F As Long
Dim myRColl, myDColl, KK As Long, I As Long, J As Long, myColl, myR, myTD
'
myurl = "https://www.diretta.it/squadra/oklahoma-city-thunder/0fHFHEWD/risultati/" '<<<<
Set IE = CreateObject("InternetExplorer.Application")
'
With IE
.navigate myurl
.Visible = False
Do While .busy: DoEvents: Loop 'Attesa not busy
Do While .readystate <> 4: DoEvents: Loop 'Attesa documento
End With
'
myStart = Timer 'attesa addizionale
Do
DoEvents
If Timer > myStart + 2 Or Timer < myStart Then Exit Do
Loop
Sheets("Foglio4").Range("A:I").ClearContents
Set myColl = IE.document.getElementById("fs-results")
With myColl.getElementsByTagName("Table")(0)
Set myRColl = .getElementsByTagName("TR")
For Each myItm In myRColl
mysplit = Split(myItm.ID, "_", , vbTextCompare)
If UBound(mysplit) > 0 Then
jk = jk + 1: If jk > 15 Then Exit For
mytar = "https://www.diretta.it/partita/" & mysplit(UBound(mysplit)) & "/#informazioni-partita"
' zZz = GetTabRaim222(mytar, 4, Sheets("Foglio4").Cells(Rows.Count, 1).End(xlUp).Offset(5, 0))
zZz = GetTabRaim222Denis7(mytar, "parts-first horizontal", Sheets("Foglio4").Cells(Rows.Count, 1).End(xlUp).Offset(5, 0))
If zZz < 1 Then
Debug.Print "NOK: ", zZz, mytar
Debug.Print 2, myurl
Debug.Print 3, Sheets("Foglio4").Cells(Rows.Count, 1).End(xlUp).Offset(5, 0).Row
Else
Debug.Print "OK", zZz, mytar
Debug.Print 11, Sheets("Foglio4").Cells(Rows.Count, 1).End(xlUp).Offset(5, 0).Row
End If
End If
Next myItm
End With
IE.Quit
Set IE = Nothing
MsgBox ("Completato...")
End Subdi Anthony47 » 15/02/18 02:18
mynext = Evaluate("max(row(1:500)*(A1:I500<>""""))") + 5
myR1 = False
reR1:
zZz = GetTabRaim222Denis7(mytar, "parts-first horizontal", Sheets("Foglio4").Cells(mynext, 1))
If zZz < 1 Then
Debug.Print "NOK: ", zZz, mytar
Debug.Print 2, myurl
Debug.Print 3, mynext + 5, myR1
Else
Debug.Print "OK", zZz, mytar
Debug.Print 11, mynext + 5, myR1
End If
If (Evaluate("max(row(1:500)*(A1:I500<>""""))") + 0) < (mynext + 1) And _
myR1 = False Then
myR1 = True
GoTo reR1
Else
If myR1 = True Then Debug.Print "Post reR1", zZz, mytar, mynext, Evaluate("max(row(1:500)*(A1:I500<>""""))")
End If
myreS = ieWaitPage(IE, 3, 60) 'sessione, Stab Time, TimeOut timedi Denis7 » 15/02/18 16:59
di Anthony47 » 15/02/18 23:59
di Denis7 » 16/02/18 16:53
Anthony47 ha scritto:Comunque visto che le modifiche sono peggiorative, allora eliminale; anzi elimina la prima (quella che ha introdotto [i]mynext = Evaluate("max(row(etc etc/i] e lascia solo la seconda, quella che porta a 3 (secondi) il parametro "Stab Time" nel richiamo della funzione ieWaitPage.
Ciao
di Anthony47 » 17/02/18 01:21
Mi attribuisci capacita' divinatorie che non posseggo...Ogni tanto però mi esce l'errore "run-time 91" , da cosa può essere causato?
di Denis7 » 17/02/18 17:32
Anthony47 ha scritto:Mi attribuisci capacita' divinatorie che non posseggo...Ogni tanto però mi esce l'errore "run-time 91" , da cosa può essere causato?
Non ti chiedo di specificare "quale riga" da' quell'errore perche' la casistica e' abbastanza varia e solo al momento in cui riesco a creare la situazione (di errore, in questo caso) potrei sperare di identificarne il perche' e il come aggirarlo.
Ciao
di assodicuori82 » 28/07/18 14:34
di Anthony47 » 29/07/18 12:16
image url hostdi maxrub » 09/11/19 20:30
di Anthony47 » 10/11/19 14:52
'RIGOROSAMENTE IN TESTA AL MODULO:
#If VBA7 Then
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
#Else
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
Sub BEToLVoLS()
Dim IE As Object, COLL1 As Object, COLL2 As Object, COLL3 As Object
Dim I As Long, J As Long, RR As Long, DSh As Worksheet
'
Set DSh = Sheets("WebData") '<<< Il foglio su cui importare i dati
'
myurl = "https://www.bet365.it" 'L'url della pagina da accedere
If IE Is Nothing Then Set IE = CreateObject("InternetExplorer.Application")
myStart = Timer
With IE
.Visible = True '... rendi visibile IE
.Navigate myurl '...vai all'url
Sleep 100
Do While .Busy: DoEvents: Sleep (20): Loop 'Attesa not busy
Do While .ReadyState <> 4: DoEvents: Sleep (20): Loop 'Attesa documento
End With
Sleep 500
Set COLL1 = IE.document.getElementsByClassName("ipc-InPlayClassificationIcon ipc-InPlayClassificationIcon-13")
Sleep 200
'Cerca Tennis:
COLL1(0).Click
Sleep 1000
'
Set COLL1 = IE.document.getElementsByClassName("li-InPlayLeague ")
For I = 0 To COLL1.Length - 1
RR = RR + 2
DSh.Cells(RR, 1) = COLL1(I).getElementsByClassName("li-InPlayLeague_Header li-InPlayLeague_Header-expanded ")(0).innerText
RR = RR + 1
DSh.Cells(RR, 1) = COLL1(I).getElementsByClassName("li-InPlayEventHeader_Label ")(0).innerText
Set COLL2 = COLL1(I).getElementsByClassName("li-InPlayEventHeader_Score ")
For J = 0 To COLL2.Length - 1
DSh.Cells(RR, 2 + J) = "'" & COLL2(J).innerText
Next J
RR = RR + 1
Set COLL2 = COLL1(I).getElementsByClassName("gll-Participant_Name")
Set COLL3 = COLL1(I).getElementsByClassName("gll-Participant_Odds")
For J = 0 To COLL2.Length - 1
DSh.Cells(RR, 1 + J) = COLL2(J).innerText & " --- " & COLL3(J).innerText
Next J
Next I
MsgBox ("Completato...")
IE.Quit
Set IE = Nothing
End Sub
di maxrub » 10/11/19 19:27
di maxrub » 10/11/19 19:36
di Anthony47 » 11/11/19 00:28
di maxrub » 11/11/19 22:51
di maxrub » 11/11/19 22:59
di Anthony47 » 13/11/19 02:07
'RIGOROSAMENTE IN TESTA AL MODULO:
#If VBA7 Then
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
#Else
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
Sub BEToLVoLS2()
Dim IE As Object, COLL1 As Object, COLL2 As Object, COLL3 As Object, CollA As Object
Dim I As Long, J As Long, RR As Long, DSh As Worksheet
Dim ZNext As Long, HArr, JJ As Long, ScArr(1 To 2, 1 To 1)
Dim Teamers As String, MScorer As String, PtScore As String
'
Set DSh = Sheets("WebData") '<<< Il foglio su cui importare i dati
'
DSh.Range("A:H").ClearContents
myurl = "https://www.bet365.it" 'L'url della pagina da accedere
If IE Is Nothing Then Set IE = CreateObject("InternetExplorer.Application")
myStart = Timer
With IE
.Visible = True '... rendi visibile IE
.Navigate myurl '...vai all'url
Sleep 100
Do While .busy: DoEvents: Sleep (20): Loop 'Attesa not busy
Do While .readyState <> 4: DoEvents: Sleep (20): Loop 'Attesa documento
End With
Debug.Print 1, IE.busy, IE.readyState
Sleep 1000
On Error Resume Next
'Go live:
IE.document.getElementsByTagName("nav")(0).getElementsByTagName("a")(1).Click
Sleep 1000
'Go Generale
IE.document.getElementsByClassName("ip-ControlBar_ButtonBar ")(0).getElementsByTagName("div")(0).Click
Sleep 1000
'Go Tennis:
Set COLL1 = IE.document.getElementsByClassName("ipc-InPlayClassificationIcon ipc-InPlayClassificationIcon-13")
Debug.Print "Len=" & COLL1.Length
Sleep 200
COLL1(0).Click
Sleep 1000
'Go Prospetto principale:
nclassn = "ipo-InPlayClassificationMarketSelectorDropdownLabelContainer "
IE.document.getElementsByClassName(nclassn)(0).getElementsByTagName("div")(0).Click
'Go Tutti gli eventi:
nclassn = "ipo-ClassificationHeader_EventButtonInnerWrapper "
IE.document.getElementsByClassName(nclassn)(0).getElementsByTagName("div")(0).Click
On Error GoTo 0
'ipo-Competition ipo-Competition-open
Set CollA = IE.document.getElementsByClassName("ipo-Competition ipo-Competition-open ")
HArr = Array("ipo-CompetitionButton_NameLabel ipo-CompetitionButton_NameLabelHasMarketHeading ", _
"ipo-CompetitionButton_MarketHeadingLabel ", "ipo-CompetitionButton_MarketHeadingLabel ", _
"ipo-CompetitionButton_MarketHeadingLabel ")
iharr = Array(0, 0, 1, 2)
Teamers = "ipo-TeamStack_Team"
MScorer = "ipo-SetScore_SetWrapper " '1-5!!
PtScore = "ipo-TeamPoints_TeamScoresWrapper "
'Dim HArr, JJ As Long
For I = 0 To CollA.Length - 1
ZNext = GetLast(Range("A:H")) + 2
If I >= CollA.Length Then Exit For
'Legge headers:
JJ = 0
For J = 0 To UBound(HArr)
JJ = JJ + 1
Cells(ZNext, JJ).Value = CollA(I).getElementsByClassName(HArr(J))(iharr(J)).innerText
If J = 0 Then JJ = JJ + 1
Next J
'Legge players:
Set COLL1 = CollA(I).getElementsByClassName("ipo-Fixture_TableRow ") 'Match
For k = 0 To COLL1.Length - 1
ScArr(1, 1) = "'"
ScArr(2, 1) = "'"
ZNext = GetLast(Range("A:H")) + 1
Set COLL2 = COLL1(k).getElementsByClassName(Teamers)
For J = 0 To COLL2.Length - 1
Cells(ZNext + J, 1) = COLL2(J).innerText
Next J
'Legge Risultati
Set COLL2 = COLL1(k).getElementsByClassName(MScorer)
For J = 0 To COLL2.Length - 1
Set COLL3 = COLL2(J).getElementsByTagName("div")
ScArr(1, 1) = ScArr(1, 1) & COLL3(0).innerText
ScArr(2, 1) = ScArr(2, 1) & COLL3(1).innerText
ScArr(1, 1) = ScArr(1, 1) & String(3 + J * 5 - Len(ScArr(1, 1)), " ") & "- "
ScArr(2, 1) = ScArr(2, 1) & String(3 + J * 5 - Len(ScArr(2, 1)), " ") & "- "
Next J
'Legge Punti:
Set COLL2 = COLL1(k).getElementsByClassName(PtScore)
Set COLL3 = COLL2(0).getElementsByTagName("div")
ScArr(1, 1) = ScArr(1, 1) & COLL3(0).innerText
ScArr(2, 1) = ScArr(2, 1) & COLL3(0).innerText
'Scrive punteggio:
Cells(ZNext, 2) = ScArr(1, 1)
Cells(ZNext + 1, 2) = ScArr(2, 1)
'
quote = "ipo-MainMarketRenderer "
quota = "gll-ParticipantCentered_Odds" '1+blank+1
'Scrive Quota Winner:
Set COLL2 = COLL1(k).getElementsByClassName(quote)
For J = 0 To COLL2.Length - 1
On Error Resume Next
Set COLL3 = COLL2(J).getElementsByClassName(quota)
Cells(ZNext, 3 + J) = COLL3(0).innerText
Cells(ZNext + 2, 3 + J) = COLL3(1).innerText
On Error GoTo 0
Next J
Next k
Next I
'Stop
MsgBox ("Completato...")
IE.Quit
Set IE = Nothing
End Sub
Function GetLast(ByRef myRan As Range) As Long
Dim LastR As Long
On Error Resume Next
LastR = myRan.Find(What:="*", After:=myRan.Cells(1, 1), _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
On Error GoTo 0
If LastR = 0 Then GetLast = 1 Else GetLast = LastR
End Function
di maxrub » 13/11/19 22:08
Torna a Applicazioni Office Windows
| Accesso sito negato - errore ERR_CONNECTION_REFUSED Autore: dipdip |
Forum: Software Windows Risposte: 10 |
Visitano il forum: Nessuno e 8 ospiti