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!