If the images are as described in my last post, the following should work (provided only those files are in the folder as I have not added any error trapping for incorrect file sequences).
Option Explicit
Sub InsertImages2()
'Graham Mayor
Const strFile As String = "C:\Path\ImageTemplate.docx" 'The template
Dim oBM As Bookmark
Dim oDoc As Document
Dim strPath As String, strImage As String
Dim strId As String
Dim vImage As Variant
Dim i As Long
strPath = BrowseForFolder("Select the folder containing the graphics files")
If Not strPath = "" Then
strImage = Dir$(strPath & "*.*")
i = 0
While Len(strImage) <> 0
On Error GoTo err_Handler
If i Mod 4 = 0 Then
Set oDoc = Documents.Add(strFile)
End If
strId = Left(strImage, Len(strImage) - 4)
vImage = Split(strId, "_")
'Msgbox strImage
Select Case vImage(2)
Case Is = "FOTO"
ImageToBM "bm1", strPath & strImage
Case Is = "PHOTO"
ImageToBM "bm2", strPath & strImage
Case Is = "ST"
ImageToBM "bm3", strPath & strImage
Case Is = "DS"
ImageToBM "bm4", strPath & strImage
End Select
i = i + 1
strImage = Dir$()
Wend
End If
lbl_Exit:
Set oDoc = Nothing
Set oBM = Nothing
Exit Sub
err_Handler:
GoTo lbl_Exit
End Sub
Function BrowseForFolder(Optional strTitle As String) As String
'Graham Mayor
'strTitle is the title of the dialog box
Dim fDialog As FileDialog
On Error GoTo err_Handler
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
With fDialog
.Title = strTitle
.AllowMultiSelect = False
.InitialView = msoFileDialogViewList
If .Show <> -1 Then GoTo err_Handler:
BrowseForFolder = fDialog.SelectedItems.Item(1) & Chr(92)
End With
lbl_Exit:
Exit Function
err_Handler:
BrowseForFolder = vbNullString
Resume lbl_Exit
End Function
Private Sub ImageToBM(strBMName As String, strValue As String)
'Graham Mayor
Dim oRng As Range
With ActiveDocument
On Error GoTo lbl_Exit
Set oRng = .Bookmarks(strBMName).Range
oRng.InlineShapes.AddPicture _
Filename:=strValue, LinkToFile:=False, _
SaveWithDocument:=True
oRng.End = oRng.End + 2
oRng.Bookmarks.Add strBMName
End With
lbl_Exit:
Set oRng = Nothing
Exit Sub
End Sub