Tomás Vásquez Fórum

Código: Selecionar todos

'Inclui referência ao Microsoft Internet Controls
Sub lReferenciaIE()
    Dim ObRef
    On Error Resume Next

    ThisWorkbook.VBProject.References.AddFromGuid "{EAB22AC0-30C1-11CF-A7EB-0000C05BAE0B}", 1, 1
End Sub

Public Function getXPathElement(sXPath As String, objElement As Object) As HTMLBaseElement
Dim sXPathArray() As String

Dim sNodeName As String
Dim sNodeNameIndex As String
Dim sRestOfXPath As String
Dim lNodeIndex As Long
Dim lCount As Long

' Split the xpath statement
sXPathArray = Split(sXPath, "/")
sNodeNameIndex = sXPathArray(1)
If Not InStr(sNodeNameIndex, "[") > 0 Then
sNodeName = sNodeNameIndex
lNodeIndex = 1
Else
sXPathArray = Split(sNodeNameIndex, "[")
sNodeName = sXPathArray(0)
lNodeIndex = CLng(Left(sXPathArray(1), Len(sXPathArray(1)) - 1))
End If
sRestOfXPath = Right(sXPath, Len(sXPath) - (Len(sNodeNameIndex) + 1))

Set getXPathElement = Nothing
For lCount = 0 To objElement.ChildNodes().Length - 1
If UCase(objElement.ChildNodes().Item(lCount).nodeName) = UCase(sNodeName) Then
If lNodeIndex = 1 Then
If sRestOfXPath = "" Then
Set getXPathElement = objElement.ChildNodes().Item(lCount)
Else
Set getXPathElement = getXPathElement(sRestOfXPath, objElement.ChildNodes().Item(lCount))
End If
End If
lNodeIndex = lNodeIndex - 1
End If
Next lCount
End Function

Sub lsPesquisar()
    'Inclui a referência se não houver
    lReferenciaIE
    
    Dim ie                  As InternetExplorer
    Dim lCidade             As String
    Dim lUF                 As String
    Dim lUltimaLinhaAtiva   As Long
    Dim lContador           As Long
        
    'Identifica a última célula ativa da lista
    lUltimaLinhaAtiva = Worksheets("Plan1").Cells(Worksheets("Plan1").Rows.Count, 1).End(xlUp).Row
    
    'Cria um objeto Internet Explorer
    Set ie = New InternetExplorer
        
    'Torna o objeto visível
    ie.Visible = True
    
    'Faz um loop por todas as linhas da planilha
    For lContador = 2 To lUltimaLinhaAtiva
        'Navega ao site
        ie.Navigate "https://sistemas.anatel.gov.br/stel/consultas/ListaEstacoesLocalidade/tela.asp?pNumServico=010"
        
        'Identifica se a página já foi totalmente carregada
        While ie.ReadyState <> READYSTATE_COMPLETE
        Wend
        sng = Timer
        Do While sng + 3 > Timer
        Loop
        
        'Carrega os dados de cidade e UF que serão preenchidos na página
        
        lUF = Range("A" & lContador).Value
        
        'Carrega os dados de cidade e UF na página e submente os dados do formulário
        ie.Document.all("pSiglaUF").Value = lUF 'coloca os dados da uf
        ie.Document.all("botaoFlatConfirmar").Click 'clica em confirmar
            
                
        While ie.ReadyState <> READYSTATE_COMPLETE
        Wend
        sng = Timer
        Do While sng + 3 > Timer
        Loop
           
        
       Set ele = getXPathElement("/html/body/form/div[2]/table[7]/tbody/tr/td[3]/button", HTMLDoc.getElementById("botaoFlat ExportarExcel"))
       If Len(ele) > 0 Then
       ele.Click
    End If
        
    Next lContador
   
    MsgBox "Concluído!"
End Sub

Código: Selecionar todos

'Inclui referência ao Microsoft Internet Controls
Sub lReferenciaIE()
    Dim ObRef
    On Error Resume Next

    ThisWorkbook.VBProject.References.AddFromGuid "{EAB22AC0-30C1-11CF-A7EB-0000C05BAE0B}", 1, 1
End Sub

Sub lsConsultaObjetoPropostaSiconv()
    'Inclui a referência se não houver
    lReferenciaIE
    
    Dim ie                  As InternetExplorer
    Dim lProposta           As String
    Dim lUltimaLinhaAtiva   As Long
    Dim lContador           As Long
    Dim objIE               As Object
    Dim HTMLDoc             As HTMLDocument
    
    'Identifica a última célula ativa da lista
    lUltimaLinhaAtiva = Worksheets("Plan4").Cells(Worksheets("Plan4").Rows.Count, 1).End(xlUp).Row
    
    'Cria um objeto Internet Explorer
    Set ie = New InternetExplorer
        
    'Torna o objeto visível
    ie.Visible = True

    'Faz um loop por todas as linhas da planilha
    For lContador = 2 To lUltimaLinhaAtiva
        'Navega ao site Siconv
        ie.Navigate "https://www.convenios.gov.br/siconv/proposta/ConsultarProposta/ConsultarProposta.do"
                    
        'Identifica se a página já foi totalmente carregada
        While ie.ReadyState <> READYSTATE_COMPLETE
        Wend
        
        'Como a página possui JavaScript que cria os objetos que são preenchidos após a carga completa, é necessário
        'aguardar um tempo, coloquei 3 segundos, alterar conforme a necessidade.
        'Caso não tenha javascript na criação dos objetos da página comentar esta parte do código, pois será bem
        'mais rápida a execução.
        sng = Timer
        Do While sng + 3 > Timer
        Loop
        
        'Carrega os dados da proposta que serão preenchidos na página
        lProposta = Range("A" & lContador).Value
                
        'Carrega os dados da proposta na página e submete os dados do formulário
        ie.Document.all("numeroProposta").innertext = lProposta
        ie.Document.forms("consultarPropostaPreenchaOsDadosDaConsultaConsultarForm").submit
       
        'Identifica se a página já foi totalmente carregada
        While ie.ReadyState <> READYSTATE_COMPLETE
        Wend
         
        'Navega no link até a proposta
        '<a href="/siconv/ConsultarProposta/ResultadoDaConsultaDePropostaDetalharProposta.do?idProposta=1328263&destino=&idConvenio="> - Clicar neste para ir para a proposta
        
                          
        'Como a página possui JavaScript que cria os objetos que são preenchidos após a carga completa, é necessário
        'aguardar um tempo, coloquei 3 segundos, alterar conforme a necessidade.
        'Caso não tenha javascript na criação dos objetos da página comentar esta parte do código, pois será bem
        'mais rápida a execução.
        sng = Timer
        Do While sng + 3 > Timer
        Loop
       
        'Faz um loop pelos objetos do tipo table na página e procura pelo campo Situação.
        'Em seguida busca pela segunda coluna da linha de Situação e armazena esta informação diretamente na coluna B da linha da planilha
        For Each i In ie.Document.body.getElementsByTagName("table")
            If InStr(i.innertext, "Objeto do Convênio") > 0 Then
                For Each l In i.getElementsByTagName("tr")
                    If InStr(l.innertext, lProposta) Then
                        Range("B" & lContador).Value = l.getElementsByTagName("td")(2).innertext 'https://stackoverflow.com/questions/47702605/excel-vba-extracting-inner-text-from-href-tag
                    End If
                Next l
            End If
        Next i
    Next lContador
    
    MsgBox "Concluído!"
End Sub