Amigos, amigos!
encontrei uma solução, depois que arrancar muitos cabelos!! aahahahaha
Olha, veio da onde não esperava, pois era um forum japonês,
http://club.excelhome.net/thread-473891-1-1.html , nem tradutor dava conta, mas o script falou por si
, depois de pesquisar e pesquisar muitas soluções e nada, Deus mostra que a simplicidade também é solução.
Código: Selecionar todos
With app
'Selects the full website and copies the contents
.Document.execCommand "SelectAll", False
.ExecWB OLECMDID_COPY, OLECMDEXECOPT_DODEFAULT
End With
Eu não sei exatamente que isso faz, mas salvou a lavoura.
Eu estava pesquisando uma saída via API, estudei uma forma de identificar janela ativa do IE e nada, mas não foi tempo perdido, serviu para aprender e compartilhar com vocês, caso necessitem!
Segue o código completo
Ele faz a autenticação, localiza uma tabela, abre a página html e copia os dados da página em uma planilha.
Eu recorri a este caminho, pois ainda não tenho domínio nos comandos para baixar o arquivo xls, digo manipular janela IE "salvar", "salvar como" e "cancelar".
Código: Selecionar todos
Sub BASE_OCUPADAS()
'http://www.excelforum.com/excel-programming-vba-macros/806831-solved-external-web-query-connection-to-login-automatically.html
'http://club.excelhome.net/thread-473891-1-1.html
Dim btnInput As Object ' MSHTML.HTMLInputElement
Dim ElementCol As Object ' MSHTML.IHTMLElementCollection
Dim IE As InternetExplorer
Dim C
Dim ULogin As Boolean, ieForm
Dim MyPass As String, MyLogin As String
Application.DisplayAlerts = False
MyLogin = ""
MyPass = ""
Set IE = New InternetExplorer ' Nova Página
IE.Visible = True
Mysite = "http://urapms.brasiltelecom.com.br/pms/"
IE.Navigate Mysite 'Acessar link
Do Until IE.READYSTATE = READYSTATE_COMPLETE 'Loop ate conectar na página
Loop
IE.Document.all("j_username").innerText = MyLogin
IE.Document.all("j_password").innerText = MyPass
'obtém o forma a qual o controle de login pertence para submetê-lo
IE.Document.forms(0).submit
'IE.Document.all("login_txt").innerText = MyLogin 'Colocar Usuário
'IE.Document.all("senha_txt").innerText = MyPass 'Colocar Senha
'IE.Document.all("submit").Click 'Clicar para acessar
Do Until IE.READYSTATE = READYSTATE_COMPLETE 'Loop ate conectar na página
Loop
Sleep (1000)
Mysite = "http://urapms.brasiltelecom.com.br/pms/relatorio/disponivel/listar-disponiveis.jsp"
IE.Navigate Mysite
Do Until IE.READYSTATE = READYSTATE_COMPLETE 'Loop ate conectar na página
Loop
hoje = Format(Now, "dd/mm/yyyy")
ontem = Format(Now - 1, "dd/mm/yyyy")
IE.Document.all("dtInicio").innerText = ontem
IE.Document.all("dtFim").innerText = hoje
IE.Document.all("nomeArquivo").innerText = "POP"
IE.Document.forms(0).submit
Sleep (5000)
Dim idaux As String
Do While IE.READYSTATE <> 4
Loop
With IE
.Navigate URL
.Visible = True
Do Until .READYSTATE = READYSTATE_COMPLETE: DoEvents: Loop
Set htmlDoc = .Document
End With
'identificar arquivo atual html
With htmlDoc
'Target the set of tables.
Set tblSet = .GetElementById("listagem")
Set mTbl = tblSet.getElementsByTagName("a")(3)
tTbl = VBA.Right(mTbl, 9) 'id tabela html atual
idaux = VBA.Right(mTbl, 6) 'auxiliar
End With
Dim a As String
Set app = CreateObject("InternetExplorer.Application")
With app
.Visible = True
.Navigate "http://urapms.brasiltelecom.com.br/pms/RelatorioDisponivelViewServlet?" & tTbl
Do Until .READYSTATE = 4
DoEvents
Loop
End With
'Application.EnableEvents = False
'Aqui seu código
' Application.EnableEvents = True
'SELECIONAR E COPIAR DADOS DA PAGINA
With app
'Selects the full website and copies the contents
.Document.execCommand "SelectAll", False
.ExecWB OLECMDID_COPY, OLECMDEXECOPT_DODEFAULT
End With
app.Quit
'ABRIR PLANILHA DESTINO
Workbooks.Open filename:="\\km3rede\aplcopel\Relacionamento_Clientes\ISOAcesso\Relatórios\Acompanhamento Diário\Diario\TESTE_WAGNER\base_ocupadas.xlsx" 'Abrindo planilha destino
Worksheets(1).Activate
Worksheets(1).Cells.ClearContents
Range("A1").Select
ActiveSheet.PasteSpecial Format:="HTML", link:=False, DisplayAsIcon:= _
False
ActiveSheet.Cells.WrapText = False
ActiveSheet.Cells.MergeCells = False
Rows("1:2").Select
Range("A2").Activate
Selection.Delete Shift:=xlUp
Cells.Select
Cells.EntireColumn.AutoFit
Rows("1:1").Select
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
ActiveWorkbook.SaveAs filename:="\\km3rede\aplcopel\Relacionamento_Clientes\ISOAcesso\Relatórios\Acompanhamento Diário\Diario\TESTE_WAGNER\base_ocupadas.xls", FileFormat _
:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Workbooks("base_ocupadas.xls").Close
Application.DisplayAlerts = True
IE.Quit
Set IE = Nothing
End Sub
Abs
Wagner