Consulting

Results 1 to 3 of 3

Thread: Import image file to Shape Fill UserPicture works in some files, not in others.

  1. #1
    VBAX Regular
    Joined
    Mar 2021
    Posts
    6
    Location

    Import image file to Shape Fill UserPicture works in some files, not in others.

    On office 365 and office 365 for Mac.
    Cross post due to not getting a good answer.

    I need a word document to import an image file, and use it to update a shape object's fill. I also need to be able to batch these updates, so I wrote the following that reads a JSON text file to control which image objects are updated, and which image files are selected.

    It works for the SECOND IMAGE only. I can't work out why. This is in the "ImageImport.docm" file


    Please note that there are a number of helper functions, as well as a JSON-Parser module, and dictionary class.
    Public Sub AutoImportData()    Dim ImportDict As Object
        Set ImportDict = ParseJson(GetJSONfromTxt)
        Dim fileID As String
        Let fileID = ImportDict("ID")
        Dim isMatchID As Boolean
        Let isMatchID = ImportDict("MatchID")
        
        'log sucess of importing images
        Dim reportStr As String
        reportStr = "Imported " & Date & vbNewLine
        reportStr = reportStr & vbNewLine & MergeImages(ImportDict("ImageMerge"))
        
        Call SaveMergeReport(reportStr)
    End Sub
    
    
    Private Function ReplaceShapeFill(fPath As String, oldShapeName As String) 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
        
        'retrive shape as object, then test if image is 'Shape' or 'InlineShape'
        Dim oShapeOld As Object
        Set oShapeOld = GetShape(oldShapeName)
        If oShapeOld Is Nothing Then
            ReplaceShapeFill = "FAIL - Shape not found"
            Exit Function
        End If
        If Selection.ShapeRange.Count = 1 Then
            Dim shp As Shape
            Set shp = oShapeOld
            With shp.Fill
                .Visible = msoTrue
                .UserPicture fPath
                .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
                .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 - " & Err.Description
    End Function
    If anyone can help me work out this out it would be greatly appreciated.


    COMPLICATIONS
    I made up a second file 'DoesWork', using user input in place of the json, so that the forum could have an easier time testing this.
    BUT THIS FILE WORKS PERFECTLY, and I can't work out why. It calls the same function, with the same code, using the same arguments. I can not work out why it is different.
    Public Sub TestManualSelection()    Dim wd As Document
        Set wd = ThisDocument
        wd.Activate
        '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, oShp.Title)
    End Sub
    
    
    Private Function ReplaceShapeFill(fPath As String, oldShapeName As String) 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)
        If oShapeOld Is Nothing Then
            ReplaceShapeFill = "FAIL - Shape not found"
            Exit Function
        End If
        If Selection.ShapeRange.Count = 1 Then
            Dim shp As Shape
            Set shp = oShapeOld
            With shp.Fill
                .Visible = msoTrue
                .UserPicture fPath
                .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
    So I imported this calling macro "TestManualSelection" in to my first file "ImageImportTest.docm", and in this file it DOESN'T work. Same code. Works in one Doc. Not in the other.

    I'm very confused, and at my wits end.
    If you wonderful people can enlighten me, I would be VERY appreciative.

    I wasn't able to get files to upload direct to the forum, but here is a link to a google drive folder. It has link to a zip of a folder with my files, along with correctly named example images, and a valid JSON textfile.
    https://drive.google.com/file/d/1-Aw...ew?usp=sharing
    (if I should handle this differently, please give me feedback.)


    Original post:
    https://www.excelforum.com/word-prog...ml#post5490823
    Last edited by truk; 06-21-2021 at 02:04 AM. Reason: bad copy paste needed correcting

  2. #2
    VBAX Regular
    Joined
    Mar 2021
    Posts
    6
    Location
    I've now worked up that the code fails on shapes of type 13 (msoShapeType = msoPicture), but succeeds on shapes of type 1 (msoShapeType = msoAutoshape)

    Is there a way to convert shapes to a a different type, or do I just need to replace all my images?

  3. #3
    VBAX Regular
    Joined
    Mar 2021
    Posts
    6
    Location
    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


Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •