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.
If anyone can help me work out this out it would be greatly appreciated.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
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.
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.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
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