Word VBA Script: adding images to a word document in all sub folders

Question

I am trying to create a VBA script that will do the following:

1. Enter a subfolder (name of folder: 101)
2. Open the word document
3. Add image to the document were I have placed the “bookmarks” (images are in the same folder)
4. Save the document
5. Close the document
6. Re-enter the next subfolder (name of folder: 102) and re-doing the process until all folder are done

Folder structure as follows:

Root folder: My Pictures

----
Subfolder: 101
----
File: test_document.docx
File: test_document – Copy.docx
File: test_document - Copy - Copy.docx
File: 6_Month_Assessment.jpg
File: portfolio.jpg
File: slide_deck.jpg

----
Subfolder:**102
----
File: test_document.docx
File: 6_Month_Assessment.jpg
File: portfolio.jpg
File: slide_deck.jpg

Etc. (up to 201 Subfolder)

Please see bellow some code I have found on this site (URL: VBA Macro replace text in Word file in all sub folders ) and have tried to modify the code to meet my needs when compiling the code nothing happens. Please note I am a novice when come to VBA Scripting.

   Sub DoLangesNow()
Dim file
Dim path As String
Dim strFolder As String
Dim strSubFolder As String
Dim strFile As String
Dim colSubFolders As New Collection
Dim varItem As Variant

     strFolder = "C:\My Pictures\"

     ' Loop through the subfolders and fill Collection object
     strSubFolder = Dir(strFolder & "*", vbDirectory)
     Do While Not strSubFolder = ""
         Select Case strSubFolder
             Case ".", ".."
                 ' Current folder or parent folder - ignore
             Case Else
                 ' Add to collection
                 colSubFolders.Add Item:=strSubFolder, Key:=strSubFolder
         End Select
         ' On to the next one
         strSubFolder = Dir
     Loop
     ' Loop through the collection
     For Each varItem In colSubFolders
         ' Loop through word docs in subfolder
         'YOU MUST EDIT THIS if you want to change the files extension
        strFile = Dir(strFolder & varItem & "\" & "*.docx")
         Do While strFile <> ""
         Set file = Documents.Open(FileName:=strFolder & _
                 varItem & "\" & strFile)

  ActiveDocument.Bookmarks("TEST").Range.InlineShapes.AddPicture FileName:=ThisDocument.path & "\Thrombolysis.jpg"
  ActiveDocument.Bookmarks("TEST2").Range.InlineShapes.AddPicture FileName:=ThisDocument.path & "\slide_deck.jpg"

' Saves the file
ActiveDocument.Save
ActiveDocument.Close
' set file to next in Dir
strFile = Dir
         Loop
     Next varItem
 End Sub

Update issue (16/09/14 : 17:59) I have started to receive saying the following: "Run-time error '5152"

Answer 1

I have fixed the issue by change the following lines of code:

Original code line:

ActiveDocument.Bookmarks("TEST").Range.InlineShapes.AddPicture FileName:=ThisDocument.path & "\images\Thrombolysis.jpg" ActiveDocument.Bookmarks("TEST2").Range.InlineShapes.AddPicture FileName:=ThisDocument.path & "\images\slide_deck.jpg"

New code:

ActiveDocument.Bookmarks("TEST").Range.InlineShapes.AddPicture FileName:=ActiveDocument.path & "\Thrombolysis.jpg" ActiveDocument.Bookmarks("TEST2").Range.InlineShapes.AddPicture FileName:=ActiveDocument.path & "\slide_deck.jpg"