Sub PasteAndAlignItems()

    Dim totalPages As Integer

    Dim currentPage As Integer

    Dim startPosition As Range

    totalPages = ActiveDocument.BuiltInDocumentProperties(wdPropertyPages)

    Set startPosition = Selection.Range

    For currentPage = 1 To totalPages

        startPosition.Select

        Selection.PasteSpecial Placement:=wdInLine

        Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Count:=1

    Next currentPage

End Sub

Sub FillShapesWithPictures()
    Dim dialog As FileDialog
    Dim selectedFiles As FileDialogSelectedItems
    Dim i As Integer
    
    Set dialog = Application.FileDialog(msoFileDialogFilePicker)
    dialog.Title = "Select multiple JPG files"
    dialog.Filters.Add "JPEG files", "*.jpg; *.jpeg", 1
    
    If dialog.Show = -1 Then
        Set selectedFiles = dialog.SelectedItems
        
        i = 1
        For Each shape In ActiveDocument.Shapes
            If i <= selectedFiles.Count Then
                shape.Fill.UserPicture selectedFiles(i)
                i = i + 1
            Else
                Exit For
            End If
        Next shape
    End If
End Sub

Sub ImportFolderOfImages()
  Dim objFSO As Object, objFolder As Object, objFile As Object, sPath As String
  Dim aDoc As Document, aPict As InlineShape, iMaxSize As Integer, dblRatio As Double
  
  Set aDoc = ActiveDocument
  iMaxSize = CentimetersToPoints(6)                          'Set your maximum width
  sPath = SelectFolder                                       'Prompt user to select a path
  If Len(sPath) = 0 Then Exit Sub                            'Exit if folder not selected
  Set objFSO = CreateObject("Scripting.FileSystemObject")    'Create late bound instance FileSystemObject
  Set objFolder = objFSO.GetFolder(sPath)                    'Get the folder object
  
  'loop through each file in the directory and import any graphics
  For Each objFile In objFolder.Files
    Debug.Print objFile.Name, objFile.Type
    On Error GoTo SkipFails   'will fail if not importable graphic format
    Set aPict = aDoc.Paragraphs.Last.Range.InlineShapes.AddPicture(FileName:=objFile.Path)
    If Not aPict Is Nothing Then
      aPict.LockAspectRatio = msoTrue
      If aPict.Width > aPict.Height Then
        aPict.Width = iMaxSize
      Else
        aPict.Height = iMaxSize
      End If
      aPict.AlternativeText = objFile.Name
      aDoc.Range.InsertAfter vbCr
    End If
SkipFails:
  Next objFile
End Sub

Function SelectFolder(Optional sTitle As String = "Choose a Folder:", Optional sInitialPath As String) As String
  With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    .Title = sTitle
    .InitialFileName = sInitialPath
    .Show
    SelectFolder = .SelectedItems(1)
  End With
End Function