Sub InsertImage()
    Dim FolderPath, objFSO, Folder, ImagePath, image
    Const END_OF_STORY = 6
    Const MOVE_SELECTION = 0
    FolderPath = Select_Folder_From_Prompt
    If InStr(FolderPath, "EMPTY") = 0 Then
        Set objFSO = CreateObject("Scripting.Filesystemobject")
        Set Folder = objFSO.GetFolder(FolderPath)
        For Each image In Folder.Files
            ImagePath = image.Path
            If CheckiImageExtension(ImagePath) = True Then
                'Insert the images into the word document
                Application.Selection.EndKey END_OF_STORY, MOVE_SELECTION
                Application.Selection.InlineShapes.AddPicture (ImagePath)
                Application.Selection.InsertBreak  'Insert a pagebreak
            End If
        Next
    End If
End Sub


Function Select_Folder_From_Prompt() As String
     
    Dim fd, bMultiSelect, CONST_MODEL_DIRECTORY
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
     
    With fd
        .Title = "Select a folder"
        .AllowMultiSelect = bMultiSelect
        .InitialFileName = CONST_MODEL_DIRECTORY
        .Filters.Clear
         
         'Use the Show method to display the File Picker dialog box and return the user's action.
         'The user pressed the action button.
        If .Show = -1 Then
            Select_Folder_From_Prompt = .SelectedItems(1) & "\"
        Else
            Select_Folder_From_Prompt = "EMPTY"
        End If
    End With
     
End Function


Function CheckiImageExtension(ImagePath)
    Dim varArray        ' An array contains iamge file extensions.
    Dim varEach         ' Each iamge file extension.
    Dim blnIsPptFile    ' Whether the file extension is image file extension.
    Dim objFSO, file, FileExtension
    Set objFSO = CreateObject("Scripting.Filesystemobject")
    Set file = objFSO.GetFile(ImagePath)
    FileExtension = file.Name
    blnIsPptFile = False
    If FileExtension <> "" Then
        varArray = Array(".emf", ".wmf", ".jpg", ".jpeg", ".jfif", ".png", ".jpe", ".bmp", ".dib", ".rle", ".gif", ".emz", ".wmz", ".pcz", ".tif", ".tiff", ".eps", ".pct", ".pict", ".wpg")
        For Each varEach In varArray
            If InStrRev(UCase(FileExtension), UCase(varEach)) <> 0 Then
                blnIsPptFile = True
                Exit For
            End If
        Next
    End If
    CheckiImageExtension = blnIsPptFile
    Set objFSO = Nothing
    Set file = Nothing
End Function