Valutazione 4.87/ 5 (100.00%) 5838 voti

Condividi:        

Sub GetAllTablesLE

Vuoi potenziare i tuoi documenti Word? Non sai come si fa una macro in Excel? Devi creare una presentazione in PowerPoint?
Oppure sei passato a OpenOffice e non sei sicuro di come lavorare al meglio?

Moderatori: Anthony47, Flash30005

Sub GetAllTablesLE

Postdi aggittoriu » 27/04/22 17:57

Ciao.

A proposito della Sub GetAllTablesLE che mi hai dato qui
Codice: Seleziona tutto
Dim WPage As Object

Sub GetAllTablesLE(myUrl As String, Optional rNum0 As Long = 1, Optional cNum0 As Long = 1)
Dim TBColl As Object, StrHtm As String
Dim I As Long, J As Long, myTim As Single
Dim RNum As Long, CNum As Long, HTDoc As Object
Dim iniTab As Long, finiTab As Long
'Dim TArr
Dim TDColl As Object, TRColl As Object, AColl As Object ', PiPPo As Long

If WPage Is Nothing Then
     Set WPage = CreateObject("Selenium.CHRomedriver")
End If
'''On Error Resume Next
reUrl:
WPage.Get myUrl
'
'Carica e ricarica...
'If myUrl <> WPage.URL And PiPPo < 4 Then
 '   PiPPo = PiPPo + 1
 '   Debug.Print "Non pronta", PiPPo, myUrl, WPage.URL
 '   GoTo reUrl
'End If
'Debug.Print "Pagina pronta", PiPPo, myUrl, WPage.URL
'myTim = Timer
'
'Set HTDoc = CreateObject("HTMLfile") 'late binding alla html obj lib
'
'Crea htmlDocument:
HTDoc.Open
lenhtml = Len(WPage.PageSource)
Do
    iniTab = InStr(finiTab + 1, WPage.PageSource, "<table", vbTextCompare)
    finiTab = InStr(iniTab + 1, WPage.PageSource, "</table", vbTextCompare)
    If iniTab = 0 Then Exit Do
    StrHtm = StrHtm & Mid(WPage.PageSource, iniTab, finiTab - iniTab + 10)
Loop
HTDoc.write StrHtm
'
'esamina i tag tabella/riga/dati:
If Not HTDoc Is Nothing Then
    Set TBColl = HTDoc.getElementsByTagName("table")
    RNum = rNum0: CNum = cNum0
    For I = 0 To TBColl.Length - 1
        RNum = RNum + 1
        Cells(RNum, CNum).Value = "## Table " & I
        Debug.Print "## Table " & I, Format(Timer - myTim, "0.0"), RNum
        Set TRColl = TBColl(I).getElementsByTagName("tr")
        RNum = RNum + 1: CNum = cNum0
        For J = 0 To TRColl.Length - 1
            Set TDColl = TRColl(J).getElementsByTagName("td")
            For K = 0 To TDColl.Length - 1
                Cells(RNum, CNum).Value = TDColl(K).innertext
                Set AColl = TDColl(K).getElementsByTagName("a")
                If AColl.Length > 0 Then
                    ActiveSheet.Hyperlinks.Add anchor:=Cells(RNum, CNum), _
                           Address:=AColl(0).href
                End If
                CNum = CNum + 1
            Next K
            RNum = RNum + 1: CNum = cNum0
    '        Debug.Print "## Table " & I, Format(Timer - myTim, "0.0"), RNum
        Next J
        RNum = RNum + 1
        DoEvents
    Next I
End If
Debug.Print "FINE-XA", RNum, Format(Timer - myTim, "0.00"), myUrl
End Sub

, la sto provando per importarmi il palinsesto del tennis dal sito https://www.betexplorer.com/next/tennis/?year=2022&month=04&day=28.

Purtroppo, nel sito BMB non funziona niente, perchè le pagine non si aprono o gli url cambiano. Allora sto provando a passare a betexplorer, anche se non è la stessa cosa.

Però forse c'è qualcosa da cambiare? Perchè a me gli hyperlink non li importa (e io avevo chiesto questo codice, proprio per averli). Qualche scritta si colora di blu. Ma gli hyperlink non ci sono.
Non ho cambiato niente. Ho solo spento il codice di PiPPo, che non credo sia utile in questo caso.
aggittoriu
Utente Senior
 
Post: 101
Iscritto il: 24/06/14 08:49

Sponsor
 

Re: Sub GetAllTablesLE

Postdi Anthony47 » 28/04/22 14:35

Ci sono tanti modi per inserire gli hyperlink, la macro non li potra' prendere tutti in considerazione.
Questa versione e' compatibile con la precedente e anche con il caso che hai indicato:
Codice: Seleziona tutto
Sub GetAllTablesLE(myUrl As String, Optional rNum0 As Long = 1, Optional cNum0 As Long = 1)
'Accetta h.links "relativi alla radice
Dim TBColl As Object, StrHtm As String
Dim I As Long, J As Long, myTim As Single
Dim RNum As Long, CNum As Long, HTDoc As Object
Dim iniTab As Long, finiTab As Long
'Dim TArr
Dim TDColl As Object, TRColl As Object, AColl As Object, PiPPo As Long

If WPage Is Nothing Then
     Set WPage = CreateObject("Selenium.CHRomedriver")
End If

'''On Error Resume Next
reUrl:
WPage.Get myUrl
'
'Carica e ricarica...
If myUrl <> WPage.Url And PiPPo < 4 Then
    PiPPo = PiPPo + 1
    Debug.Print "Non pronta", PiPPo, myUrl, WPage.Url
    GoTo reUrl
