Tag Archives: URL

VBA – Check if site is online

And here is one more gift from our forum. I love the forum (Did I already say that?).

It was a simple question: How do I check if a site is online? Ok, after a rapid internet search, I’ve found a interesting post on MrExcel forum (by the way, it’s excellent!):

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

It brought to us the function below:

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

The function uses the MSXML2.ServerXMLHTTP library to create a request to a valid URL and returns the HTML of response. It is useful, but, it’s to much if you only want to check if the site is online. The only thing you need to check is the HTTP Code. If the code is 200, everything is ok!

So, I’ve changed the code a bit to this (my apologies for the portuguese names, but, you know, this is a brazilian blog – 🙂 ):

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

I’ve created the EstaOnline Sub as an example of how to call the IsSiteOnline function, which returns a boolean value. If it’s True, the site is online. Otherwise, it’s offline, broken, down, missed…. whatever.

More about ServerXMLHTTP:

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

File Sample:

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

Enjoy!

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