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

Word 2010 VBA では、変更する画像要素の .visible オプションを変更すると役立ちます。

  1. .visible を false に設定します
  2. 写真を変える
  3. .visilbe を true に設定します

それは私のために働いた。

于 2015-09-11T17:34:53.880 に答える
1

PowerPointT(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 ウィンドウが開いたら、新しい画像を選択します。終わった。この方法を使えば、ver 2016 の「Bing Search と One-Drive ウィンドウ」をバイパスして、画像を変更することができます。

コードには、いくつかの間違いや欠落がある可能性があります (またはあるはずです)。誰かまたはモデレーターがコードのエラーを修正してくれれば幸いです。しかし、ほとんどの場合、うまく機能することがわかりました。また、復元する元の形状のプロパティがまだ他にもあることを認めます。たとえば、形状の線のプロパティ、透明度、画像形式などです。形状のあまりにも多くのプロパティを複製したい人にとって、これは始まりになると思います。これが誰かの役に立てば幸いです。

于 2018-07-12T16:10:22.143 に答える