[RESOLVIDO]Copiar dados da internet com Vba

[absilva]

Boa tarde.
Sou novo no fórum e em Vba. Vi que o fórum é bastante rico em informações e participação de seus membros.
Pois bem...
Estou tentando construir um código que acesse uma página da web, com Caption, e copie os dados para uma planilha do excel.
O problema é que quando submeto a consulta, abre outra janela do navegador e eu não sei como interagir com esta nova janela para copiar os dados que necessito.

Segue código abaixo...

Private Sub CommandButton_CONSULTAR_Click()

'Determinando variáveis
Dim objIE As InternetExplorer
Dim elem
Dim tbl
Dim tr

'Abre navegador Internet Explorer
Set objIE = CreateObject("InternetExplorer.Application")

With objIE

.StatusBar = False
.Toolbar = False
.Width = 1000
.Height = 600
.Resizable = False
.AddressBar = False
.Visible = True
.Top = 200
.Left = 150

'Navega site e aguarda carregar completamente
.Navigate "http://smap14.mda.gov.br/extratopf/PesquisaTitular.aspx"
Do While .Busy Or _
.ReadyState <> 4
DoEvents
Loop

'Preenche cpf automaticamente
.Document.all.Item("ctl00_ctl00_CONTENTEXTRATO_ContentPlaceHolder1_txtCPF").innertext = 'TextBox_CPF

'Coloca foco na caixa caption
reset:
.Document.getElementById("ctl00_ctl00_CONTENTEXTRATO_ContentPlaceHolder1_txtUserCode").Focus

x = .Document.activeElement.Name

Do While x = "ctl00_ctl00_CONTENTEXTRATO_ContentPlaceHolder1_txtUserCode"
x = .Document.activeElement.Name
DoEvents
Loop

'Aguarda submissão do código
If .Document.all.Item("ctl00_ctl00_CONTENTEXTRATO_ContentPlaceHolder1_txtUserCode").Value = "" Then GoTo reset

'Submete código
.Document.all("ctl00$ctl00$CONTENTEXTRATO$ContentPlaceHolder1$btnPesquisar").submit

Do While .Busy Or _
.ReadyState <> 4
DoEvents
Loop

'Após submeter, o navegador abre uma nova página e não consigo interagir com ela. Pode ser a cópia total da página que depois faço o tratamento necessário.

End With

End Sub

[Mikel Silveira Fraga]

Absilva, boa tarde e seja bem vindo ao fórum.

Dei uma olhada em seu código e vi que realmente, ao selecionar o link Ver, é aberta uma nova janela com os dados.

Primeiro, vamos precisar realizar uma correção em algumas das últimas linhas do código, no momento de realizar a pesquisa. Altere as linhas abaixo:

Código: Selecionar todos

'Aguarda submissão do código
If .Document.all.Item("ctl00_ctl00_CONTENTEXTRATO_ContentPlaceHolder1_txtUserCode").Value = "" Then GoTo reset

'Submete código
.Document.all("ctl00$ctl00$CONTENTEXTRATO$ContentPlaceHolder1$btnPesquisar").submit

Por:

Código: Selecionar todos

'Aguarda submissão do código
If VBA.Len(.Document.all.Item("ctl00_ctl00_CONTENTEXTRATO_ContentPlaceHolder1_txtUserCode").Value) <> 5 Then GoTo reset

'Submete código
.Document.all("ctl00$ctl00$CONTENTEXTRATO$ContentPlaceHolder1$btnPesquisar").Click

Existe uma forma de interagir com essa nova janela, mas seria algo um pouco mais complicado e sem muita necessidade. Então, minha proposta abaixo, é exatamente pegar o link e realizar a navegação na própria janela que já esta instanciada pelo Objeto IE.
Para isso, adicione o código abaixo, acima do comando End With:

Código: Selecionar todos

Set objElementCol = .Document.getElementsByTagName("a")
For Each objLink In objElementCol
    If VBA.UCase(objLink.innerText) = VBA.UCase("Ver") Then
        .Navigate objLink.href
        Exit For
    End If
Next objLink

Faça as alterações e veja se vai funcionar do jeito que precisa.

