Arquivo da tag: URL

VBA – Verificando se o site está online

Mais uma que veio do fórum, que como já disse inúmeras vezes, é um espaço pelo qual sou apaixonado.

A pergunta era simples. Como verificar se um site está online. Ao procurar uma alternativa simples, cheguei no seguinte post do site MrExcel (excelente referência em Excel VBA):

http://www.mrexcel.com/forum/excel-questions/707305-excel-visual-basic-applications-check-if-certain-website-online.html

Que nos deu a seguinte função:

Function getHtmlFromUrl(pURL As String) As String
     Dim resText As String
     Dim objHttp As Object
     Set objHttp = CreateObject("MSXML2.ServerXMLHTTP")
     objHttp.Open "GET", pURL, False
     objHttp.Send ""
     getHtmlFromUrl = Mid(objHttp.ResponseText, 1, 255) 
End Function

Essa função utiliza a biblioteca MSXML2.ServerXMLHTTP para fazer uma requisição para uma URL válida e retorna o texto de resposta. Útil, porém, para somente checar se o site está online, não é necessário ler todo o HTML. Basta checar seu status, ou o HTTP Code da resposta. Se for 200, está tudo ok!

Por fim, transformei o código acima no seguinte:

Sub EstaOnline()
 Debug.Print IsSiteOnline("http://www.tomasvasquez.com.br")
End Sub
 
Function IsSiteOnline(pURL As String) As Boolean
On Error GoTo TrataErro
 Dim resText As String
 Dim objHttp As Object
 Set objHttp = CreateObject("MSXML2.ServerXMLHTTP")
 objHttp.Open "GET", pURL, False
 objHttp.Send ""
 IsSiteOnline = objHttp.Status = 200
 
TrataSaida:
 Exit Function
TrataErro:
 IsSiteOnline = False
 GoTo TrataSaida
End Function

Como apoio, criei a SubOnline como exemplo de chamada para a IsSiteOnline, que faz a verificação e retorna True se estiver, False, do contrário.

Para saber mais sobre o ServerXMLHTTP:

http://msdn.microsoft.com/en-us/library/ms766431(v=vs.85).aspx

Arquivo do exemplo:

http://www.tomasvasquez.com.br/forum/download/file.php?id=2246

Bom proveito!

VBA – Fazendo o download de um arquivo

A pergunta veio do fórum, mas decidi colocar aqui para compartilhar com todos, até porque, esse código estava perdido em algum canto do meu HD faz muito tempo.
😀

O código abaixo realiza o download de um arquivo de uma URL informada em uma pasta também informada:

Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
    (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, _
    ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
 
Public Sub Download()
    On Error GoTo Err
    Dim Auxiliar As Long
    Dim URL As String, CaminhoLocal As String
    URL = "http://www.tomasvasquez.com.br/downloads/modelocadastro.zip"
    CaminhoLocal = "C:\modelocadastro.zip"
    Auxiliar = URLDownloadToFile(0, URL, CaminhoLocal, 0, 0)
    MsgBox "Download efetuado com sucesso!"
    Exit Sub
Err:
    MsgBox "Erro no download do arquivo"
End Sub

No caso, estou usando como exemplo o link do Modelo de Cadastro deste site. Basta colar o código em um novo módulo e executar, para em seguida ver que o Modelo de Cadastro é salvo no caminho “C:\modelocadastro.zip”.

Obviamente, a macro é adaptável a outras necessidades, URLs e tipos de arquivos.

Bom proveito!

VBA – Carregando o controle Imagem através de uma URL

Mais uma do fórum.

Em alguns sistemas, é comum precisar carregar uma imagem do disco local para mostrá-la num formulário VBA. A tarefa é simples e comum de ser fazer aos programadores VBA:

Imagem.Picture = LoadPicture("CaminhoLocal")

Simples. Porém, o método LoadPicture não dá suporte a carregar imagens da internet. Ao tentar colocar no parâmetro filename o um endereço de internet, o código gera um erro.  Nas andanças da Internet, chegamos a um código que, sendo  uma adaptação do LoadPicture, faz o dito trabalho (mantive os comentários originais para garantir a autoria):

Option Explicit
 
Private Declare Function URLDownloadToFile Lib "urlmon" Alias _
    "URLDownloadToFileA" (ByVal pCaller As Long, _
    ByVal szURL As String, ByVal szFileName As String, _
    ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
 
Private Declare Function DeleteUrlCacheEntry Lib "Wininet.dll" _
    Alias "DeleteUrlCacheEntryA" ( _
    ByVal lpszUrlName As String) As Long
 
Private Declare Function GetTempFileName Lib "kernel32" Alias _
    "GetTempFileNameA" (ByVal lpszPath As String, _
    ByVal lpPrefixString As String, ByVal wUnique As Long, _
    ByVal lpTempFileName As String) As Long
 
Private Declare Function SetFileAttributes Lib "kernel32" Alias _
    "SetFileAttributesA" (ByVal lpFileName As String, _
    ByVal dwFileAttributes As Long) As Long
 
 
Private Const ERROR_SUCCESS As Long = 0
Private Const BINDF_GETNEWESTVERSION As Long = &H10
Private Const INTERNET_FLAG_RELOAD As Long = &H80000000
Private Const FILE_ATTRIBUTE_TEMPORARY = &H100
 
 
Private Function DownloadFile(sSourceUrl As String, _
                              sLocalFile As String) As Boolean
 
  'Download the file. BINDF_GETNEWESTVERSION forces
  'the API to download from the specified source.
  'Passing 0& as dwReserved causes the locally-cached
  'copy to be downloaded, if available. If the API
  'returns ERROR_SUCCESS (0), DownloadFile returns True.
   DownloadFile = URLDownloadToFile(0&, _
                                    sSourceUrl, _
                                    sLocalFile, _
                                    BINDF_GETNEWESTVERSION, _
                                    0&) = ERROR_SUCCESS
 
End Function
 
Function LoadPictureUrl(sSourceUrl As String) As IPictureDisp
   Dim sLocalFile As String
 
   On Error GoTo err_h
 
   'Create a buffer
   sLocalFile = String(260, 0)
   'Get a temporary filename
   GetTempFileName "C:\", "KPD", 0, sLocalFile
   'Remove all the unnecessary chr$(0)'s
   sLocalFile = Left$(sLocalFile, InStr(1, sLocalFile, Chr$(0)) - 1)
   'Set the file attributes
   SetFileAttributes sLocalFile, FILE_ATTRIBUTE_TEMPORARY
 
  'Attempt to delete any cached version of the file.
   DeleteUrlCacheEntry sSourceUrl
 
   If DownloadFile(sSourceUrl, sLocalFile) = True Then
 
      'hfile = FreeFile
      'Open sLocalFile For Input As #hfile
      'Text1.Text = Input$(LOF(hfile), hfile)
      'Close #hfile
      Set LoadPictureUrl = LoadPicture(sLocalFile)
      Kill sLocalFile
   Else
      'Create a bogus error
      Err.Raise 999
   End If
 
   Exit Function
err_h:
   Set LoadPictureUrl = LoadPicture("")
End Function

Um exemplo de código bem simples que faz o trabalho seria:

Private Sub UserForm_Initialize()
    Me.Image1.Picture = LoadPictureUrl("http://www.tomasvasquez.com.br/images/Logo_Tomas.gif")
End Sub

Um viva a comunidade de VBA!

Referências

http://www.mrexcel.com/forum/showthread.php?t=116387