End If
Debug.Print "Pagina pronta", PiPPo, myUrl, WPage.Url
myTim = Timer
'
Set HTDoc = CreateObject("HTMLfile") 'late binding alla html obj lib

'Crea htmlDocument:
HTDoc.Open
lenhtml = Len(WPage.PageSource)
Do
    iniTab = InStr(finiTab + 1, WPage.PageSource, "<table", vbTextCompare)
    finiTab = InStr(iniTab + 1, WPage.PageSource, "</table", vbTextCompare)
    If iniTab = 0 Then Exit Do
    StrHtm = StrHtm & Mid(WPage.PageSource, iniTab, finiTab - iniTab + 10)
Loop
HTDoc.write StrHtm

'Crea root per hLinks
Dim qmPos As Long, hlRoot As String, iHL As String
qmPos = InStr(10, myUrl & "/", "/", vbTextCompare)
hlRoot = Left(myUrl, qmPos - 1)
'
'esamina il tag richiesto:
If Not HTDoc Is Nothing Then
    Set TBColl = HTDoc.getElementsByTagName("table")
    RNum = rNum0: CNum = cNum0
    For I = 0 To TBColl.Length - 1
        RNum = RNum + 1
        Cells(RNum, CNum).Value = "## Table " & I
        Debug.Print "## Table " & I, Format(Timer - myTim, "0.0"), RNum
        Set TRColl = TBColl(I).getElementsByTagName("tr")
        RNum = RNum + 1: CNum = cNum0
        For J = 0 To TRColl.Length - 1
            Set TDColl = TRColl(J).getElementsByTagName("td")
            For k = 0 To TDColl.Length - 1
                Cells(RNum, CNum).Value = TDColl(k).innerText
                Set AColl = TDColl(k).getElementsByTagName("a")
                If AColl.Length > 0 Then
                    iHL = Replace(AColl(0).href, "about:", "", , , vbTextCompare)
                    If Left(iHL, 1) = "/" Then
                        iHL = hlRoot & iHL
                    End If
                    ActiveSheet.Hyperlinks.Add anchor:=Cells(RNum, CNum), _
                           Address:=iHL
                End If
                CNum = CNum + 1
            Next k
            RNum = RNum + 1: CNum = cNum0
    '        Debug.Print "## Table " & I, Format(Timer - myTim, "0.0"), RNum
        Next J
        RNum = RNum + 1
        DoEvents
    Next I
End If
Debug.Print "FINE-LE", RNum, Format(Timer - myTim, "0.00"), myUrl
End Sub

Ciao
Avatar utente
Anthony47
Moderatore
 
Post: 18282
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: Sub GetAllTablesLE

Postdi aggittoriu » 28/04/22 16:37

Ok grazie! Mi può andar bene già così. I nomi dei tornei non vengono importati, ma si possono ricavare dai vari hyperlink. Poi è velocissima, quindi comoda. ;)

Però non ho capito perchè mi hai riacceso 'sto PiPPo, che io avevo spento. :D Non serve e per di più, mi apre due volte Crome e alla fine me ne chiude solo uno. :mmmh:
aggittoriu
Utente Senior
 
Post: 101
Iscritto il: 24/06/14 08:49

Re: Sub GetAllTablesLE

Postdi aggittoriu » 28/04/22 19:14

No. Non riesco a toglielo quel codice. Se lo tolgo, non funziona. Se non lo tolgo, mi apre due volte crome e una resta aperta anche a fine esecuzione. Ho aggiunto un
Codice: Seleziona tutto
WPage.Quit

Set WPage = Nothing

alla fine, per chiudere anche la seconda pagina. Ma se evitassi di aprirne due, sarebbe tutto di guadagnato. :mmmh:
aggittoriu
Utente Senior
 
Post: 101
Iscritto il: 24/06/14 08:49

Re: Sub GetAllTablesLE

Postdi Anthony47 » 28/04/22 20:08

Quella parte serve a controllare che siamo arrivati alla pagina di destinazione; a me spesso looppa (per attendere la pagina finale) ma non apre altre sessioni chrome.
Prova ad aggiungere un delay nel ciclo:
Codice: Seleziona tutto
reUrl:
WPage.Get myUrl
'
WPage.Wait 1000                '<<< AGGIUNTO
'Carica e ricarica...
If myUrl <> WPage.Url And PiPPo < 4 Then
'etc

Ciao
Avatar utente
Anthony47
Moderatore
 
Post: 18282
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: Sub GetAllTablesLE

Postdi aggittoriu » 28/04/22 23:47

No. Ho messo 5000, ma non cambia niente. Mi apre due pagine subito. Senza neanche aspettare i 5000, che sarebbero 5 secondi. Giusto?

Ma non è possibile togliere questo controllo? Nell'altra che mi hai dato, l'ho fatto e funziona bene. Tanto il sito che dava problemi era BMB. Ma ora sto provando con BetExplorer, che non cambia l'indirizzo web.
aggittoriu
Utente Senior
 
Post: 101
Iscritto il: 24/06/14 08:49

Re: Sub GetAllTablesLE

Postdi aggittoriu » 29/04/22 08:46

No. Contrordine. Ho rimesso PiPPo anche nell'altra. Però ancora c'è qualcosa che non va.
Ora devo andare. Pubblico un file di esempio stanotte, così si capisce meglio dov'è il problema. :(
aggittoriu
Utente Senior
 
Post: 101
Iscritto il: 24/06/14 08:49

Re: Sub GetAllTablesLE

Postdi Anthony47 » 29/04/22 12:23

Prima assicurati che in testa a un tuo modulo standard vba ci sia la dichiarazione Dim WPage As Object.
Poi devi guardare in che momento le due sessioni vengono create: Esegui "passo passo" la tua Sub ImpQ e controlla in quale momento si visualizza la prima sessione chrome e in che momento la seconda, e cosa contengono.
Per informazioni su come fare, vedi viewtopic.php?f=26&t=103893&p=647677#p647677

Ciao
Avatar utente
Anthony47
Moderatore
 
Post: 18282
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: Sub GetAllTablesLE

Postdi aggittoriu » 30/04/22 07:17

Ieri notte, non ce l'ho fatta. Anche perchè era tardi e non capivo. Nel file originale, continua a darmi gli stessi problemi. In questo di esempio qui il problema delle due pagine aperte è sparito. Boh! Evvidentemente in quello originale mi sarò dimenticato di salvare le modifiche. :oops: Poi vedo.

Comunque. Ora lo scarico del palinsesto funziona bene.

