Help with Macro to replace Shape UserPicture.

I wrote the following macro to update images in Shapes in Word.

The idea was to pass a reference to the shape object and change the Shape.Fill.UserPicture to a given image fill. I was using .PNG files.

It runs, and returns "SUCCESS" with no errors, but the image is not updated. I can't work out why.
Any help would be greatly appreciated.

Note that I commented out the the error catch.

Private Function ReplaceShapeFill(imgFileName As String, ByRef fPath As String, oldShapeName As String, _
                                    useDestAspect As Boolean, aspect As Double) As String
    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:
    ReplaceShapeFill = "FAIL"
End Function

Public 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

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.

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

Since you're running this from Excel, instead of employing ThisDocument, which isn't where your code will reside, you should not only instantiate Word(e.g. Dim objWd as Object), but also explicitly tell objWd what document to work with - whether by opening that document directly or looping through the open ones to test which (if any) is the document you want, then set a reference to that document (e.g. Set objDoc = objWd.Documents(i)) then pass objDoc to your functions. For example:

Sub Demo()
Dim ObjWd As Object, ObjDoc As Object, StrDocNm As String
Dim bStrt As Boolean, bFound As Boolean, StrNm As String
StrNm = Trim(InputBox(prompt:=promptStr, Default:=defaultStr, Title:="Set name for selected Shape"))
If StrNm = "" Then Exit Sub
'Check whether the document exists
StrDocNm = "C:\Users\" & Environ("Username") & "\Documents\Document Name.doc"
If Dir(StrDocNm) = "" Then
  MsgBox "Cannot find the designated document: " & StrDocNm, vbExclamation
  Exit Sub
End If
' Test whether Word is already running.
On Error Resume Next
bStrt = False ' Flag to record if we start Word, so we can close it later.
Set ObjWd = GetObject(, "Word.Application")
'Start Word if it isn't running
If ObjWd Is Nothing Then
  Set ObjWd = CreateObject("Word.Application")
  If ObjWd Is Nothing Then
    MsgBox "Can't start Word.", vbExclamation
    Exit Sub
  End If
  ' Record that we've started Word, so we can terminate it later.
  bStrt = True
End If
On Error GoTo 0
'Check if the document is open.
bFound = False
With ObjWd
  'Hide our Word session
  If bStrt = True Then .Visible = False
  For Each ObjDoc In .Documents
    If ObjDoc.FullName = StrDocNm Then ' We already have it open
      bFound = True
      Exit For
    End If
  Next
  ' If not open by the current user.
  If bFound = False Then
    ' Check if another user has it open.
    If IsFileLocked(StrDocNm) = True Then
      ' Report and exit if true
      MsgBox "The Word document is in use." & vbCr & "Please try again later.", vbExclamation, "File in use"
      If bStrt = True Then .Quit
      Exit Sub
    End If
    ' The file is available, so open it.
    Set ObjDoc = .Documents.Open(Filename:=StrDocNm)
    If ObjDoc Is Nothing Then
      MsgBox "Cannot open:" & vbCr & StrDocNm, vbExclamation
      If bStrt = True Then .Quit
      Exit Sub
    End If
  End If
  With ObjDoc
    'Only now can we can process the document!!!
    'Your functions can now be called
     MsgBox CountShapeTitles(ObjDoc, StrNm)
    .Save
    'Close the document if we opened it
    If bFound = False Then .Close
  End With
  If bStrt = True Then .Quit
End With
End Sub

Function IsFileLocked(strFileName As String) As Boolean
  On Error Resume Next
  Open strFileName For Binary Access Read Write Lock Read Write As #1
  Close #1
  IsFileLocked = Err.Number
  Err.Clear
End Function

Private Function CountShapeTitles(ObjDoc As Object, StrNm As String) As Long
Dim i As Long, ObjShp As Object: i = 0
With ObjDoc
  For Each ObjShp In .Shapes
    If ObjShp.Title = StrNm Then i = i + 1
  Next
  For Each ObjShp In .InlineShapes
    If ObjShp.Title = testName Then i = i + 1
  Next
End With
CountShapeTitles = i
End Function

Personally, though, I'd use early binding as it's much faster than late binding.

I am NOT running the code from excel. I merely mentioned that some of the DATA passed to the function happened to originate in Excel. But in this case, I am restricted that the image update MUST be run from word.
This detail is not part of the problem I was trying to address in the OP. It was just the reason I had to give you a different driver macro, that didn't assume a number of prior operations to ensure matching filenames and shape titles.


As I said before, I AM running the code from the Word document itself.
I AM using ThisDocument to refer to tell the application which document to work with. If you look at my code, the function I am actually asking about (Private Function ReplaceShapeFill) consistently uses ThisDocument.

I am not dimming shape as an Object for the sake of early or late binding. I am using Object because it is compatible with both ShapeRange objects and InlineShapes objects. I can not know in advance which type I will need to work with.

So if you have any suggestions on why the first function I posted filled to replace the shape fills, but the second one succeeded, that would be helpful.
Thanks

Originally Posted by truk2

I am NOT running the code from excel. I merely mentioned that some of the DATA passed to the function happened to originate in Excel.

Well, what do you suppose one might understand from:

the macro I was using ran the updates via a text list generated in an excel doc that I couldn't share here.

Why even mention Excel if it's not relevant?

Originally Posted by truk2

As I said before, I AM running the code from the Word document itself.

You made no such statement in your previous posts.

Originally Posted by truk2

I am using Object because it is compatible with both ShapeRange objects and InlineShapes objects. I can not know in advance which type I will need to work with.

Not knowing beforehand is irrelevant, since you loop through both kinds anyway.

Using Object references makes no sense at all if it's being run entirely within Word. In any event, you have:

Dim ilShp As InlineShape
Dim shp As Shape
Dim oShp As Object

@Macropod.

I apologise as this got a little adversarial. I'm finding it hard, as you've been fairly consistently ignoring either the context of my question (Why doesn’t my function work?), , or the function of my code.

I'll try to clarify.

Originally Posted by macropod

Well, what do you suppose one might understand from:

Why even mention Excel if it's not relevant?

You demanded to see the driver macro. I tried to explain that the driver macro in this project is not as friendly to testing by other users.
I mentioned that my code works from a textfile listing the images to be processed, and that said text is generated in a separate process in excel. I did not expect you to redesign the whole process to work from excel based on the that passing mention.
To be clear, the process is:
-Objects in word have specific titles.
-images to be imported are stored in same folder as the word document, with specific filenames
-Textfile to control process contains the relevent file names and object titles, and is also stored in same folder.
-Code in word reads the text file, and imports the relevant image files to their target objects.

The process cannot be handled in the excel file due to various logistical issues that. Just accept that as part of the spec.

Not knowing beforehand is irrelevant, since you loop through both kinds anyway.

Using Object references makes no sense at all if it's being run entirely within Word. In any event, you have:

Dim ilShp As InlineShape
Dim shp As Shape
Dim oShp As Object

No.
The important bit here is that GetShape() can return either a SHAPE or an INLINESHAPE as an object.

    Dim oShapeOld As Object
    Set oShapeOld = GetShape(oldShapeName)
    oShapeOld.Select
    If Selection.ShapeRange.Count = 1 Then

It is only after I’ve received that object that it can be tested to see which kind it is, and handle it appropriately.

I hope that clarifies things.
And I must say, while it didn't help with my question at all, I did appreciate the effort of the in depth guide on accessing word from excel.

Next post will include files.

So getting back to the actual issue.

Here I have two files.
The zip file named "DoesNotWork" is an anomynised version of my project.
It contains example image files, a textfile with formated processing instructions, and the .docm word file.

When the "ImportData" sub is called, the text file is parsed and relevant images imported (which does not seem to work)
Note that as this version is run by the text file, if a tester wants to try other images, they must have the same filenames as the ones provided, and be in the same folder as the docm file.


The second file "DoesWork.docm" is a version I made to make it easier for any willing helpers to explore my code.
I did away with the textfile control and specifically named image files.
In this version, when "TestReplaceShapeFill" is called, the user can simply select a shape in the document, and choose an image file that they want to import.
I CANNOT use this set for my project, but this version appears to work just fine. This is very confusing to me, as both versions call the same function, with very similar parameters. I basically changed the way a filename string is handled to suit the new driver macro.

The relevant function in both versions is

'Does Work
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

