web-dev-qa-db-fra.com

Utiliser VBA pour changer d'image

J'essaie d'utiliser VBA pour automatiser la fonction de changement d'image lorsque vous cliquez avec le bouton droit de la souris sur une forme dans Excel/Word/PowerPoint.

Cependant, je ne suis pas en mesure de trouver une référence, pouvez-vous aider?

imagevbams-officeexcel-2007
9
PlayKid

Vous pouvez modifier la source d'une image à l'aide de la méthode UserPicture telle qu'elle est appliquée à une forme de rectangle. Cependant, vous devrez redimensionner le rectangle en conséquence si vous souhaitez conserver le rapport de format d'origine de l'image, car celle-ci prendra les dimensions du rectangle.

Par exemple:

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

Pour autant que je sache, vous ne pouvez pas changer la source d'une image, vous devez supprimer l'ancienne et en insérer une nouvelle.

Voici un début

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
8
chris neilsen
'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
2
ali-mousavi

ce que je fais est de poser les deux images l'une sur l'autre et d'attribuer la macro ci-dessous aux deux images. Évidemment, j'ai nommé les images "lighton" et "lightoff", alors assurez-vous de changer cela en vos images.

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
1
user5847966

Dans Word 2010 VBA, il est utile de modifier l'option .visible pour l'élément d'image que vous souhaitez modifier.

  1. mettre le .visible à false
  2. changer l'image
  3. définir le .visilbe à true

cela a fonctionné pour moi.

1
user5326408

Par le passé, j'ai créé plusieurs contrôles d'image sur le formulaire et les a superposés. Ensuite, vous définissez par programme toutes les images .visible = false sauf celle que vous souhaitez afficher. 

0
user4024676

Je travaille dans Excel et VBA. Je ne peux pas superposer d'images parce que j'ai plusieurs feuilles d'un nombre variable et que chaque feuille contient les images, le fichier deviendrait énorme si, par exemple, 20 feuilles contenaient les 5 images que je voulais animer. 

J'ai donc utilisé une combinaison de ces astuces énumérées ci-dessous: 1) J'ai inséré une forme RECTANGLE à l'emplacement et à la taille que je voulais:

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) Maintenant, pour animer (changer) l'image, il me suffit de changer le Shape.Fill.UserPicture:

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

J'ai donc atteint mon objectif, qui consiste à n'avoir qu'une image par feuille (et non 5 comme dans mon animation). La duplication de la feuille ne fait que dupliquer l'image active;.

0
user3422093

j'utilise ce code:

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
0
Yeera

J'ai essayé d'imiter la fonction originale de 'Change Picture' avec VBA dans PowerPoint (PPT)

Le code ci-dessous tente de récupérer les propriétés suivantes de l'image d'origine: - .Gauche, .Top, .Width, .Hauteur - zOrder - Nom de la forme - Paramètres HyperLink/Action - Effets d'animation

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

Comment utiliser: Je vous suggère d'ajouter cette macro dans la liste de la barre d'outils Accès rapide. (Option Atteindre ou clic droit sur le menu du ruban)) Sélectionnez d’abord une image sur la diapositive que vous souhaitez modifier. Ensuite, si la fenêtre FileDialog s’ouvre, choisissez une nouvelle image. C'est fait. En utilisant cette méthode, vous pouvez ignorer la "fenêtre Bing Search et One-Drive" de la version 2016 lorsque vous souhaitez modifier une image.

Dans le code, il pourrait (ou devrait) y avoir des erreurs ou quelque chose qui manque. Je vous en serais reconnaissant si quelqu'un ou un modérateur corrige ces erreurs dans le code. cela fonctionne bien. En outre, j’admets qu’il existe encore d’autres propriétés de la forme originale à récupérer - comme la propriété de ligne de la forme, la transparence, le format d’image, etc. Je pense que cela peut être un début pour les personnes qui veulent dupliquer ces propriétés TROP D'UN TYPE. J'espère que cela sera utile à quelqu'un.

0
konahn