Function ShowPicD(PicFile As String, _
Optional iWidth As Single = 118, _
Optional iHeight As Single = 89, _
Optional ShiftHorizontal As Single = 0, _
Optional ShiftVertical As Single = 0) As String
'Shows a picture and deletes previous picture when picfile changes.
'Adapted from ShowPicD code posted by Damon Ostrander, with special
'thanks to PA HS Teacher for some nice improvements.
'See Pictures in Excel Formula
'and ShowPicD Function - Aspect Ratio
'and VB- Automatically Insert Picture
'Major modifications are as follows:
'1) Use correct variable types (Single) for width, etc.
'2) Width and height are optional (credit to PA HS Teacher).
'3) Enable user to just send in width or height, calculate other value
' assuming a 4x3 image.
'4) Add option to shift the image horizontally and vertically.
'5) Link to picture instead of embedding in the file - makes saves
' faster and reduces file size (credit to PA HS Teacher).
'6) Fix issue with picture showing up on other worksheets (credit to
' PA HS Teacher).
'7) Name the picture based on cell location so that we do not have to
' search for pictures by location.
'8) Return a String instead of a Boolean in order to display "No Image"
' in cell if no image exists.
'9) Probably a few other tweaks.
On Error GoTo Done
' Default to 4x3 image size if one of dimensions is specified as 0
' Note - if we wanted to generally scale the picture that can be
' done (instead of doing this) - see note on this further in the
' routine. We assume that the user will send in one of these values
' (not both as zero).
'If iHeight = 0 Then
'iHeight = 0.75 * iWidth
'ElseIf iWidth = 0 Then
'iWidth = 4 / 3 * iWidth
'End If
'Look for a picture already over cell (note we name the picture based
'on cell location below so we can use the name as our search criteria)
Dim AC As Range
Set AC = Application.Caller
Dim SheetName As String
SheetName = AC.Parent.Name
'Note - this will delete max of one existing picture over cell
Dim P As Shape
For Each P In Worksheets(SheetName).Shapes
If P.Type = msoLinkedPicture Then
If P.Name = SheetName & "-" & CStr(AC.Row) & ":" & CStr(AC.Column) Then
P.Delete
Exit For
End If
End If
Next P
'Special case if picture file is blank - return empty string and exit
If PicFile = "" Then
ShowPicD = ""
Exit Function
End If
'Notes on AddPicture method:
'AC.Left = the position (in points) of the upper-left corner of the picture
'relative to the upper-left corner of the document.
'AC.Top = the position (in points) of the upper-left corner of the picture
'relative to the top of the document (thus we subtract ShiftVertical below
'instead of add it).
'The 3rd argument is set to false to save a link to the file, versus embedding
'in the Excel file - makes our files much smaller and saves much faster.
Set P = Worksheets(SheetName).Shapes.AddPicture(PicFile, msoCTrue, msoFalse, _
AC.Left, AC.Top, iWidth, iHeight)
'P.ScaleHeight 1#, True, msoScaleFromTopLeft
'P.ScaleWidth 1#, True, msoScaleFromTopLeft
'P.SetShapesDefaultProperties
P.ScaleHeight Factor:=1, RelativeToOriginalSize:=msoTrue
P.ScaleWidth Factor:=1, RelativeToOriginalSize:=msoTrue
'Shift the picture if needed. Note: Excel may not shift the picture
'exactly as we request - it can come out 0.2 off from where we want
'it. The original ShowPicD function searched for the previous picture
'based on location, which would fail due to this slight discrepancy.
'Thus we now name the picture based on cell location instead.
P.IncrementLeft ShiftHorizontal
P.IncrementTop -ShiftVertical
'Uncomment the code below to see the possible 0.2 shift mentioned above
'Dim err_left As Single, err_top As Single
'err_left = P.left - left
'err_top = P.top - top
'Dim result As Integer
'result = MsgBox("Image shift - " & PicFile & vbCrLf & _
' "Left = " & Str(err_left) & vbCrLf & "Top = " & Str(err_top))
'Name P based on calling cell location
'Note - I use CStr instead of Str as Str adds a space before the number
P.Name = SheetName & "-" & CStr(AC.Row) & ":" & CStr(AC.Column)
'Note - another way to scale the image is to do the below (use this
'if you cannot live with the 4x3 image scaling earlier in the function),
'but this will be slightly slower as the picture will be scaled twice.
'P.ScaleHeight 1, msoCTrue
'P.ScaleWidth 1, True
'P.Height = iHeight
'Also can set P.Width instead
ShowPicD = ""
Exit Function
Done:
ShowPicD = "No Image"
End Function
