Вопрос по image, vba – Использование VBA для изменения изображения

9

Я пытаюсь использовать VBA для автоматизации функции изменения изображения, когда вы щелкаете правой кнопкой мыши по фигуре в Excel / Word / Powerpoint.

Тем не менее, я не могу найти какую-либо ссылку, вы можете помочь?

Вы пытались использовать макро-рекордер и проверять, какой был автоматически сгенерированный код? assylias
@ chrisneilsen достаточно справедливо - я не знал. assylias
@assylias это одно из (немногих) действий, которое рекордер не записывает chris neilsen

Ваш Ответ

9   ответов
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
если вы по-прежнему запрашиваете щелчок правой кнопкой мыши, я пока не могу найти решение
это было для powerpoint
и это было для левого щелчка, а не правого щелчка, потому что в PowerPoint есть только щелчок мыши и наведение мыши
0

PowerPoinT (PPT)

Код ниже пытается восстановить следующие свойства оригинальной картинки: - .Left, .Top, .Width, .Height - zOrder - Имя формы - HyperLink / Настройки действий - Анимационные эффекты

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, выберите новое изображение. Это сделано. Используя этот метод, вы можете обойти «Bing Search и One-Drive Window» apos; в версии 2016 года, когда вы хотите изменить изображение.

В коде могут быть (или должны) быть некоторые ошибки или чего-то не хватает. Я был бы признателен, если бы кто-то или любой модератор исправил эти ошибки в коде. Но в основном я обнаружил, что все работает нормально. Кроме того, я признаю, что есть еще больше свойств исходной фигуры, которые необходимо восстановить - например, свойство линии фигуры, прозрачность, формат изображения и так далее. Я думаю, что это может быть началом для людей, которые хотят скопировать эти СЛИШКОМ МНОГО свойства формы. Надеюсь, это кому-нибудь пригодится.

8

change источник изображения, вам нужно удалить старую и вставить новую

Вот начало

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
Либо запишите свойства старого изображения в переменные перед его удалением, либо оставьте изображение на месте, пока вы копируете его свойства, запишите его z-порядок, затем удалите его и переместите новое изображение обратно в z-порядок исходного изображения
1 поскольку я не могу найти какой-либо код для изменения изображения :( поэтому я думаю, что это единственный способ, но это не имеет никакого смысла, Microsoft :(
Привет Крис, я тоже думал об этом, однако, когда речь заходит о Shadow, Contrast, Brightness, я даже не могу изменить их свойства, это приведет к ошибкам, таким как копирование свойства из старого изображения в новое. Но я могу программно наподобие Shadow.Blur = 30, но если я скажу NewPic.Shadow.Blur = OldPic.Shadow.Blur, я получу ошибки. PlayKid
1

нта изображения, который вы хотите изменить.

set the .visible to false change the picture set the .visilbe to true

это сработало для меня.

0

е и положил их друг на друга. Затем вы программно устанавливаете все изображения .visible = false, кроме того, которое хотите показать.

1

что я делаю, это кладу оба изображения друг на друга, и назначаю макрос ниже для обоих изображений. Очевидно, что я назвал изображения «lighton». и & quot; lightoff & quot ;, поэтому обязательно измените это на свои изображения.

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
2
'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
0

потому что у меня есть несколько листов с переменным номером, и на каждом листе есть изображения, поэтому файл получился бы огромным, если, скажем, на 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, как в моей анимации), а дублирование листа только дублирует активное изображение, поэтому анимация без проблем продолжается со следующим изображением.

9

UserPicture метод применительно к форме прямоугольника. Однако вам необходимо соответствующим образом изменить размер прямоугольника, если вы хотите сохранить исходное соотношение сторон изображения, так как изображение будет принимать размеры прямоугольника.

В качестве примера:

 ActivePresentation.Slides(2).Shapes(shapeId).Fill.UserPicture ("C:\image.png")
Технически это добавляет заливку к фигуре, и заливка не будет видимой, если ваша фигура является изображением.
Хорошо работал в Excel

Похожие вопросы