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!
 

Domenic

MrExcel MVP
Joined
Mar 10, 2004
Messages
19,013
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!
 

rbsam

New Member
Joined
Jul 12, 2019
Messages
42
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
 

rbsam

New Member
Joined
Jul 12, 2019
Messages
42
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')
 

Domenic

MrExcel MVP
Joined
Mar 10, 2004
Messages
19,013
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]
 

rbsam

New Member
Joined
Jul 12, 2019
Messages
42
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!
 

Domenic

MrExcel MVP
Joined
Mar 10, 2004
Messages
19,013
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?
 

rbsam

New Member
Joined
Jul 12, 2019
Messages
42
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?
 

Domenic

MrExcel MVP
Joined
Mar 10, 2004
Messages
19,013
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.
 

Forum statistics

Threads
1,082,318
Messages
5,364,524
Members
400,804
Latest member
davileal

Some videos you may like

This Week's Hot Topics

  • populate from drop list with multiple tables
    Hi All, i have a drop list that displays data, what i want is when i select one of those from the list to populate text from different tables on...
  • Find list of words from sheet2 in sheet1 before a comma and extract text vba
    Hi Friends, Trying to find the solution on my task. But did not find suitable one to the need. Here is my query and sample file with details...
  • Dynamic Formula entry - VBA code sought
    Hello, really hope one of you experts can help with this - i've spent hours on this and getting no-where. .I have a set of data (more rows than...
  • Listbox Header
    Have a named range called "AccidentsHeader" Within my code I have: [CODE]Private Sub CommandButton1_Click() ListBox1.RowSource =...
  • Complex Heat Map using conditional formatting
    Good day excel world. I have a concern. Below link have a list of countries that carries each country unique data. [URL...
  • Conditional formatting
    Hi good morning, hope you can help me please, I have cells P4:P54 and if this cell is equal to 1 then i want row O to say "Fully Utilised" and to...
Top