'Does NOT work
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 expansion 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
    
    'retrive shape as object, then test if image is 'Shape' or 'InlineShape'
    Dim oShapeOld As Object
    Set oShapeOld = GetShape(oldShapeName)
    oShapeOld.Select
    If Selection.ShapeRange.Count = 1 Then
        Dim shp As Shape
        Set shp = oShapeOld
        shp.Select
        shp.Fill.UserPicture fPath & imgFileName
        shp.Fill.Visible = msoTrue
    ElseIf Selection.InlineShapes.Count = 1 Then
        Dim InShp As InlineShape
        Set InShp = oShapeOld
        InShp.Select
        InShp.Fill.UserPicture fPath & imgFileName
        InShp.Fill.Visible = msoTrue
    End If
    ReplaceShapeFill = "SUCCESS"
    Exit Function
    
onErr:
    #If varDebug = 1 Then
        Debug.Assert False
        Resume
    #End If
    ReplaceShapeFill = "FAIL - " & Err.Description
End Function

So could anyone explain why one version works, and the other doesn't?
That would help me a great deal.

Issue has now been reposted here
http://www.vbaexpress.com/forum/show...075#post410075

I finally worked this out.
The shape fill userpicture method for changing an image only seems to work with a shape of type msoAutoshape (type 1). this is the same type of shape you get when you insert a shape from the ribbon by drawing a rectangle.

My document had shapes of type 'msoChart' (type 3), and 'msoPicture' (type 13). I had to go through and replace them with type 1's. After that my code worked perfectly.

I wrote the following function to help with deleting a shape, and replacing with as similarly sized and positioned Autoshape.

Public Function ReplaceAsAutoShape(oShapeOld As Object, wdDoc As Document) As String
'Replace passed Shape or InlineShape object with a placeholde AutoShape (rectangle) object.
'Use because Shape of type msoPicture do not accept replacement fill as .userpicture
On Error GoTo onErr
    
    If oShapeOld Is Nothing Then
        ReplaceAsAutoShape = "FAIL - named shape not found"
        Exit Function
    End If
    
    wdDoc.Activate
    'wdDoc.Select
    

    Dim shp As Shape
    Dim ishp As InlineShape
    Dim ishape As InlineShape
    Dim rng As Range
    Dim lft As Single, tp As Single, w As Single, h As Single
    Dim wrp As Long, rVertPos As Long, rHorzPos As Long
    Dim ttl As String
    Let ttl = oShapeOld.Title
    
    'detect if object is an InlineShape
    oShapeOld.Select
    Dim bInline As Boolean
    Let bInline = Selection.InlineShapes.Count > 0
    If bInline Then
        ReplaceAsAutoShape = "Convert to Shape first"
        Exit Function
    End If
    Dim aRng As Range
    Set aRng = oShapeOld.Anchor
   
    Set shp = Selection.ShapeRange(1)
    Set oShapeOld = Nothing
    Let lft = shp.left
    Let tp = shp.top
    Let w = shp.width
    Let h = shp.height
    Let wrp = shp.WrapFormat.Type
    Let rVertPos = shp.RelativeVerticalPosition
    Let rHorzPos = shp.RelativeHorizontalPosition
    
    Dim oShapeNew As Shape
    Set oShapeNew = wdDoc.Shapes.AddShape(Type:=msoAutoShape, left:=lft, top:=tp, _
                        width:=w, height:=h, Anchor:=aRng)
    shp.Delete
    oShapeNew.WrapFormat.Type = wrp
    oShapeNew.Title = ttl
    oShapeNew.Name = ttl
    oShapeNew.RelativeVerticalPosition = rVertPos
    oShapeNew.RelativeHorizontalPosition = rHorzPos
    oShapeNew.Fill.ForeColor.RGB = RGB(51, 153, 51)
    oShapeNew.left = lft
    oShapeNew.top = tp
    
'    If bInline Then
'        oShapeNew.ConvertToInlineShape
'        oShapeNew.Select
'        Set oShapeNew = Nothing
'        On Error Resume Next
'        Selection.InlineShapes(1).Range = rng
'    End If
    
    ReplaceAsAutoShape = "SUCCESS!"
    Exit Function
    
onErr:
    Debug.Print Err.Number, Err.Description
    #If varDebug = 1 Then
        Debug.Assert False
        'Resume
    #End If
    ReplaceAsAutoShape = "FAIL - " & Err.Description
    
End Function