objInlineShape.ScaleWidth = 100

'--< replace as Thumb.jpg >--

'*pasteBitmap is much smaller

cell_Range.PasteSpecial DataType:=wdPasteBitmap, Placement:=wdInLine

Set objInlineShape = cell_Range.Cells(1).Range.InlineShapes(1)

objInlineShape.ScaleWidth = 100

'--</ replace as Thumb.jpg >--

Option Explicit On

'----< Setup Parameters >----

Const const_Path_Photos_Default As String = "B:\2017"

Const const_int_maxLength_Photos As String = 6

Const Show_Filenames As Boolean = False

Const Show_ImageNr As Boolean = False

Const Add_Empty_Textline As Boolean = False

Private Nr_Table_with_Fotos As Integer

Private intRow_Match As Integer

Private intColumn_Match As Integer

Sub Insert_Photos()

    '-----------------< Fotos_einfuegen() >-----------------

    '*Description:

    '*This macro inserts photos in a table at column 3 and creates for each picture one row

    '*The selection is by a folder dialog and imports the entire folder

    '*Table: it searchs for the first table, which has the text: "foto" in the table-header

    '*Reference Microsoft Scripting Runtime    http://www.codedocu.de/Details?d=1076

    '------< Insert Pictures From Folder >------

    '--< Import-Dialog >--

    Dim objFiledialog As FileDialog

    Set objFiledialog = Application.FileDialog(msoFileDialogFilePicker)

    objFiledialog.AllowMultiSelect = True

    objFiledialog.ButtonName = "Import Images"

    objFiledialog.Filters.Add "Images Photos", "*.jpg;*.png;*.tiff;*.gif"

    objFiledialog.Title = "Fotos auswählen.."

    objFiledialog.InitialView = msoFileDialogViewTiles

    objFiledialog.InitialFileName = const_Path_Photos_Default

    objFiledialog.AllowMultiSelect = True

    If Not objFiledialog.Show() = True Then

        Exit Sub

    End If

    '--< Import-Dialog >--

    '-< check >-

    '</ Ordner ist leer >

    If objFiledialog.SelectedItems().Count = 0 Then

        Exit Sub

    End If

    '</ Ordner ist leer >

    '-</ check >-

    '--< Init Document >--

    '< get Document >

    Dim doc As Document

    Set doc = Application.ActiveDocument

    '</ get Document >

    '< find Table >

    '* Bild in Header

    Nr_Table_with_Fotos = fx_find_Table()

    '</ find Table >

    Dim tblPictures As Table

    Set tblPictures = doc.Tables(Nr_Table_with_Fotos)

    '--</ Init Document >--

    'On Error Resume Next

    '-------< @Loop: Insert all Images >--------

    Dim objInlineShape As InlineShape

    Dim sFilename As String

    Dim iPicture As Integer

    iPicture = 0

    Dim iCol As Integer

    iCol = 0

    Dim iFile As Integer

    For iFile = 1 To objFiledialog.SelectedItems.Count

        '------< Loop.Item  >------

        DoEvents

        '< get selection >

        sFilename = objFiledialog.SelectedItems(iFile)

        '</ get selection >

        '< get Extension >

        Dim sExtension As String

        Dim intLen_Extension As Integer

        intLen_Extension = InStrRev(sFilename, ".", -1, vbBinaryCompare)

        sExtension = Mid(LCase(sFilename), intLen_Extension)

        '</ get Extension >

        If InStr(1, "*.jpg;*.png;*.tiff;*.gif", sExtension) > 0 Then 'JPG-Datei

            '----< IsPhoto >----

            iPicture = iPicture + 1

            Dim iRow As Integer

            iRow = tblPictures.Rows.Count

            iCol = intColumn_Match

            '-< new Row >-

            If iPicture > 1 Then

                Dim new_Row As Row

                    Set new_Row = tblPictures.Rows.Add()

            End If

            '-</ new Row >-

            '< set Cell >

            Dim cell_Range As Range

            Set cell_Range = tblPictures.Cell(iRow + 1, iCol).Range

            cell_Range.Select

            Selection.EndKey

            '</ set Cell >

            '< Title Row >

            'Selection.TypeText Text:=Chr(11)

            '</ Title Row >

            DoEvents

            'refresh Style

            'tblPictures.Style = tblPictures.Style

            '< insert Photo after Bookmark >

            '*SaveWithDocument:= True to save the linked picture with the document. The default value is False.

            '*LinkToFile: True to link the picture to the file from which it was created. False to make the picture an independent copy of the file. The default value is False.

            Set objInlineShape = doc.InlineShapes.AddPicture(FileName:=sFilename, LinkToFile:=False, SaveWithDocument:=True, Range:=cell_Range)

            '</ insert Photo after Bookmark >

            '< scale >

            objInlineShape.LockAspectRatio = msoTrue

            If objInlineShape.Width > objInlineShape.Height Then

                objInlineShape.Width = CentimetersToPoints(const_int_maxLength_Photos)    'in Centimeters

            Else

                objInlineShape.Height = CentimetersToPoints(const_int_maxLength_Photos)    'in Centimeters

            End If

            '</ scale >

            '--< replace as png >--

            '*reduce memory 1 MB to 1kb

            '< cut >

            objInlineShape.Select

            Selection.Cut

            DoEvents

            '</ cut >

            '--< replace as Thumb.jpg >--

            '*pasteBitmap is much smaller

            cell_Range.PasteSpecial DataType:=wdPasteBitmap, Placement:=wdInLine

            Set objInlineShape = cell_Range.Cells(1).Range.InlineShapes(1)

            objInlineShape.ScaleWidth = 100

            '--</ replace as Thumb.jpg >--

            '--< Filename >--

            If Show_Filenames = True Or Show_ImageNr = True Then

                Dim sLabel As String

                sLabel = ""

                If Show_Filenames Then

                    Dim pos As Integer

                    pos = InStrRev(sFilename, "\")

                    If pos < 0 Then

                        pos = InStrRev(sFilename, "/")

                    End If

                    sLabel = Mid(sFilename, pos + 1)

                    sLabel = Replace(sLabel, ".jpg", "", , , vbTextCompare)

                End If

                If Show_ImageNr Then

                    sLabel = iPicture & ": " & sLabel

                End If

                'cell_Range.Select

                Selection.EndKey

                Selection.InsertBreak wdLineBreak

                Selection.TypeText Text:=sLabel

                DoEvents

            End If

            '--< Filename >--

            '< Empty TextLine >

            If Add_Empty_Textline = True Then

                Selection.TypeText Text:=Chr(11)

                DoEvents

            End If

            '</ Empty TextLine >

            If Err.Number <> 0 Then

                MsgBox Err.Description

                Err.Clear

            End If

            '----</ Insert Image  >----

            '----</ IsPhoto >----

        End If

    Next

    '----</ @Loop: all Files >----

    '------</ Insert Pictures From Folder >------

    '-----------------< Fotos_einfuegen() >-----------------

End Sub

Private Function fx_find_Table() As Integer

    '--------< fx_find_Table() >--------

    '< init >

    Dim iTable As Integer

    '</ init >

    '----< @Loop: Tables >----

    For iTable = 1 To Tables.Count

        Dim tbl As Table

        Set tbl = Tables(iTable)

        '--< @Loop: Rows >--

        Dim iRow As Integer

        For iRow = 0 To tbl.Rows.Count - 1

            '--< @Loop: Columns >--

            Dim iColumn As Integer

            For iColumn = 0 To tbl.Columns.Count - 1

                '< Cell >

                Dim varCell As Variant

                Set varCell = tbl.Cell(iRow, iColumn)

                If varCell.Range.Text Like "Bild*" Then

                    '< match >

                    intRow_Match = iRow

                    intColumn_Match = iColumn

                    '< out >

                    fx_find_Table = iTable

                    Exit For

                    '</ out >

                    '</ match >

                End If

                '</ Cell >

            Next

            '--</ @Loop: Columns >--

        Next

        '--</ @Loop: Rows >--

    Next

    '----</ @Loop: Tables >----

    '< out >

    'fx_get_Table =

    '</ out >

    '--------</ fx_find_Table() >--------

End Function