Question

当您在Excel / Word / Powerpoint中右键单击一个Shape时，我正在尝试使用VBA自动执行更改图片功能。

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

Answer 1

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

举个例子：

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

Answer 2

据我所知，你不能更改图片来源，你需要删除旧图片并插入一张新图片

这是一个开始

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

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

Answer 4

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

将.visible设置为false
更改图片
将.visilbe设置为true

对我有用。

Answer 5

我所做的是将两个图像放在彼此的顶部，并将下面的宏指定给两个图像。显然我已将图像命名为“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

Answer 6

我过去所做的是在表单上创建多个图像控件并将它们叠放在一起。然后以编程方式设置除要显示的图像之外的所有图像.visible = false。

Answer 7

我使用此代码：

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

Answer 8

我在Excel和VBA工作。我无法覆盖图像，因为我有多张可变数字的图纸，而且每张图纸都有图像，所以如果20页有我想要动画的所有5张图像，文件会变得很大。

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

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

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

所以我完成了我的目标，即每张照片只有1张照片（而不是我的动画中的5张照片）并且复制照片仅复制活动照片，因此动画会与下一张照片无缝连接。

Answer 9

我试图用PowerPoinT（PPT）中的VBA模仿“更改图片”的原始功能

下面的代码尝试恢复原始图片的以下属性： -.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

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

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

Answer 10

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

使用VBA更改图片

10 个答案: