Using VBA to change Picture

Question

I am trying to use VBA to automate the Change Picture function when you right click a Shape in Excel/Word/Powerpoint.

However, I am not able to find any reference, can you assist?

Dominant

Have you tried using the macro recorder and checking what the auto-generated code was? – Greeley

@Greeley this is one of the (few) actions recorder doesn't record – Escort

@chrisneilsen fair enough - I didn't know. – Greeley

Answer 1

So far as I know you can't change the source of a picture, you need to delete the old one and insert a new one

Here's a start

strPic ="Picture Name"
Set shp = ws.Shapes(strPic)

'Capture properties of exisitng picture such as location and size
With shp
    t = .Top
    l = .Left
    h = .Height
    w = .Width
End With

ws.Shapes(strPic).Delete

Set shp = ws.Shapes.AddPicture("Y:\our\Picture\Path\And\File.Name", msoFalse, msoTrue, l, t, w, h)
shp.Name = strPic
shp.ScaleHeight Factor:=1, RelativeToOriginalSize:=msoTrue
shp.ScaleWidth Factor:=1, RelativeToOriginalSize:=msoTrue

Escort

Hi Chris, I thought about that too, however, when it comes to Shadow, Contrast, Brightness, I cannot even change their properties, it will give me errors like copying the property from the old picture to the new picture. But, I can programmatically like Shadow.Blur = 30, but if I say NewPic.Shadow.Blur = OldPic.Shadow.Blur, I get errors. – Dominant

Either record the properties of the old picture in variables before deleting it or leave the picture in place while you copy its properties, record its z-order, then delete it and move the new picture back to the original picture's z-order – Gusty

