RodrigoMalagodi 30/12/2015, 13:00
Bom dia Assis, posso sim cara!
Dei uma adaptada à minha necessidade.Veja no exemplo que coloquei o formulário para atualizar os valores ao carregar, mas também tem a opção de atualizar clicando no botão.
Não consegui enviar o arquivo em anexo, mas segue link do 4shared.com. para download.
Link direto - dólar_web2
Veja aí o código e também o anexo!
========================================Option Compare Database
Private Sub btCapturar2_Click()
fncCapturaDataHora2
'PTAX_COMPRA = ""
'PTAX_VENDA = ""
End Sub
Function fncCapturaDataHora2() As Date
Dim objIE As Object
Dim intPos As Integer
Dim PaginaHtml As String
Dim ptax_venda_web As String
'Dim ptax_compra_web As String
On Error GoTo trataErro
'----------------------------------------------------------
'Verifica se o site está ativo
'caso não esteja ativo, função assume valor falso de data
'----------------------------------------------------------
If Not fncSiteAtivo("www.dolarhoje.com.br") Then
fncCapturaDataHora2 = "0,00"
Exit Function
End If
'-----------------------------------------------
'Abre o Internet Explorer
'-----------------------------------------------
Set objIE = CreateObject("InternetExplorer.Application")
'--------------------------------------
'Esconde o navegador Internet Explorer
'--------------------------------------
objIE.Visible = False
'--------------------------------------------------
'Carrega a página do Observatório Nacional
'---------------------------------------------------
objIE.Navigate "https://ptax.bcb.gov.br/ptax_internet/consultarUltimaCotacaoDolar.do"
'------------------------------------------------
'Aguarda até o completo carregamento da página
'------------------------------------------------
Do While objIE.Busy: DoEvents: Loop
Do While objIE.ReadyState <> 4: DoEvents: Loop
'------------------------------------------------------
'Passa todo o código HTML para a variável PaginaHtml
'------------------------------------------------------
PaginaHtml = objIE.Document.All(0).InnerHTML
'--------------------------------------------------------------------
'Encontra a posição da frase "Hora Oficial de Brasilia" no texto HTML
'---------------------------------------------------------------------
intPos = InStr(PaginaHtml, "CENTER") + 66
'-------------------------------------------
'passa para a função o valor da data e hora
'-------------------------------------------
'popula valor dolar compra
PTAX_COMPRA = "R$ " & Replace(Replace(Mid(PaginaHtml, intPos, 7), "", ""), "<", "")
'ptax_compra_web = Mid(ptax_compra_web, 52, 6)
'PTAX_COMPRA = ptax_compra_web
'tratamento capturar dolar venda
ptax_venda_web = Replace(Replace(Mid(PaginaHtml, intPos, 60), "", ""), "<", "")
ptax_venda_web = Mid(ptax_venda_web, 52, 6)
'popupa valor dolar venda
PTAX_VENDA = "R$ " & ptax_venda_web
sair:
'-----------------------------
'Encerra o Internet Explorer
'-----------------------------
objIE.Quit
Set objIE = Nothing
Exit Function
trataErro:
fncCapturaDataHora2 = #1/1/1800#
Resume sair
End Function
Private Function fncSiteAtivo(ByVal NomeSite As String) As Boolean
Dim colPingResults As Object
Dim oPingResult As Variant
Dim strQuery As String
strQuery = "SELECT * FROM Win32_PingStatus WHERE Address = '" & NomeSite & "'"
Set colPingResults = GetObject("winmgmts://./root/cimv2").ExecQuery(strQuery)
For Each oPingResult In colPingResults
If Not IsObject(oPingResult) Then
fncSiteAtivo = False
ElseIf oPingResult.StatusCode = 0 Then
fncSiteAtivo = True
Else
fncSiteAtivo = False
End If
Next
Set colPingResults = Nothing
End Function
Private Sub Form_Load()
fncCapturaDataHora2
End Sub
=================
Espero que ajude a quem precisar.
Feliz Ano Novo a todos e que Deus os abençoe.