Viele Bilder in Tabelle einfügen

Sub BilderImportieren()

    Dim selectedFolder As String

    Dim objFSO As Object

    Dim objFolder As Object

    Dim objFile As Object

    Dim ws As Worksheet

    Dim imgLeft As Integer

    Dim imgTop As Integer

    Dim imgWidth As Double

    Dim imgHeight As Double

    Dim imgCount As Integer

    Dim pic As Picture

    Dim startRow As Integer

    Dim rowOffset As Integer



    With Application.FileDialog(msoFileDialogFolderPicker)

        .Title = "Ordner mit Bildern auswählen"

        If .Show = -1 Then

            selectedFolder = .SelectedItems(1)

        Else

            Exit Sub

        End If

    End With



    On Error Resume Next

    Set ws = Worksheets("Bilder")

    On Error GoTo 0

    If ws Is Nothing Then

        Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))

        ws.Name = "Bilder"

    End If



    imgLeft = 1 

    imgTop = 1 

    imgWidth = 400

    imgHeight = 300

    imgCount = 0

    startRow = 1 

    rowOffset = 22 ' Zeilenabstand

    columnOffset = 8 ' Spaltenabstand



    Set objFSO = CreateObject("Scripting.FileSystemObject")

    If Not objFSO.FolderExists(selectedFolder) Then

        MsgBox "Der ausgewählte Ordner wurde nicht gefunden.", vbExclamation

        Exit Sub

    End If



    Set objFolder = objFSO.GetFolder(selectedFolder)



    For Each objFile In objFolder.Files

        If InStr(1, LCase(objFile.Name), ".jpg") > 0 Or InStr(1, LCase(objFile.Name), ".jpeg") > 0 Or InStr(1, LCase(objFile.Name), ".png") > 0 Then

            ' Füge das Bild in die Excel-Tabelle ein

            Set pic = ws.Pictures.Insert(objFile.Path)

            With pic

                .Left = ws.Cells(imgTop, imgLeft).Left

                .Top = ws.Cells(imgTop, imgLeft).Top

                .ShapeRange.LockAspectRatio = msoTrue

                .ShapeRange.Width = imgWidth

                .ShapeRange.Height = imgHeight

            End With

            

            imgCount = imgCount + 1

            ' Koordinaten für nächstes bild

            If imgCount Mod 2 = 0 Then

               startRow = startRow + rowOffset

                imgTop = startRow

                imgLeft = 1

                

            Else

                imgLeft = columnOffset

            End If

            

            If imgCount Mod 4 = 0 Then

                ws.HPageBreaks.Add Before:=ws.Cells(startRow, 8)

                ws.VPageBreaks.Add Before:=ws.Cells(startRow, 14)

            End If

            

            

        End If

    Next objFile

End Sub