当您在 Excel/Word/Powerpoint 中右键单击形状时，我正在尝试使用 VBA 自动更改图片功能。
但是，我找不到任何参考资料，您能帮忙吗？
【问题讨论】：
标签： image vba ms-office excel-2007
据我所知你不能更改图片的来源，你需要删除旧的并插入一个新的
这是一个开始
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
【讨论】：
您可以使用应用于矩形的UserPicture 方法更改图片的来源。但是，如果您希望保持图片的原始纵横比，则需要相应地调整矩形的大小，因为图片将采用矩形的尺寸。
举个例子：
ActivePresentation.Slides(2).Shapes(shapeId).Fill.UserPicture ("C:\image.png")
【讨论】：
'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
【讨论】：
我所做的是将两个图像放在彼此的顶部，并将下面的宏分配给两个图像。显然我已将图像命名为“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
【讨论】：
我过去所做的是在表单上创建几个图像控件，然后将它们叠放在一起。然后您以编程方式设置所有图像 .visible = false 除了您要显示的图像。
【讨论】：
在 Word 2010 VBA 中，更改要更改的图片元素的 .visible 选项会有所帮助。
这对我有用。
【讨论】：
我尝试在PowerPoinT(PPT)中用VBA模拟'Change Picture'的原始功能
下面的代码尝试恢复原始图片的以下属性： - .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 版中的“必应搜索和 One-Drive 窗口”。
在代码中，可能（或应该）有一些错误或遗漏。 如果有人或任何版主纠正代码中的这些错误，我将不胜感激。 但大多数情况下，我发现它工作正常。 另外，我承认还有更多原始形状的属性需要恢复——比如形状的线条属性、透明度、图片格式等。 我认为对于想要复制形状的太多属性的人来说，这可能是一个开始。 我希望这对某人有帮助。
【讨论】：
我使用这个代码：
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
【讨论】：
我正在使用 Excel 和 VBA。我无法叠加图像，因为我有多个可变编号的工作表，并且每张工作表都有图像，所以如果 20 张工作表包含我想要制作动画的所有 5 个图像，文件会变得很大。
所以我结合了这里列出的这些技巧： 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) 现在要对图片进行动画（更改），我只需要更改 Shape.Fill.UserPicture：
ActiveSheet.Shapes("SCOTS_WIZARD").Fill.UserPicture _
"G:\Users\ScotLouis\Documents\My Spreadsheets\WordFind Wizard\WordFind Wizard 2.jpg"
所以我已经实现了每张只有 1 张图片（而不是动画中的 5 张）的目标，并且复制这张图片只会复制活动图片，因此动画会与下一张图片无缝继续。
【讨论】：