Abraços.

[absilva]

Nossa Professor, EXCELENTE!!!
Ficou perfeito o redirecionamento para o novo link. Mas ainda preciso de sua ajuda:
Quando abre o novo link, preciso copiar os dados e colar em uma planilha do excel para depois trata-los.
Logo após o comando objIE.Quit, estou tentando usar o .ExecWB 17, 0 para selecionar toda área. Após, pretendo usar o .ExecWB 12, 2 para copiar. Mas acho que o .ExecWB está buscando o objIE que fechamos, pois aparece "O Objeto chamado foi desconectado de seus clientes".

Pergunto: Como selecionar e copiar estes dados no total ou copiar um dados específico, como a validade?

Desde já, muito obrigado.

[Mikel Silveira Fraga]

Absilva, boa tarde.

Que bom que funcionou do jeito que estava precisando.

Dando continuidade e pegando o sua sugestão, pode utilizar o código abaixo para capturar a data de validade da consulta. Lembrando que o código abaixo ainda deve ser inserido antes da linha de comando End With.

Código: Selecionar todos

Do While .Busy Or _
.ReadyState <> 4
DoEvents
Loop

'Extrair a validade
Set objElementCol = .Document.getelementsbytagname("span")
For Each objText In objElementCol
    If objText.Document.getelementsbytagname("strong").Length > 0 Then
        If VBA.UCase(objText.innerText) Like VBA.UCase("Validade: *") Then
            MsgBox VBA.Replace(objText.innerText, "Validade: ", "")
            Exit For
        End If
    End If
Next objText

Nesse exemplo, estou apenas exibindo a data em uma Caixa de Text (MsgBox). Mas você irá definir o local onde vai querer armazenar essa informação.

Qualquer dúvidas, fico no aguardo.

[absilva]

Caro Professor, obrigado.

Mas creio que não fui muito claro. Perdão!
Na verdade não necessito que retorne a data da consulta, e sim a data de validade da DAP que consta no extrato.
Conforme suas orientações, fiz algumas adaptações e consegui colar os dados na planilha. Mas não sei se foi da forma mais correta. Segue o código revisado:
Sub Buscar_Dados()

Dim objIE As InternetExplorer

Dim elem
Dim tbl
Dim tr

Set objIE = CreateObject("InternetExplorer.Application") 'UserForm2.WebBrowser1

With objIE

.StatusBar = True
.Toolbar = True
.Width = 1000
.Height = 600
.Resizable = True
.AddressBar = True
.Visible = False
.Top = 150
.Left = 170

.Navigate "http://smap14.mda.gov.br/extratopf/PesquisaTitular.aspx"
Do While .Busy Or _
.ReadyState <> 4
DoEvents
Loop


.Document.all.Item("ctl00_ctl00_CONTENTEXTRATO_ContentPlaceHolder1_txtCPF").innerText = "641.816.341-91" 'UserForm1("TextBox_CPF")


reset:
.Document.getElementById("ctl00_ctl00_CONTENTEXTRATO_ContentPlaceHolder1_txtUserCode").Focus

x = .Document.activeElement.Name

Do While x = "ctl00_ctl00_CONTENTEXTRATO_ContentPlaceHolder1_txtUserCode"
x = .Document.activeElement.Name
DoEvents
Loop
.Visible = True
Unload UserForm1
'Aguarda submissão do código
If VBA.Len(.Document.all.Item("ctl00_ctl00_CONTENTEXTRATO_ContentPlaceHolder1_txtUserCode").Value) <> 5 Then GoTo reset

.Visible = False

'Submete código
.Document.all("ctl00$ctl00$CONTENTEXTRATO$ContentPlaceHolder1$btnPesquisar").Click


Do While .Busy Or _
.ReadyState <> 4
DoEvents
Loop

Set objElementCol = .Document.getelementsbytagname("a")
For Each objLink In objElementCol
If VBA.UCase(objLink.innerText) = VBA.UCase("Ver") Then
.Navigate objLink.href
Exit For
End If
Next objLink
Do While .Busy Or _
.ReadyState <> 4
DoEvents
Loop


