truk
06-21-2021, 01:58 AM
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-AwVjHdc70aX62aDya82xbgABWvsfdxU/view?usp=sharing
(if I should handle this differently, please give me feedback.)
Original post:
https://www.excelforum.com/word-programming-vba-macros/1343838-help-with-macro-to-replace-shape-userpicture.html#post5490823
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-AwVjHdc70aX62aDya82xbgABWvsfdxU/view?usp=sharing
(if I should handle this differently, please give me feedback.)
Original post:
https://www.excelforum.com/word-programming-vba-macros/1343838-help-with-macro-to-replace-shape-userpicture.html#post5490823