Image adder based on name criteria

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.

Code:

---

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.

See, for example: https://stackoverflow.com/questions/...pes-addpicture

Thanks.

Code:

---

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?

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

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

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.

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.

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

Code:

---

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

---

This solution solves the question in hand. Thanks.