'Seleciona todos os dados e copia
.ExecWB 17, 0
.ExecWB 12, 2


'Ativa a Planilha, fecha o objIE e cola os dados
Windows("Consulta Extrato DAP.xlsm").Activate
Sheets("Plan2").Select
Range("A1").Select


objIE.Quit
Call Colar
Set objIE = Nothing

End With
End Sub

Aproveitando... Ficou muito bom o código Captcha aguardar 5 elementos para redirecionar. Mas quando digito o código errado, ainda assim ele conclui o procedimento e copia a página de consulta, quando deveria aguardar o código correto.

Ah... Perdão por não colocar o código dentro da caixa como o senhor faz, mas é que não sei como fazer.

Mais uma vez, obrigado!

[Mikel Silveira Fraga]

Absilva, bom dia.

Cara, você chegou a desenvolver a rotina chamada "Colar"? Você não me enviou esta parte do código.

Sobre o uso da Método ExecWB do Internet Explorer, nunca utilizei e nem sei ao certo como o mesmo funciona.

Em minha última mensagem, quando montei a rotina que capturava a Data de Validade, meu intuito foi de montar um modelo (para ser adaptado) que atendesse a necessidade de extração dos dados, enviando a informação capturada diretamente para o local onde desejado. Acredito que seja o mais trabalhoso, mas com melhores resultados.

Tente adaptar o comando, seguindo a mesma lógica de raciocínio para os demais dados.

Ficamos no aguardo.

[absilva]

Boa tarde professor

Segue abaixo a rotina que estou usando para colar.

Sub Colar()
'
' Colar Macro

Sheets("Plan2").Select
Range("A1").Select
ActiveSheet.PasteSpecial Format:="Texto", Link:=False, DisplayAsIcon:=False

Range("A1").Select
Sheets("Plan1").Select
Range("A6").Select

End Sub

Sobre o captcha, não consegui fazer parar a rotina quando o código é digitado errado:
If VBA.Len(.Document.all.Item("ctl00_ctl00_CONTENTEXTRATO_ContentPlaceHolder1_txtUserCode").Value) <> 5 Then GoTo reset

Obrigado.

[Mikel Silveira Fraga]

Absilva, boa tarde.

Em relação ao erro do Captcha incorreto, reformulei a lógica para corrigir isso.

Aproveitei e dei uma reorganizada em seu código, para facilitar a leitura, conforme abaixo:

Código: Selecionar todos

Sub Buscar_Dados()

    Dim objIE As InternetExplorer
    
    Set objIE = CreateObject("InternetExplorer.Application") 'UserForm2.WebBrowser1
    
    With objIE
    
        .StatusBar = True
        .Toolbar = True
        .Width = 1000
        .Height = 600
        .Resizable = True
        .AddressBar = True
        .Visible = False
        .Top = 150
        .Left = 170
        
        .Navigate "http://smap14.mda.gov.br/extratopf/PesquisaTitular.aspx"
        Do While .Busy Or .ReadyState <> 4: DoEvents: Loop
        
        .Document.all.Item("ctl00_ctl00_CONTENTEXTRATO_ContentPlaceHolder1_txtCPF").innerText = "641.816.341-91" 'UserForm1("TextBox_CPF")
        
sbReset1:
        'Unload UserForm1
        .Visible = True
        .Document.getElementById("ctl00_ctl00_CONTENTEXTRATO_ContentPlaceHolder1_txtUserCode").innerText = ""
        
sbReset2:
        .Document.getElementById("ctl00_ctl00_CONTENTEXTRATO_ContentPlaceHolder1_txtUserCode").Focus
        
        x = .Document.activeElement.Name
        
        Do While x = "ctl00_ctl00_CONTENTEXTRATO_ContentPlaceHolder1_txtUserCode"
            x = .Document.activeElement.Name
            DoEvents
        Loop
        
        'Aguarda submissão do código
        If VBA.Len(.Document.all.Item("ctl00_ctl00_CONTENTEXTRATO_ContentPlaceHolder1_txtUserCode").Value) <> 5 Then GoTo sbReset2
        
        .Visible = False
        
        'Submete código
        .Document.all("ctl00$ctl00$CONTENTEXTRATO$ContentPlaceHolder1$btnPesquisar").Click
        
        Do While .Busy Or .ReadyState <> 4: DoEvents: Loop
        
        Set objElementCol = .Document.getelementsbytagname("a")
        For Each objLink In objElementCol
            If VBA.UCase(objLink.innerText) = VBA.UCase("Ver") Then
                .Navigate objLink.href
                Do While .Busy Or .ReadyState <> 4: DoEvents: Loop
                GoTo sbContinuar
            End If
        Next objLink
        
        GoTo sbReset1
        