Quello che mi da ancora problemi è lo scarico delle quote.
A volte funziona bene. A volte no (nella colonna I non dovrevve comparire nessun dato). Anche ripetendo la macro subito, quando sembra che sia tutto ok. E non capisco perchè.
Ho cambiato solo un piccolo pezzo di codice, perchè mi pare di capire che la tabella che interessa a me sia solo la 1 e per intitolare le tabelle col nome dei tennisti. Allora cos'è che non va? :-?
aggittoriu
Utente Senior
 
Post: 101
Iscritto il: 24/06/14 08:49

Re: Sub GetAllTablesLE

Postdi Anthony47 » 30/04/22 16:34

Lo scarico delle quote va in crisi perche' spesso le tabelle non sono pronte quando la pagina viene dichiarata pronta...
Ho inserito nella Sub GetImpQ un controllo (tipo PiPPo):
Codice: Seleziona tutto
Sub GetImpQ(myUrl As String, Optional rNum0 As Long = 1, Optional cNum0 As Long = 1)
'GetAllTablesArr per betexplorer.com/tennis
'http://www.pc-facile.com/forum/viewtopic.php?f=26&t=111428&start=20#p660238
' Cambia solo da For I a Next I, per importare solo la tabella 1 e intitolarla col nome del match
'
Dim TBColl As Object
Dim I As Long, J As Long, myTim As Single
Dim RNum As Long, CNum As Long
   
Dim TArr

If WPage Is Nothing Then
     Set WPage = CreateObject("Selenium.CHRomedriver")
End If

On Error Resume Next

WPage.Get myUrl
'
myTim = Timer
'
Do                                                                            'Aspetta max 4 sec la tabella
    Set TBColl = WPage.FindElementsByTag("table")
    If TBColl.Count > 0 Then
        RNum = rNum0: CNum = cNum0
        If InStr(1, TBColl(1).Attribute("class") & "  ", " sort", vbTextCompare) > 0 Then Exit Do
        Debug.Print "WA", Format(Timer - myTim, "0.00"), TBColl.Count
    End If
    DoEvents
    If Timer > (myTim + 4) Then Exit Do
    WPage.Wait 500
Loop
''Debug.Print "ExA", Format(Timer - myTim, "0.00"), TBColl.Count
'
' For I = 1 To TBColl.Count               'Scan delle Tabelle presenti
 '   TArr = TBColl(I).AsTable.Data
  '  RNum = RNum + 1
   ' Cells(RNum, CNum).Value = "## Table " & I
    'If (UBound(TArr) * UBound(TArr, 2)) > 0 Then
     '   Cells(RNum + 1, CNum).Resize(UBound(TArr), UBound(TArr, 2)).Value = TArr
   ' End If
   ' RNum = RNum + UBound(TArr) + 1
   ' DoEvents
' Next I
'etc
'etc


Quanto al problema della doppia sessione Chrome, io penso sia dovuta alla mancata dichiarazione Dim WPage As Object IN TESTA al modulo

Ciao
Avatar utente
Anthony47
Moderatore
 
Post: 18282
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: Sub GetAllTablesLE

Postdi aggittoriu » 01/05/22 00:30

Ok. La controllo domani (che in realtà è già oggi) poi ti faccio sapere.

Quanto al problema della doppia sessione Chrome, io penso sia dovuta alla mancata dichiarazione Dim WPage As Object IN TESTA al modulo

No. Quella dichiarazione c'era. Ma ho messo le due macro in due moduli diversi. Pensavo si potesse fare. :oops:
aggittoriu
Utente Senior
 
Post: 101
Iscritto il: 24/06/14 08:49

Re: Sub GetAllTablesLE

Postdi aggittoriu » 01/05/22 07:49

Ok. Provata. Sembra tutto ok stavolta. ;)

Come sempre, grazie e... alla prossima! :oops: :D
aggittoriu
Utente Senior
 
Post: 101
Iscritto il: 24/06/14 08:49


Torna a Applicazioni Office Windows

Chi c’è in linea

Visitano il forum: Anthony47 e 22 ospiti