Bilder untereinander einfügen

Frage: In einem Ordner (optional mit Unterordner) sind viele Bilddateien (jpg). Diese sollen ab A1 untereinander eingefügt werden. Die Zeilenhöhe ist schon angepasst. Wie geht das?

Option Explicit
Dim objPicture As Picture
Dim objFSO As Object
Public Sub Main()
    Dim shpShape As Shape
    Dim strPath As String
    On Error GoTo Fin
    strPath = "C:\Temp\Test\"
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    Application.ScreenUpdating = False
    With ThisWorkbook.Worksheets(1)
        For Each shpShape In .Shapes
            If shpShape.TopLeftCell.Column = 1 Then shpShape.Delete
        Next shpShape
    End With
    SearchFiles strPath, "*.jpg", False ' ohne Unterordner
    'SearchFiles strPath, "*.jpg", True ' mit Unterordner
Fin:
    Set objPicture = Nothing
    Set objFSO = Nothing
    Application.ScreenUpdating = True
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
Private Sub SearchFiles(strFolder As String, strFileName As String, _
    Optional blnTMP As Boolean = False)
    Dim objFolder As Object
    Dim objFile As Object
    Dim lngRow As Long
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    For Each objFile In objFSO.GetFolder(strFolder).Files
        If objFile.Name Like strFileName Then
            With ThisWorkbook.Worksheets(1)
                With .Cells(lngRow + 1, 1)
                    Set objPicture = .Parent.Pictures.Insert(objFile.Path)
                    objPicture.Top = .Top
                    objPicture.Left = .Left
                    objPicture.Height = .Height
                    objPicture.Width = .Width
                End With
                lngRow = lngRow + 1
            End With
        End If
    Next objFile
    If blnTMP = True Then
        For Each objFolder In objFSO.GetFolder(strFolder).Subfolders
            SearchFiles strFolder & "\" & objFolder.Name, strFileName, blnTMP
        Next objFolder
    End If
End Sub

Sind schon Bilder eingfügt und Du möchtest die Zeilenhöhe an die Bilder anpassen, dann so (beachte den Hinweis von Nepumuk im Link unten):

Option Explicit
Sub Main()
    Dim shpShape
    On Error GoTo Fin
    Application.ScreenUpdating = False
    For Each shpShape In Tabelle1.Shapes
        'If shpShape.Type = msoPicture Then
        ' in Excel 2010
        If shpShape.Type = msoLinkedPicture Then
            Rows(shpShape.TopLeftCell.Row).RowHeight = shpShape.Height
        End If
    Next shpShape
Fin:
    Application.ScreenUpdating = True
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

Hinweis Nepumuk...

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...