sbContinuar:
        'Seleciona todos os dados e copia
        .ExecWB 17, 0
        .ExecWB 12, 2
        
        'Ativa a Planilha, fecha o objIE e cola os dados
        Windows("Consulta Extrato DAP.xlsm").Activate
        Sheets("Plan2").Select
        Range("A1").Select
        
        .Quit
    
    End With
    
    Call Colar
    Set objIE = Nothing
    
End Sub

Sobre a função "Colar", nos testes que fiz funcionou perfeitamente. Talvez o problema fosse o fechamento mesmo do objIE.

Veja se agora vai funcionar do jeito que queria.

[absilva]

Olá Professor.

Funcionou perfeitamente!
A página atualiza e gera novo código até que seja digitado corretamente.
- Mas quando há algum erro de digitação do CPF, aparece a seguinte mensagem: "Extrato não gerado – verificar inconsistência na DAP ou DAP não existe em nosso sistema". Gostaria que não travasse a rotina e redirecionasse para meu userform1 ("TextBox_CPF1").Select, ou poderia ser userform1 ("TextBox_CPF1").SetFocus para que seja digitado um CPF válido.

- Outra coisa:
Como este procedimento depende da qualidade da internet, às vezes dá a impressão de que ele travou, pois pode demorar muito. Estou vendo sobre como colocar uma barra de progresso. Mas o que encontrei diz respeito somente a inserção de dados na planilha ou em uma ListView. Neste caso deveria reportar somente o andamento das rotinas. Alguma sugestão?

Mais uma vez, obrigado pela disposição e paciência!

Segue abaixo todas as minhas rotinas:

Código: Selecionar todos

'Exibe a Userfom para inserção do CPF
Sub Consultar()
UserForm1.Show
End Sub

Ao executar o CPF para consulta, segue para seguinte rotina:

Código: Selecionar todos

Sub Buscar_Dados()
    'Faz a busca pelo CPF digitado
    'Evita a visualização das atualizações de página
    Application.ScreenUpdating = True

    Dim objIE As InternetExplorer
   
   'Cria o IE
    Set objIE = CreateObject("InternetExplorer.Application")
   
   'Define o padrão do IE e o mantém oculto
    With objIE
   
        .StatusBar = False
        .Toolbar = False
        .Width = 1000
        .Height = 600
        .Resizable = False
        .AddressBar = False
        .Visible = False
        .Top = 150
        .Left = 170

       'Navega na página e aguarda seu total carregamento
        .Navigate "http://smap14.mda.gov.br/extratopf/PesquisaTitular.aspx"
        Do While .Busy Or .ReadyState <> 4: DoEvents: Loop
       
       'Insere os números digitados na Userform1
        .Document.all.Item("ctl00_ctl00_CONTENTEXTRATO_ContentPlaceHolder1_txtCPF").innerText = UserForm1("TextBox_CPF1")
       
sbReset1:
	'Exibe o objIE para que seja digitado o código Captcha
        .Visible = True
        'Apaga qualquer elemento que esteja no campo para ser digitado o código. Aguarda 5 dígitos e então submete. Caso o código seja incorreto, apaga o que foi digitado e aguarda 5 dígitos novamente
        .Document.getElementById("ctl00_ctl00_CONTENTEXTRATO_ContentPlaceHolder1_txtUserCode").innerText = ""
       