1up as I can't find any code to change the picture :( so I though this is the only way, but this doesn't make any sense Microsoft :( – Mcmanus

Very sad that it seems impossible to change the source of a picture. Deleting and adding seems too much of a hassle if it comes to PowerPoint where I use animations on pictures. – Interlay

What I ended up doing now is adding all image I need and showing and hiding them according to what I need using VBA. I know this is very unfortunate and not file size optimized of course but for my case it works. – Interlay

Answer 2

You can change the source of a picture using the UserPicture method as applied to a rectangle shape. However, you will need to resize the rectangle accordingly if you wish to maintain the picture's original aspect ratio, as the picture will take the dimensions of the rectangle.

As an example:

 ActivePresentation.Slides(2).Shapes(shapeId).Fill.UserPicture ("C:\image.png")

Bergama

Technically this adds a fill to a shape, and the fill won't be visible if your shape is a picture. – Enamelware

Answer 3

'change picture without change image size
Sub change_picture()
strPic = "Picture 1"
Set shp = Worksheets(1).Shapes(strPic)

'Capture properties of exisitng picture such as location and size
With shp
    t = .Top
    l = .Left
    h = .Height
    w = .Width
End With

Worksheets(1).Shapes(strPic).Delete

Set shp = Worksheets(1).Shapes.AddPicture("d:\pic\1.png", msoFalse, msoTrue, l, t, w, h)
shp.Name = strPic

End Sub

Cylinder

Answer 4

what I do is lay both images on top of eachother, and assign the macro below to both images. Obviously i've named the images "lighton" and "lightoff", so make sure you change that to your images.

Sub lightonoff()

If ActiveSheet.Shapes.Range(Array("lighton")).Visible = False Then
    ActiveSheet.Shapes.Range(Array("lighton")).Visible = True
        Else
    ActiveSheet.Shapes.Range(Array("lighton")).Visible = False
    End If

End Sub

Lothario

Answer 5

What I've done in the past is create several image controls on the form and lay them on top of each other. Then you programmatically set all images .visible = false except the one you want to show.

Susannasusannah

Answer 6

In Word 2010 VBA it helps to change the .visible option for that picture element you want to change.

1. set the .visible to false
2. change the picture
3. set the .visilbe to true

that worked for me.

Diarist

Answer 7

I tried to imitate the original function of 'Change Picture' with VBA in PowerPoinT(PPT)

The code below tries to recover following properties of the original picture: - .Left, .Top, .Width, .Height - zOrder - Shape Name - HyperLink/ Action Settings - Animation Effects

Option Explicit

Sub ChangePicture()

    Dim sld As Slide
    Dim pic As Shape, shp As Shape
    Dim x As Single, y As Single, w As Single, h As Single
    Dim PrevName As String
    Dim z As Long
    Dim actions As ActionSettings
    Dim HasAnim As Boolean
    Dim PictureFile As String
    Dim i As Long

    On Error GoTo ErrExit:
    If ActiveWindow.Selection.Type <> ppSelectionShapes Then MsgBox "Select a picture first": Exit Sub
    Set pic = ActiveWindow.Selection.ShapeRange(1)
    On Error GoTo 0

    'Open FileDialog
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "Picture File", "*.emf;*.jpg;*.png;*.gif;*.bmp"
        .InitialFileName = ActivePresentation.Path & "\"
        If .Show Then PictureFile = .SelectedItems(1) Else Exit Sub
    End With

    'save some properties of the original picture
    x = pic.Left
    y = pic.Top
    w = pic.Width
    h = pic.Height
    PrevName = pic.Name
    z = pic.ZOrderPosition
    Set actions = pic.ActionSettings    'Hyperlink and action settings
    Set sld = pic.Parent
    If Not sld.TimeLine.MainSequence.FindFirstAnimationFor(pic) Is Nothing Then
        pic.PickupAnimation 'animation effect <- only supported in ver 2010 above
        HasAnim = True
    End If

    'insert new picture on the slide
    Set shp = sld.Shapes.AddPicture(PictureFile, False, True, x, y)

    'recover original property
    With shp
        .Name = "Copied_ " & PrevName

        .LockAspectRatio = False
        .Width = w
        .Height = h

        If HasAnim Then .ApplyAnimation 'recover animation effects

        'recover shape order
        .ZOrder msoSendToBack
        While .ZOrderPosition < z
            .ZOrder msoBringForward
        Wend

        'recover actions
        For i = 1 To actions.Count
            .ActionSettings(i).action = actions(i).action
            .ActionSettings(i).Run = actions(i).Run
            .ActionSettings(i).Hyperlink.Address = actions(i).Hyperlink.Address
            .ActionSettings(i).Hyperlink.SubAddress = actions(i).Hyperlink.SubAddress
        Next i

    End With

    'delete the old one
    pic.Delete
    shp.Name = Mid(shp.Name, 8)  'recover name

ErrExit:
    Set shp = Nothing
    Set pic = Nothing
    Set sld = Nothing

End Sub

How to use: I suggest you to add this macro into the Quick Access Toolbar list. (Goto Option or Right-click on the Ribbon menu)) First, select a Picture on the slide which you want to change. Then, if the FileDialog window opens, choose a new picture. It's done. By using this method, you can bypass the 'Bing Search and One-Drive Window' in ver 2016 when you want to change a picture.

In the code, there might(or should) be some mistakes or something missing. I'd appreciate it if somebody or any moderator correct those errors in the code. But mostly, I found that it works fine. Also, I admit that there are still more properties of the original shape to recover - like the line property of the shape, transparency, pictureformat and so on. I think this can be a beginning for people who want to duplicate those TOO MANY properties of a shape. I hope this is helpful to somebody.

Sedimentation

Answer 8

i use this code :

Sub changePic(oshp As shape)
    Dim osld As Slide
    Set osld = oshp.Parent
    osld.Shapes("ltkGambar").Fill.UserPicture (ActivePresentation.Path & "\" & oshp.Name & ".png")
End Sub

Jetpropelled

and that was for left click, not right click, coz in powerpoint there is only mouse click and mouseover – Jetpropelled

if u still ask for right click, i'am not find the solution yet – Jetpropelled

Answer 9

I'm working in Excel and VBA. I can't overlay images because I have multiple sheets of a variable number and each sheet has the images, so the file would get huge if, say 20 sheets had all 5 images I want to animate.

So I used a combination of these tricks listed here: 1) I inserted an RECTANGLE shape at the location and size I wanted:

