Replace the current Picture on a Worksheet with another of choice.

[beloshi]

Hello Excel Gurus

Once again I am thankful to this platform to help me when I got stuck in anything related to excel VBA.

I have been searching all day today to look for a solution which matches my case but unfortunately did not find a single one or may be I am searching it all wrong. Kindly help to point me to the right direction

Let me explain my case here, I have a worksheet which has two pictures in short its an Executive summary which has two pictures related to trend every month I need to update that executive summary and also the sales data inside for almost 25 different workbooks . I have dealt with the sales data part with vba to auto update all the sales figures including the executive summary but I also need to change a picture depicting some trend taken from another source as a picture(the picture is already ready to be imported). Every month I change that picture manually but now I want a vba code which automatically changes the old trend picture to the one I specify. (Either ask to select the image from OPEN FILE dialogue) or I can embed the path with the name of the picture.

1- Code should Identify the picture on the selected sheet "xyz" and prompt me to change it with the new image

or

2- both the images should be changed from a selected folder.

Awaiting your precious suggestions.

Best regards

Beloshi

 

[yky]

Are those two pictures the only pictures in that sheet? If so, you can delete them using the command like "ThisWorkbook.Sheets(1).Pictures.Delete".

Then, you can add pictures using the code like (if they are resided in a folder) :

Dim p As Object
Set p = Workbooks(workbookname).Sheets(sheetname).Shapes.AddPicture(Filename:=Path &  "\" & picturename & ".jpg", LinkToFile:=False, SaveWithDocument:=True, Left:=cell_to_be_inserted.Left, _
 Top:=cell_to_be_inserted.Top, Width:=-1, Height:=-1)

cell_to_be_inserted is the cell you want the picture to be in. You need to adjust picture width and height. The code uses -1 and -1 that will give you picture in its original size which might be too big.

 

[beloshi]

Are those two pictures the only pictures in that sheet? If so, you can delete them using the command like "ThisWorkbook.Sheets(1).Pictures.Delete".

Then, you can add pictures using the code like (if they are resided in a folder) :

Dim p As Object
Set p = Workbooks(workbookname).Sheets(sheetname).Shapes.AddPicture(Filename:=Path &  "\" & picturename & ".jpg", LinkToFile:=False, SaveWithDocument:=True, Left:=cell_to_be_inserted.Left, _
 Top:=cell_to_be_inserted.Top, Width:=-1, Height:=-1)

cell_to_be_inserted is the cell you want the picture to be in. You need to adjust picture width and height. The code uses -1 and -1 that will give you picture in its original size which might be too big.

Thank you for the reply yes they are on the same sheet and changing the sheet is also not a problem isn't there a way to replace the picture like we do in Excel with "Change Picture" option as it gets the picture in the same place where the previous one is automatically and keeping the aspect ratio intact?

Thank you for the code I will test it in and see if I can modify it somehow to suit my requirement.

Because I am doing it for more than 25 workbooks every month so as mentioned above I have used VBA to take care of my data/figures update part now just the picture part left which is also important to update.

Best regards

Beloshi

 

[tonyyy]

Beloshi,

...isn't there a way to replace the picture like we do in Excel with "Change Picture" option as it gets the picture in the same place where the previous one is automatically and keeping the aspect ratio intact?

You might consider the following...

Sub changePictures()
''''Select the picture you want to replace before running the macro

Dim shp As Shape, UserSelection As Variant
Dim t As Long, l As Long, h As Long, w As Long
Dim fDialog As FileDialog, fName As String

Set UserSelection = ActiveWindow.Selection

On Error GoTo NoShape
Set shp = ActiveSheet.Shapes(UserSelection.Name)
  
''''Capture existing shape location and dimensions
On Error Resume Next
    t = shp.Top
    l = shp.Left
    h = shp.Height
    w = shp.Width

''''Delete existing shape
shp.Delete
On Error GoTo 0

''''Select new shape (ie, picture)
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
With fDialog
    .AllowMultiSelect = False
    .Title = "Select a file"
    .InitialFileName = "C:\Docs 2018\2018 Gigs\"
    If .Show = -1 Then
       fName = .SelectedItems(1)
    End If
End With

''''Add new shape
Set shp = ActiveSheet.Shapes.AddPicture _
    (Filename:=fName, linktofile:=msoFalse, savewithdocument:=msoTrue, _
    Top:=t, Left:=l, Height:=-1, Width:=-1)
shp.Name = fName

shp.Select
With Selection.ShapeRange
    .LockAspectRatio = msoTrue
    .Height = h
'    .Width = w'Choose height or width, not both
End With

Exit Sub
NoShape:
    MsgBox "Please select a picture or shape."
End Sub

Cheers,

tonyyy

 

[beloshi]

Beloshi,



You might consider the following...

Sub changePictures()
''''Select the picture you want to replace before running the macro

