使用 VBA 更改图片

Using VBA to change Picture

提问by PlayKid

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

当您右键单击 Excel/Word/Powerpoint 中的形状时，我正在尝试使用 VBA 来自动化更改图片功能。

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

但是，我找不到任何参考资料，您能帮忙吗？

回答by richnis

You can change the source of a picture using the UserPicturemethod 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.

您可以使用应用于矩形形状的UserPicture方法更改图片的来源。但是，如果您希望保持图片的原始纵横比，则需要相应地调整矩形的大小，因为图片将采用矩形的尺寸。

As an example:

举个例子：

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

回答by chris neilsen

So far as I know you can't changethe 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

回答by ali-mousavi

'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.png", msoFalse, msoTrue, l, t, w, h)
shp.Name = strPic

End Sub

回答by user5326408

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

在 Word 2010 VBA 中，它有助于更​​改要更改的图片元素的 .visible 选项。

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

1. 将 .visible 设置为 false
2. 改变图片
3. 将 .visilbe 设置为 true

that worked for me.

这对我有用。

回答by user5847966

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.

我所做的是将两个图像叠加在一起，并将下面的宏分配给两个图像。显然，我将图像命名为“lighton”和“lightoff”，因此请确保将其更改为您的图像。

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

回答by Yeera

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

回答by user3422093

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.

我在 Excel 和 VBA 中工作。我无法叠加图像，因为我有多个可变数量的工作表并且每张工作表都有图像，所以如果说 20 张有我想要制作动画的所有 5 张图像，那么文件会变得很大。

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

所以我使用了这里列出的这些技巧的组合：1）我在我想要的位置和大小插入了一个矩形形状：

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:

2）现在要动画（更改）图片，我只需要更改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.

所以我已经实现了每张图片只有 1 张图片（而不是我的动画中的 5 张图片）的目标，并且复制工作表只会复制活动图片，因此动画与下一张图片无缝衔接。

回答by konahn

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

我尝试在PowerPoinT(PPT)中用VBA模仿原来的“换图”功能

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

下面的代码尝试恢复原始图片的以下属性： - .Left, .Top, .Width, .Height - zOrder - 形状名称 - 超链接/动作设置 - 动画效果

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.

使用方法：建议您将此宏添加到快速访问工具栏列表中。（转到选项或右键单击功能区菜单））首先，在幻灯片上选择要更改的图片。然后，如果 FileDialog 窗口打开，请选择一张新图片。完成。使用此方法，您可以在想要更改图片时绕过 2016 版中的“必应搜索和一驱动器窗口”。

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.

在代码中，可能（或应该）有一些错误或缺失的东西。如果有人或任何版主更正代码中的这些错误，我将不胜感激。但大多数情况下，我发现它运行良好。另外，我承认还有更多原始形状的属性需要恢复——比如形状的线条属性、透明度、图片格式等等。我认为对于想要复制形状的太多属性的人来说，这可能是一个开始。我希望这对某人有帮助。

回答by Tarun Reddy

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

![请找到附加的代码。先在PPT中创建一个形状并运行代码】1

回答by user4024676

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.

我过去所做的是在窗体上创建几个图像控件并将它们放在彼此的顶部。然后，您以编程方式设置所有图像 .visible = false 除了要显示的图像。