16

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

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

4

10 回答 10

11

据我所知图片的来源是不能改的，需要删除旧的，插入新的

这是一个开始

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
于 2012-04-16T06:47:53.820 回答
10

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

举个例子：

 ActivePresentation.Slides(2).Shapes(shapeId).Fill.UserPicture ("C:\image.png")
于 2013-08-06T14:38:32.003 回答
4 
'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
于 2016-04-21T04:34:13.290 回答
2

我所做的是将两个图像放在彼此的顶部，并将下面的宏分配给两个图像。显然，我已将图像命名为“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
于 2016-01-27T16:48:07.940 回答
1

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

于 2014-09-09T22:16:29.930 回答
1

我试图在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 版中的“必应搜索和 One-Drive 窗口”。

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

于 2018-07-12T16:10:22.143 回答
1

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

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

这对我有用。

于 2015-09-11T17:34:53.880 回答
0

![请查找附件代码。首先在PPT中创建一个形状并运行代码] 1

于 2019-10-31T16:23:59.037 回答
0

我正在使用 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 张）的目标，并且复制工作表只会复制活动图片，因此动画与下一张图片无缝衔接。

于 2017-11-26T19:00:11.533 回答
0

我使用此代码：

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
于 2017-11-11T13:42:15.623 回答