Option Explicit
Sub ReplaceRectangleImage()
Dim rectangleShape As Shape
Dim replacementImage As Shape
Application.ScreenUpdating = False
'set the rectangle (change the rectangle name accordingly)
Set rectangleShape = ThisWorkbook.Worksheets("Sheet1").Shapes("Rectangle 1")
'set the replacement image located in the specified cell (change the cell reference accordingly)
Set replacementImage = GetReplacementImage(ThisWorkbook.Worksheets("Sheet2").Range("B2"))
'if an image isn't found within the specified cell, exit the sub
If replacementImage Is Nothing Then
MsgBox "No image found!", vbExclamation
Exit Sub
End If
'call sub to replace the image within the rectangle
ReplaceImage rectangleShape, replacementImage
Application.ScreenUpdating = True
End Sub
Function GetReplacementImage(ByVal Target As Range) As Shape
Dim sourceWorksheet As Worksheet
Dim currentShape As Shape
Set sourceWorksheet = Target.Parent
For Each currentShape In sourceWorksheet.Shapes
If Not Intersect(currentShape.TopLeftCell, Target) Is Nothing Then
If currentShape.Type = msoPicture Then
Set GetReplacementImage = currentShape
Exit Function
Else
Set GetReplacementImage = Nothing
Exit Function
End If
End If
Next currentShape
Set GetReplacementImage = Nothing
End Function
Sub ReplaceImage(ByVal rectangleShape As Shape, ByVal replacementImage As Shape)
Dim sourceWorksheet As Worksheet
Dim temporaryChartObject As ChartObject
Dim temporaryFile As String
temporaryFile = Environ("temp") & "\temp.png"
Set sourceWorksheet = replacementImage.Parent
Set temporaryChartObject = sourceWorksheet.ChartObjects.Add(Left:=0, Top:=0, Width:=replacementImage.Width, Height:=replacementImage.Height)
With temporaryChartObject
.Activate
With .Chart
.ChartArea.Format.Line.Visible = msoFalse
replacementImage.Copy
.Paste
.Export Filename:=temporaryFile, FilterName:="PNG"
End With
rectangleShape.Fill.UserPicture temporaryFile
.Delete
End With
Kill temporaryFile
rectangleShape.Parent.Activate
End Sub