sbReset2:
	'Coloca o insersor de texto na caixa do código
        .Document.getElementById("ctl00_ctl00_CONTENTEXTRATO_ContentPlaceHolder1_txtUserCode").Focus
       
        x = .Document.activeElement.Name
       
        Do While x = "ctl00_ctl00_CONTENTEXTRATO_ContentPlaceHolder1_txtUserCode"
            x = .Document.activeElement.Name
            DoEvents
        Loop
       
        'Aguarda submissão do código
        If VBA.Len(.Document.all.Item("ctl00_ctl00_CONTENTEXTRATO_ContentPlaceHolder1_txtUserCode").Value) <> 5 Then GoTo sbReset2
       'Oculta objIE
        .Visible = False
       
        'Submete código
        .Document.all("ctl00$ctl00$CONTENTEXTRATO$ContentPlaceHolder1$btnPesquisar").Click
       
        Do While .Busy Or .ReadyState <> 4: DoEvents: Loop
       'Caso o código Captcha esteja correto, aguarda carregar e abre o link do extrato na mesma página
        Set objElementCol = .Document.getelementsbytagname("a")
        For Each objLink In objElementCol
            If VBA.UCase(objLink.innerText) = VBA.UCase("Ver") Then
                .Navigate objLink.href
                Do While .Busy Or .ReadyState <> 4: DoEvents: Loop
                GoTo sbContinuar
            End If
        Next objLink
       
        GoTo sbReset1
       
sbContinuar:
        'Seleciona todos os dados e copia
        .ExecWB 17, 0
        .ExecWB 12, 2
       
        'Ativa a Planilha, fecha o objIE e cola os dados
        Windows("Consulta Extrato DAP - Cópia de Segurança.xlsm").Activate
       
       
        .Quit
        Set objIE = Nothing
    End With
   
    Call Colar
    'Deixa as atualizações visíveis novamente
    Application.ScreenUpdating = True
End Sub

Abaixo a rotina para colar os dados coletados:

Código: Selecionar todos

Sub Colar()
'O código abaixo deveria ser usado caso o excel não ficasse em foco. O que não é o caso
'Windows("Consulta Extrato DAP - Cópia de Segurança.xlsm").Activate
 
Sheets("Plan2").Select
Range("A1").Select
'Cola somente texto   
ActiveSheet.PasteSpecial Format:="Texto", Link:=False, DisplayAsIcon:=False

'Coloca a Planilha BancoDados em foco. É onde os dados, depois de tratados, serão gravados.
Sheets("BancoDados").Select
Range("A6").Select

End Sub

[Mikel Silveira Fraga]

Absilva, boa tarde.

Como tem passado, tudo bem? Espero que sim.

Então, como não tenho o modelo completo para testar o comportamento entre a Janela do Navegador e o Userform do Excel, pensei em encerrar a execução do Navegador ao detectar o Erro do Extrato DAP. Dessa forma, o Userform será exibido em 1º plano na tela.

O código abaixo, deve ser adicionado entre os comandos Next objLink e GoTo sbReset1:

Código: Selecionar todos

        'Valida o resultado da pesquisa.
        Do While .Busy Or .readyState <> 4: DoEvents: Loop 'Aguarda carregamento erro.
        Const strErrorExtrato As String = _
            "Extrato não gerado – verificar inconsistência na DAP ou DAP não existe em nosso sistema"
        
        Set objElementCol = .document.getElementsByTagName("li")
        For Each objError In objElementCol
            If VBA.UCase(objError.innerText) = VBA.UCase(strErrorExtrato) Then
                MsgBox strErrorExtrato, vbCritical, "Erro DAP"
                .Quit
                Exit Sub
            End If
        Next objError

Teste e veja se atende dessa forma.

Sobre a barra de progresso, não sei se vai conseguir fazer o que deseja, não de forma eficiente.

Quando se trabalha com uma ProgressBar, a ideia é ver o evolutivo das etapas de um processo, sendo que cada comando executado, pode ser considerado uma etapa. No caso da lentidão da internet, você esta tendo a demora de um retorno de uma única etapa e não de várias etapas que compõem um processo. Nesse caso, a ideia de exibir a continuidade de um processo, vai ficar parado do mesmo jeito, não exibindo a sua evolução.

Não sei se fui claro sobre isso. Qualquer outra dúvida, estamos a disposição.

Abraços.