Dim shp As Shape, UserSelection As Variant
Dim t As Long, l As Long, h As Long, w As Long
Dim fDialog As FileDialog, fName As String

Set UserSelection = ActiveWindow.Selection

On Error GoTo NoShape
Set shp = ActiveSheet.Shapes(UserSelection.Name)
  
''''Capture existing shape location and dimensions
On Error Resume Next
    t = shp.Top
    l = shp.Left
    h = shp.Height
    w = shp.Width

''''Delete existing shape
shp.Delete
On Error GoTo 0

''''Select new shape (ie, picture)
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
With fDialog
    .AllowMultiSelect = False
    .Title = "Select a file"
    .InitialFileName = "C:\Docs 2018\2018 Gigs\"
    If .Show = -1 Then
       fName = .SelectedItems(1)
    End If
End With

''''Add new shape
Set shp = ActiveSheet.Shapes.AddPicture _
    (Filename:=fName, linktofile:=msoFalse, savewithdocument:=msoTrue, _
    Top:=t, Left:=l, Height:=-1, Width:=-1)
shp.Name = fName

shp.Select
With Selection.ShapeRange
    .LockAspectRatio = msoTrue
    .Height = h
'    .Width = w'Choose height or width, not both
End With

Exit Sub
NoShape:
    MsgBox "Please select a picture or shape."
End Sub

Cheers,

tonyyy

Thank you very much for the code Tonyyy, although the code is doing fine but it has two issues if there is any suggestion to change it than it would totally fit my requirements

I- I have tried this code and it works but it is not using the aspect ratio of the source picture whereas it is using the aspect ratio of the which I select (later picture i.e.)

II- The codes need to select the pictures in the sheets automatically (otherwise if I can click on the picture than I can also right click on it to change the picture manually with same efforts), as I want to add the code to my current VBA to do everything on its own from updating the whole workbook data/ figures as well as Pictures / charts in it.

Hope I am clear with the requirements now.

best regards

Beloshi

 

[tonyyy]

I- I have tried this code and it works but it is not using the aspect ratio of the source picture whereas it is using the aspect ratio of the which I select (later picture i.e.)

Let's call the picture that's currently on the sheet "sheetPic". And the picture somewhere on your hard drive "filePic." Let's assume the pics are different in size and aspect ratio. (Is that a true assumption?) Let's also assume you want to position the filePic, when it's inserted, with the same upper left corner of the sheetPic (which will be deleted.) So, when the filePic is inserted - what size do you want it to be? Which aspect ratio should it adhere to?

II- The codes need to select the pictures in the sheets automatically (otherwise if I can click on the picture than I can also right click on it to change the picture manually with same efforts), as I want to add the code to my current VBA to do everything on its own from updating the whole workbook data/ figures as well as Pictures / charts in it.

I'll assume you have code to loop through the ~25 workbooks and worksheets, so the changePictures code will either be embedded into your existing code or called as a subroutine. Are the names of the pictures on the sheet constant? Are they sheetPic1 and sheetPic2? And when replaced, will they still be named sheetPic1 and sheetPic2? How are the filePics named? (I'm trying to determine how you want to match sheetPics to filePics so the sheetPics are replaced with the correct filePic. Or does it matter?)

 

[beloshi]

Let's call the picture that's currently on the sheet "sheetPic". And the picture somewhere on your hard drive "filePic." Let's assume the pics are different in size and aspect ratio. (Is that a true assumption?) Let's also assume you want to position the filePic, when it's inserted, with the same upper left corner of the sheetPic (which will be deleted.) So, when the filePic is inserted - what size do you want it to be? Which aspect ratio should it adhere to?

Yes, Your assumption is true. I want to position file on the same place where there is already a Picture which will be replaced / deleted in the same position and with the same aspect ratio as the one which was replaced.

I'll assume you have code to loop through the ~25 workbooks and worksheets, so the changePictures code will either be embedded into your existing code or called as a subroutine. Are the names of the pictures on the sheet constant? Are they sheetPic1 and sheetPic2? And when replaced, will they still be named sheetPic1 and sheetPic2? How are the filePics named? (I'm trying to determine how you want to match sheetPics to filePics so the sheetPics are replaced with the correct filePic. Or does it matter?)