ActiveSheet.Shapes.AddShape(msoShapeRectangle, 1024#, 512#, 186#, 130#).Select
Selection.Name = "SCOTS_WIZARD"
With Selection.ShapeRange.Fill
  .Visible = msoTrue
  .UserPicture "G:\Users\ScotLouis\Documents\My Spreadsheets\WordFind Wizard\WordFind Wizard 1.jpg"
  .TextureTile = msoFalse
End With

2) Now to animate (change) the picture, I only need to change the Shape.Fill.UserPicture:

ActiveSheet.Shapes("SCOTS_WIZARD").Fill.UserPicture _
    "G:\Users\ScotLouis\Documents\My Spreadsheets\WordFind Wizard\WordFind Wizard 2.jpg"

So I've accomplished my goal of only having 1 picture per sheet (not 5 as in my animation) and duplicating the sheet only duplicates the active picture, so the animation continues seamlessly with the next picture.

Weinman

Answer 10

![Please find attached code. First create a shape in PPT and run the code]1

Alleluia

Answer 11

@konahn Thank you so much!! I rewrote the code a bit. Now VBA will automatically search for a picture with the desired name picture1 and automatically replace it with picture2 from the pre-specified directory without the participation of the operator

Option Explicit
 
Sub ChangePicture()
 
Dim sld As Slide
Dim pic As Shape, shp As Shape
Dim x As Single, y As Single, w As Single, h As Single
Dim PrevName As String
Dim z As Long
Dim actions As ActionSettings
Dim HasAnim As Boolean
Dim PictureFile As String
Dim i As Long
 
' Find the shape with the name "picture1"
Set pic = Nothing
For Each sld In ActivePresentation.Slides
    For Each shp In sld.Shapes
        If shp.Type = msoPicture And shp.Name = "picture1" Then
            Set pic = shp
            Exit For
        End If
    Next shp
    If Not pic Is Nothing Then Exit For
Next sld
If pic Is Nothing Then
    MsgBox "Picture not found."
    Exit Sub
End If
 
'Get the new picture file path
PictureFile = "D:\picture2.jpg"
 
'save some properties of the original picture
x = pic.left
y = pic.top
w = pic.width
h = pic.height
PrevName = pic.Name
z = pic.ZOrderPosition
Set actions = pic.ActionSettings    'Hyperlink and action settings
Set sld = pic.Parent
If Not sld.TimeLine.MainSequence.FindFirstAnimationFor(pic) Is Nothing Then
    pic.PickupAnimation 'animation effect <- only supported in ver 2010 above
    HasAnim = True
End If
 
'insert new picture on the slide
Set shp = sld.Shapes.AddPicture(PictureFile, False, True, x, y)
 
'recover original property
With shp
    .Name = "Copied_ " & PrevName
 
    .LockAspectRatio = False
    .width = w
    .height = h
 
    If HasAnim Then .ApplyAnimation 'recover animation effects
 
    'recover shape order
    .ZOrder msoSendToBack
    While .ZOrderPosition < z
        .ZOrder msoBringForward
    Wend
 
   'recover actions
For i = 1 To actions.count
.ActionSettings(i).Action = actions(i).Action
.ActionSettings(i).Run = actions(i).Run
.ActionSettings(i).Hyperlink.Address = actions(i).Hyperlink.Address
.ActionSettings(i).Hyperlink.SubAddress = actions(i).Hyperlink.SubAddress
Next i
 
End With
 
'delete the old one
pic.Delete
shp.Name = Mid(shp.Name, 8) 'recover name
 
Exit Sub
 
ErrHandler:
MsgBox "Error " & Err.Number & ": " & Err.Description
End Sub

Kamila