VBA to Replace Picture with Clipboard Copy

[Mike De Salvo]

Looking for a macro to replace a picture with an image copied to the clipboard. I found the following that works in Word.doc; but I need one that will work Excel. Any ideas?

[COLOR=#333333][FONT=Segoe UI]Sub ReplacePictureWithClipboarPicture()[/FONT][/COLOR]
[COLOR=#333333][FONT=Segoe UI]Dim oILS As InlineShape[/FONT][/COLOR]
[COLOR=#333333][FONT=Segoe UI]Dim LngW As Long[/FONT][/COLOR]
[COLOR=#333333][FONT=Segoe UI]If Selection.Type = wdSelectionInlineShape Then[/FONT][/COLOR]
[COLOR=#333333][FONT=Segoe UI]  Set oILS = Selection.InlineShapes(1)[/FONT][/COLOR]
[COLOR=#333333][FONT=Segoe UI]  LngW = oILS.Width[/FONT][/COLOR]
[COLOR=#333333][FONT=Segoe UI]  oILS.Delete[/FONT][/COLOR]
[COLOR=#333333][FONT=Segoe UI]  Selection.Range.Paste[/FONT][/COLOR]
[COLOR=#333333][FONT=Segoe UI]  Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend[/FONT][/COLOR]
[COLOR=#333333][FONT=Segoe UI]  If Selection.Type = wdSelectionInlineShape Then[/FONT][/COLOR]
[COLOR=#333333][FONT=Segoe UI]    Set oILS = Selection.InlineShapes(1)[/FONT][/COLOR]
[COLOR=#333333][FONT=Segoe UI]    With oILS[/FONT][/COLOR]
[COLOR=#333333][FONT=Segoe UI]      .LockAspectRatio = True[/FONT][/COLOR]
[COLOR=#333333][FONT=Segoe UI]      .Width = LngW[/FONT][/COLOR]
[COLOR=#333333][FONT=Segoe UI]    End With[/FONT][/COLOR]
[COLOR=#333333][FONT=Segoe UI]  Else[/FONT][/COLOR]
[COLOR=#333333][FONT=Segoe UI]    ActiveDocument.Undo (3)[/FONT][/COLOR]
[COLOR=#333333][FONT=Segoe UI]    MsgBox "Operation canceled and reversed.  The content of the clipboard was not a inline shape image."[/FONT][/COLOR]
[COLOR=#333333][FONT=Segoe UI]  End If[/FONT][/COLOR]
[COLOR=#333333][FONT=Segoe UI]Else[/FONT][/COLOR]
[COLOR=#333333][FONT=Segoe UI]  MsgBox "Please select the image to replace and try again.  The image must be an inline shape image."[/FONT][/COLOR]
[COLOR=#333333][FONT=Segoe UI]End If[/FONT][/COLOR]
[COLOR=#333333][FONT=Segoe UI]End Sub[/FONT][/COLOR]

 

[Mike De Salvo]

Figured out the code myself. The following code will not only replace a picture, but will:
1.) Check to see if you've selected a picture to replace
2.) Ask if you want to replace picture.
2.) Check to see if the copy on the clipboard is a picture format
3.) Resize the picture to match the lowest side of the picture replaced
4.) Assign the macro itself to the picture so that in the event you want to replace the picture again all you need to do is select it.

Hope this helps someone. The various components of the code seem to be lacking out there on the web.

Sub Replace_Picture()On Error Resume Next
ActiveSheet.Shapes(Application.Caller).Select
If TypeName(Selection) = "Picture" Then
Else
    MsgBox "Please select the image to replace and try again.  The image must be a picture."
    GoTo 20
End If


YesNo = MsgBox("Do you want to replace picture one you've copied to clipboard?", vbYesNo + vbQuestion, "Click on Yes or No")
    Select Case YesNo
        Case vbYes
            GoTo 10
        Case vbNo
            GoTo 20
    End Select


10      With Application
            .ScreenUpdating = False
            .EnableEvents = False
            .DisplayAlerts = False
        End With
Dim Default_Pic As Picture
Dim W_DP As Long
Dim H_CP As Long
Dim Comp_Pic As Picture


Set Default_Pic = Selection
W_DP = Default_Pic.Width
H_DP = Default_Pic.Height


ActiveSheet.Paste
If TypeName(Selection) = "Picture" Then
    Set Comp_Pic = Selection
    With Comp_Pic
        .ShapeRange.LockAspectRatio = msoTrue
        .ShapeRange.Width = W_DP
        .OnAction = "Replace_Picture"
End With
    If Comp_Pic.Height > H_DP Then Comp_Pic.ShapeRange.Width = H_DP


    Default_Pic.Delete
Else:   Selection.Delete
        Default_Pic.Select
End If
        With Application
            .ScreenUpdating = True
            .EnableEvents = True
            .DisplayAlerts = True
        End With
20  End Sub

 

[straleks]

Had to register just to say THANK YOU! Exactly what I needed.

Did some small modifications, so I will post it here in case anybody needs it.
(Also, you need to enable developer tab, go into visual basic, and create a module, and paste this there)

Sub Replace_Picture()
ActiveSheet.Shapes(Application.Caller).Select
If TypeName(Selection) = "Picture" Then
Else
    MsgBox "Please select the image to replace and try again.  The image must be a picture."
    GoTo 20
End If




YesNo = MsgBox("Do you want to replace the picture with one you've copied to the clipboard?", vbYesNo + vbQuestion)
    Select Case YesNo
        Case vbYes
            GoTo 10
        Case vbNo
            GoTo 20
    End Select




10      With Application
            .ScreenUpdating = False
            .EnableEvents = False
            .DisplayAlerts = False
        End With
Dim Default_Pic As Picture
Dim W_DP As Long
Dim H_CP As Long
Dim Comp_Pic As Picture




Set Default_Pic = Selection
'W_DP = Default_Pic.Width
'H_DP = Default_Pic.Height
'MsgBox (W_DP)
'Use predefined values for width/height, so if will fit perfectly on a A3 page
W_DP = 1050
H_DP = 700




ActiveSheet.Paste
If TypeName(Selection) = "Picture" Then
    Set Comp_Pic = Selection
    With Comp_Pic
        .ShapeRange.LockAspectRatio = msoTrue
        .ShapeRange.Width = W_DP
        .OnAction = "Replace_Picture"
    End With
    If Comp_Pic.Height > H_DP Then Comp_Pic.ShapeRange.Height = H_DP
    
'send to back, so it will be behind text boxes
    Selection.ShapeRange.ZOrder msoSendToBack
'align to the top right edge of the page
    Comp_Pic.Left = W_DP - Comp_Pic.ShapeRange.Width
    Comp_Pic.Top = 0
    Default_Pic.Delete
    


Else:   Selection.Delete
        Default_Pic.Select
End If
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
End With
20
End Sub