Tag Archives: LoadPicture

Microsoft Office, VBA

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