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