Replace image on sheet1 shape fill with image from sheet2 cell

rbsam

New Member
Joined
Jul 12, 2019
Messages
42
I have a rectangle with an image fill on sheet 1.

On sheet 2 I have images that aren't a shape, they were just drag and dropped into Excel, but they are located within the cell borders

I'm trying to figure out the code to take the image from a specific cell on sheet 2 and replace the shape image fill on sheet 1 with it.
Is it possible to do this?
Any help would be appreciated!
 

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple
Place the following code in a regular module (Visual Basic Editor >> Insert >> Module). Note that it assumes that the workbook running the code contains the relevant sheets (Sheet1 and Sheet2).

Code:
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

Hope this helps!
 
Upvote 0
Place the following code in a regular module (Visual Basic Editor >> Insert >> Module). Note that it assumes that the workbook running the code contains the relevant sheets (Sheet1 and Sheet2).

Code:
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

Hope this helps!

Hey, thanks so much for taking the time to reply.

It doesn't seem to work for me, but that could just be me not implanting it correctly. I just want to check I've changed the right parts of your code so I'll refer to it by your comment line

'set the rectangle (change the rectangle name accordingly)
Set rectangleShape = ThisWorkbook.Worksheets("this is where I put the name of the sheet that contains the rectangle that contains the image fill that needs to change, right?").Shapes("this is the name of the rectangle shape?")

'set the replacement image located in the specified cell (change the cell reference accordingly)
Set replacementImage = GetReplacementImage(ThisWorkbook.Worksheets("this is the other sheet nam that contains the cell with the desired image?").Range("this is the cell number that contains the image? eg. C4?"))

These are the only parts that I could tell needed parts replacing. Does the image located on sheet2 in cell eg. C4 need to have some sort of action performed to attach it to that cell properly? I did a drag-and-drop into the cell and ensured it was within the cell borders so it didn't cross over to cover 2 cells.

Thanks again for your help!

Oh I should point out, the running of the code didn't cause an error, it just didn't react
 
Upvote 0
Hey, thanks so much for taking the time to reply.

It doesn't seem to work for me, but that could just be me not implanting it correctly. I just want to check I've changed the right parts of your code so I'll refer to it by your comment line

'set the rectangle (change the rectangle name accordingly)
Set rectangleShape = ThisWorkbook.Worksheets("this is where I put the name of the sheet that contains the rectangle that contains the image fill that needs to change, right?").Shapes("this is the name of the rectangle shape?")

'set the replacement image located in the specified cell (change the cell reference accordingly)
Set replacementImage = GetReplacementImage(ThisWorkbook.Worksheets("this is the other sheet nam that contains the cell with the desired image?").Range("this is the cell number that contains the image? eg. C4?"))

These are the only parts that I could tell needed parts replacing. Does the image located on sheet2 in cell eg. C4 need to have some sort of action performed to attach it to that cell properly? I did a drag-and-drop into the cell and ensured it was within the cell borders so it didn't cross over to cover 2 cells.

Thanks again for your help!

Oh I should point out, the running of the code didn't cause an error, it just didn't react



Ah so I realised that my button was set to only run my code and not yours. I wasn't sure how to make the button run multiple macros so I inserted the code:

Sub RunAll()
Call insert
Call GetReplacementImage
Call ReplaceImage
Call ReplaceRectangleImage
End Sub

and then assigned the macro 'RunAll' to the button

However when I click the button I get:

Compile error: Argument not optional

and then it highlights Sub RunAll()

I'm not sure what happened because one time when I clicked it it actually did produce the image in question, but it was inside a chart fixed to the very top left of Sheet2 (should be sheet 1), but I haven't been able to reproduce that

By the way, when I went to assign a Macro to the button, it listed in my code 'insert', your code 'ReplaceRectangleImage' but it didn't list 'ReplaceImage' or 'GetReplacementImage' (maybe it's because GetReplacementImage is a function, not a sub? but it didn't list 'ReplaceImage')
 
Upvote 0
You only need to call ReplaceRectangleImage, which will in turn call the GetReplacementImage and ReplaceImage...

Code:
[COLOR=#333333]Sub RunAll()[/COLOR]
[COLOR=#333333]    Call insert[/COLOR]
[COLOR=#333333]    Call ReplaceRectangleImage[/COLOR]
[COLOR=#333333]End Sub[/COLOR]
 
Upvote 0
Ok, so now I'm getting

Run-time error '-2147024894 (80070002)':
Method of 'UserPicture' of object 'Fillformat' failed

When I click Debug it highlight the line
rectangleShape.Fill.UserPicture temporaryFile

However, the weird thing, is it really messes with the viewing of the spreadsheet, it's like it's really zoomed out and zooming in is quite glitchy. But if you select any cell, then zoom in back to 100%, it seems to go back to normal. In addition to this, the image does get inserted correctly despite the error message, but it's not on sheet1, its on sheet2 which is where the image source is. It inserts it in the very top left corner of sheet2 as a picture ('Picture 1') and as I can't move it the only option is to delete it, which then reveals a blank white space behind it covering what was there before (like the textbook with the title of the project in the top left corner), and that's because this white space is considered a chart, I can then delete the chart and it reveals what is behind it (like the textbook title of the project)

So it's capturing the source image correctly, and it is inserting it, but it is inserting it on the wrong sheet and it is fixed to the top left and won't move

Any ideas? thanks again for your help!
 
Upvote 0
It would suggest that the file specified by temporaryFile does not exist. Other than calling ReplaceRectangleImage from another procedure, did you change the code at all?
 
Upvote 0
It would suggest that the file specified by temporaryFile does not exist. Other than calling ReplaceRectangleImage from another procedure, did you change the code at all?

Nope, no other changes.

I've developed a work around which I think is probably good enough to keep.

Rather than the user drag-and-dropping the image into the cell, I've included a button that pops open the file browser. The user selects the image, the code retrieves the file path from their file selection and inserts a rectangle shape with the image fill of that file path. Because it's a rectangle with a image fill, I think I'll be able to reference it later easier than just an image dragged inside a cell.

What do you think of this solution? It seems to work for me, but can you imagine anything that could break?
 
Upvote 0
I think your solution is much better. It would eliminate the need to store the images within the file itself, which would reduce the size of the file. And, it would eliminate the need to create a temporary chartobject in order to first export the image to a file and then fill the shape with the image, making it more efficient.
 
Upvote 0

Forum statistics

Threads
1,213,495
Messages
6,113,992
Members
448,538
Latest member
alex78

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top