Help with Macro to replace Shape UserPicture.

Originally Posted by macropod

You've posted two functions, but not the macro that drives them.

That said, as written, your functions will only impact the document containing them, not any other document.

Yes. I wanted it to be restricted to the document the code is in. That was by design due to other factors.

As for a driving macro, the macro I was using ran the updates via a text list generated in an excel doc that I couldn't share here.
I built another driving macro, allowing the user to select a shape and replacement picture, calling the same functions. And frustratingly IT WORKS PERFECTLY.

I'll now go back and try to find a functional difference between the versions.

I've included my code, and a working example file demostrating use with both inline shapes and shapeRange shapes.

Option Explicit

Public Sub TestReplaceShapeFill()
    Dim wd As Document
    Set wd = ThisDocument
    
    'check for selected image Shape
    If Selection.ShapeRange.Count > 1 Or Selection.InlineShapes.Count > 1 Then
        MsgBox "Please select a single shape only."
        Exit Sub
    End If
    Dim ilShp As InlineShape
    Dim shp As Shape
    Dim oShp As Object
    If Selection.ShapeRange.Count = 1 Then
        Set oShp = Selection.ShapeRange(1)
    ElseIf Selection.InlineShapes.Count = 1 Then
        Set oShp = Selection.InlineShapes(1)
    Else
        MsgBox "No shape has been selected"
        Exit Sub
    End If
    
    'set up shape title. Title must be used to deal with later use cases
    Dim defaultStr As String
    Let defaultStr = oShp.Title
    Dim promptStr As String
    If CountShapeTitles(oShp.Title) <= 1 Then
        Let promptStr = "Accept or edit existing Shape title"
    Else
        Let promptStr = "Shape title is not unique. Please enter a unique title"
    End If
    
    Dim bPass As Boolean: bPass = False
    Dim nameStr As String
    Do While bPass <> True
        Let nameStr = InputBox(prompt:=promptStr, Default:=defaultStr, Title:="Set name for selected Shape")
        If nameStr = "" Then 'if user selects "Cancel"
            Exit Sub
        ElseIf CountShapeTitles(nameStr) > 1 Then
            Let promptStr = "Shape title is not unique. Please enter a unique title."
            Let bPass = False
        Else
            Let bPass = True
            oShp.Title = nameStr
        End If
    Loop
    
    'select replacement image
    'https://wellsr.com/vba/2018/excel/vba-select-files-with-msoFileDialogFilePicker/
    Dim strFilePath As String
    With Application.FileDialog(msoFileDialogFilePicker)
        If .Show <> 0 Then
            strFilePath = .SelectedItems(1)
            Debug.Print strFilePath
        End If
    End With
    
    'pass to function
    MsgBox ReplaceShapeFill(strFilePath, strFilePath, oShp.Title, True, 1)
End Sub

Private Function ReplaceShapeFill(imgFileName As String, ByRef fPath As String, oldShapeName As String, _
                                    useDestAspect As Boolean, aspect As Double) As String
    'note 'useDestAspect' and 'aspect' variables are for later expasion once the code is working. Not currently used
    'If Right(fPath, 1) <> Application.PathSeparator Then fPath = fPath & Application.PathSeparator
    On Error GoTo onErr
    Dim wdDoc As Document
    Set wdDoc = ThisDocument
    
    Dim oShapeOld As Object
    Set oShapeOld = GetShape(oldShapeName)
    oShapeOld.Select
    If Selection.ShapeRange.Count = 1 Then
        Dim shp As Shape
        Set shp = oShapeOld
        With shp.Fill
            .Visible = msoTrue
            .UserPicture fPath '& imgFileName
            .TextureTile = msoFalse
            .RotateWithObject = msoTrue
        End With
    ElseIf Selection.InlineShapes.Count = 1 Then
        Dim InShp As InlineShape
        Set InShp = oShapeOld
        With InShp.Fill
            .Visible = msoTrue
            .UserPicture fPath '& imgFileName
            .TextureTile = msoFalse
            .RotateWithObject = msoTrue
        End With
    End If
        
    ReplaceShapeFill = "SUCCESS"
    Exit Function
    
onErr:
    #If varDebug = 1 Then
        Debug.Assert False
        Resume
    #End If

    ReplaceShapeFill = "FAIL"
End Function

Private Function CountShapeTitles(testName As String) As Long
    Dim cnt As Long: cnt = 0
    Dim shp As Shape
    For Each shp In ThisDocument.Shapes
        If shp.Title = testName Then cnt = cnt + 1
    Next shp
    Dim iShp As InlineShape
    For Each iShp In ThisDocument.InlineShapes
        If iShp.Title = testName Then cnt = cnt + 1
    Next iShp
    CountShapeTitles = cnt
End Function

Private Function GetShape(titleStr As String) As Object
    Dim oShp As Object
    For Each oShp In ThisDocument.Shapes
        If oShp.Title = titleStr Then
            Set GetShape = oShp
            Exit Function
        End If
    Next oShp
    For Each oShp In ThisDocument.InlineShapes
        If oShp.Title = titleStr Then
            Set GetShape = oShp
            Exit Function
        End If
    Next oShp
End Function