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") |
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 |
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 |
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