Yes I have the code which is looping through all of the ~25 workbooks and worksheets with data and charts (snippets), the code I will use as a subroutine as I don't want to touch the data automation vba part so I will make a sub and than call it as required with my current set of code. The names of the pictures are not constant but I will make them if required by the code itself. Yes you can assume it like sheetPic1 and sheetPic2 and yes they should inherit the same name sheetPic1 and sheetPic2.

Actually about your last part of the question whether how I want to match sheetPics to filePics is a bit tricky so to make it simple , what I can do now I will save the filepics as the same aspect ratio as the sheetPics but they have a different name like "filePic_CS" and "filepic_CH" placed collectively in designated folder which is updated everymonth but the folder name bears the month name like 2018-06 , 2018-07 so on so forth.

Hope I am clear with my answers to your question, if still there is smthing which you need to know kindly let me know. I am really thankful for all these efforts you are putting in and can't thank you enough for it.


With best regards

beloshi

 

[tonyyy]

I want to position file on the same place where there is already a Picture which will be replaced / deleted in the same position and with the same aspect ratio as the one which was replaced.

Even though you're explicit in stating "the same aspect ratio" - I'm guessing you really mean same size. In an executive summary, if you insert a picture 10x larger than the existing picture, even if it has the same aspect ratio as the picture being replaced it could easily overlay everything else.

Sub changePicturesLoop()
Application.ScreenUpdating = False
Dim shp As Shape, UserSelection As Variant
Dim t As Long, l As Long, h As Long, w As Long
Dim fPath As String, fName1 As String, fName2 As String

fPath = "C:\Docs 2018\2018 Gigs\" ''''Change to your folder path
fName1 = fPath & "Cloud 9.jpg" '''Change to "filePic_CS" (This will replace Picture 1)
fName2 = fPath & "Daydream Farm.jpg" '''Change to "filePic_CH" (This will replace Picture 2)

For Each shp In ActiveSheet.Shapes
    t = shp.Top
    l = shp.Left
    h = shp.Height
    w = shp.Width
    If shp.Name = "Picture 1" Then
        shp.Delete
        Set shp = ActiveSheet.Shapes.AddPicture _
            (Filename:=fName1, linktofile:=msoFalse, savewithdocument:=msoTrue, _
            Top:=t, Left:=l, Height:=h, Width:=w)
        shp.Name = "Picture 1"
    ElseIf shp.Name = "Picture 2" Then
        shp.Delete
        Set shp = ActiveSheet.Shapes.AddPicture _
            (Filename:=fName2, linktofile:=msoFalse, savewithdocument:=msoTrue, _
            Top:=t, Left:=l, Height:=h, Width:=w)
        shp.Name = "Picture 2"
    End If
Next shp
End Sub

 

[beloshi]

Even though you're explicit in stating "the same aspect ratio" - I'm guessing you really mean same size. In an executive summary, if you insert a picture 10x larger than the existing picture, even if it has the same aspect ratio as the picture being replaced it could easily overlay everything else.

Sub changePicturesLoop()
Application.ScreenUpdating = False
Dim shp As Shape, UserSelection As Variant
Dim t As Long, l As Long, h As Long, w As Long
Dim fPath As String, fName1 As String, fName2 As String

fPath = "C:\Docs 2018\2018 Gigs\" ''''Change to your folder path
fName1 = fPath & "Cloud 9.jpg" '''Change to "filePic_CS" (This will replace Picture 1)
fName2 = fPath & "Daydream Farm.jpg" '''Change to "filePic_CH" (This will replace Picture 2)

For Each shp In ActiveSheet.Shapes
    t = shp.Top
    l = shp.Left
    h = shp.Height
    w = shp.Width
    If shp.Name = "Picture 1" Then
        shp.Delete
        Set shp = ActiveSheet.Shapes.AddPicture _
            (Filename:=fName1, linktofile:=msoFalse, savewithdocument:=msoTrue, _
            Top:=t, Left:=l, Height:=h, Width:=w)
        shp.Name = "Picture 1"
    ElseIf shp.Name = "Picture 2" Then
        shp.Delete
        Set shp = ActiveSheet.Shapes.AddPicture _
            (Filename:=fName2, linktofile:=msoFalse, savewithdocument:=msoTrue, _
            Top:=t, Left:=l, Height:=h, Width:=w)
        shp.Name = "Picture 2"
    End If
Next shp
End Sub

Thank you very much tonyyy for posting this, my apologies for the late reply as I was out of town for 3 days on an official trip. But I checked your code today and it worked like a charm.

 

[tonyyy]

You're very welcome...