Image adder based on name criteria

[Programmer_n]

My intention is to add images from a folder to a new document if the name of the images occur within a word document.

So workflow is check the document against a list and emphasize the word and check emphasized words against image name and add those images to a new word document if it matches. the image name could be single word or multiple words.

For example a folder contains two images one named 'galleries' and another named 'document building blocks' document exactly stored within a folder.

' Now I have stored this words in a word file called emphasis.docx and check its occurence within a word document.

The following macro checks the wordlist and italize the word below.

Although this step is insignificant it helps me see what words are being picked.

On the Insert tab, the galleries include items that are designed to coordinate with the overall look of your document. You can use these galleries to insert tables, headers, footers, lists, cover pages, and other document building blocks. When you create pictures, charts, or diagrams, they also coordinate with your current document look.


Sub H_emphasis()

Application.ScreenUpdating = False 'close screen and refresh
Dim StartTime As Double
Dim SecondsElapsed As Double

StartTime = Timer

Dim sCheckDoc As String
Dim docRef As Document
Dim docCurrent As Document
Dim oRng As range
Dim oPara As Paragraph
sCheckDoc = "D:\emphasis.docx"
Set docCurrent = ActiveDocument
Set docRef = Documents.Open(sCheckDoc)
docCurrent.Activate

For Each oPara In docRef.Paragraphs
Set oRng = oPara.range
oRng.End = oRng.End - 1
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Font.Italic = True
.Replacement.Text = "^&"
.Forward = True
.Format = True
.MatchWholeWord = True
.MatchCase = False
.MatchWildcards = False
.Wrap = wdFindContinue
.Text = Trim(oRng.Text)
.Execute Replace:=wdReplaceAll
End With
Next oPara

docRef.Close
docCurrent.Activate

Application.ScreenUpdating = True
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "ITALIZIED emphasis in " & SecondsElapsed & " seconds", vbInformation

End Sub

Now it is the step 2 I am uncertain? How to let word know pick galleries and document building blocks .jpeg and add those images to a new word document from lot of images in a folder. Please help me with this missing link in this work flow.

[macropod]

See, for example: https://stackoverflow.com/questions/60534251/error-when-inserting-image-using-variable-for-selection-inlineshapes-addpicture

[Programmer_n]

Thanks.


Dim sPic As String
Dim sPath As String
sPath = "D:\ReportImages\"
sPic = Dir(sPath & "*.jpg")
Do While sPic <> ""
Selection.InlineShapes.AddPicture _
FileName:=sPath & sPic, _
LinkToFile:=False, SaveWithDocument:=True
sPic = Dir
Selection.TypeParagraph
Selection.TypeParagraph
Loop


By This code i am able to add all those images inside the folder but the intervening link logic

If the italized word in the document matches the image name then add only those images in the document baffles me.

How to arrive at that logic in Word VBA?

[macropod]

The link I posted already shows how to insert images whose names match names found in the document.

[Programmer_n]

Tried using the link but the solution in the link doesn’t work for me.

[macropod]

Well, unless it's a State Secret, perhaps you'd care to explain what the image names in your document consist of. Better still, you might even attach a document to a post with some representative data (delete anything sensitive)? You do this via the paperclip symbol on the 'Go Advanced' tab at the bottom of this screen.

[Programmer_n]

Apologize. I should have been more articulate.

I added the attachments hope it helps.

Snapshot of problem:

List.docx contains words that occur in the output. The code runs compares the content with the words from the list and red fonts the identified words. Image folder contains 4 images of which two contains the same name as red font words which must be added to the document.
Now I am getting four images but expected output is only two images.

Note: I think now you can understand my intention. I am unsure if it is crude way of approaching this problem, If there is any elegant solution please help.

[macropod]

Try running the following macro from your List document - which should be saved in the docm format.

Sub Demo()
Application.ScreenUpdating = False
Dim DocSrc As Document, DocTgt As Document, iShp As InlineShape
Dim FlList As String, FlNm As String, i As Long
Const StrPath As String = "C:\Users\Desktop\Images\"
Set DocSrc = ActiveDocument
With Dialogs(wdDialogFileOpen)
If .Show = False Then Exit Sub
End With
Set DocTgt = ActiveDocument
FlList = DocSrc.Range.Text
With DocTgt.Range.Find
.ClearFormatting
With .Replacement
.ClearFormatting
.Font.ColorIndex = wdRed
.Font.Bold = True
.Font.Italic = True
End With
.MatchWholeWord = True
.MatchCase = False
.Forward = True
.Format = True
.Wrap = wdFindContinue
For i = 0 To UBound(Split(FlList, vbCr)) - 1
FlNm = Split(FlList, vbCr)(i)
If Dir(StrPath & FlNm & ".png") = "" Then
ElseIf (FlNm <> "") Then
.Text = FlNm
.Execute Replace:=wdReplaceAll
If .Found = True Then
With DocTgt
.Range.InsertAfter vbCr
Set iShp = .InlineShapes.AddPicture(StrPath & FlNm & ".png", False, True, .Range.Characters.Last)
With iShp
.LockAspectRatio = True
.Width = InchesToPoints(1.25)
End With
End With
End If
End If
Next
End With
Set iShp = Nothing: Set DocSrc = Nothing: Set DocTgt = Nothing
Application.ScreenUpdating = True
End Sub

[Programmer_n]

This solution solves the question in hand. Thanks.