#If VBA7 Then
Private Declare PtrSafe 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
#Else
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
#End If
Private Const ERROR_SUCCESS As Long = 0
Private Const BINDF_GETNEWESTVERSION As Long = &H10
Private Const INTERNET_FLAG_RELOAD As Long = &H80000000
Enum ImageModeEnum
FitCell_MaintainAspect = 1 'resizes the image to fit inside the cell, maintaining aspect ratio.
FitCell_IgnoreAspect = 2 'stretches or compresses the image to fit inside the cell, ignoring aspect ratio.
OriginalSize = 3 'leaves the image at original size, which may cause cropping.
CustomSize = 4 'allows the specification of a custom size.
End Enum
Function IMAGE(TargetURL As String, Optional ImageMode As ImageModeEnum = 3, Optional CustomHeight As Long = -1, Optional CustomWidth As Long = -1)
Dim TargetCell As Range, Img As Object
Dim CallerCell As Variant, TargetFileName As String
Const BASEPATH = "C:\TEMPIMAGES\"
If Len(Dir(BASEPATH, vbDirectory)) = 0 Then MkDir BASEPATH
CallerCell = Application.Caller.Address
If VarType(CallerCell) = vbString Then
Set TargetCell = Range(CallerCell)
TargetFileName = BASEPATH & GetFilenameFromURL(TargetURL)
If Len(Dir(TargetFileName)) <> 0 Then Kill TargetFileName
DownloadFile TargetURL, TargetFileName
TargetCell.Parent.Shapes.AddPicture Filename:=TargetFileName, linktofile:=msoFalse, savewithdocument:=msoTrue, Top:=TargetCell.Top, Left:=TargetCell.Left, Width:=CustomWidth, Height:=CustomHeight
Set Img = TargetCell.Parent.Shapes(TargetCell.Parent.Shapes.Count)
With Img
.LockAspectRatio = IIf(ImageMode = 2, msoFalse, msoTrue)
.Placement = xlMoveAndSize
Select Case ImageMode
Case FitCell_MaintainAspect
If .Width > .Height Then
.Width = TargetCell.Width
Else
.Height = TargetCell.Height
End If
Case FitCell_IgnoreAspect
.Width = TargetCell.Width
.Height = TargetCell.Height
Case CustomSize
.ShapeRange.LockAspectRatio = msoFalse
If CustomHeight >= 0 And CustomWidth >= 0 Then
.Width = CustomWidth
.Height = CustomHeight
ElseIf CustomHeight >= 0 Then
.Height = CustomHeight
Else
.Width = CustomWidth
End If
End Select
End With
End If
IMAGE = ""
End Function
Private Function DownloadFile(ByVal SourceURL As String, ByVal LocalFile As String) As Boolean
DownloadFile = URLDownloadToFile(0&, SourceURL, LocalFile, BINDF_GETNEWESTVERSION, 0&) = ERROR_SUCCESS
End Function
Private Function GetFilenameFromURL(ByVal FilePath As String) As String
If Right$(FilePath, 1) <> "/" And Len(FilePath) > 0 Then
If InStr(FilePath, "?") > 0 Then FilePath = Split(FilePath, "?")(0)
GetFilenameFromURL = GetFilenameFromURL(Left$(FilePath, Len(FilePath) - 1)) + Right$(FilePath, 1)
End If
End Function
