Microsoft Excel

Herbers Excel/VBA-Archiv

In Masse Bilder importieren

Betrifft: In Masse Bilder importieren von: Dennis
Geschrieben am: 28.09.2020 15:57:46

Hallo zusammen,


besteht irgendwie eine Möglichkeit, habe den Dateipfad in einer Zelle stehen, die Bilder automatisch (wenn möglich) in Masse zu importieren?

Betrifft: AW: In Masse Bilder importieren
von: Nepumuk
Geschrieben am: 28.09.2020 16:25:34

Hallo Dennis,

was soll ich mir unter "Masse" vorstellen?

Gruß
Nepumuk

Betrifft: AW: In Masse Bilder importieren
von: Dennis
Geschrieben am: 28.09.2020 19:52:28

Es handelt sich um ca. 800 Zeilen also 800 Bilder aus einem Ordner

Betrifft: AW: In Masse Bilder importieren
von: Nepumuk
Geschrieben am: 28.09.2020 20:30:10

Hallo Dennis,

ich bin jetzt mal davon ausgegangen dass sich der Ordnerpfad in Zelle A1 befindet und das alles .jpg - Bilder sind.

Option Explicit

Public Sub InsertPictures()
    
    Dim strPath As String, strFileName As String
    Dim sngTop As Single
    Dim objShape As Shape
    
    strPath = Cells(1, 1).Text
    If Right$(strPath, 1) <> "\" Then strPath = strPath & "\"
    
    strFileName = Dir$(strPath & "*.jpg")
    
    Do Until strFileName = vbNullString
        
        Set objShape = Tabelle1.Shapes.AddPicture(Filename:=strPath & strFileName, LinkToFile:=msoFalse, _
            SaveWithDocument:=msoTrue, Left:=0, Top:=sngTop, Width:=-1, Height:=-1)
        
        sngTop = sngTop + objShape.Height
        
        strFileName = Dir$
        
    Loop
    
    Set objShape = Nothing
    
End Sub

Gruß
Nepumuk

Betrifft: AW: In Masse Bilder importieren
von: Dennis
Geschrieben am: 28.09.2020 21:04:24

Ab A2-A717 sind die Pfade der Bilder... Was muss ich da ändern?

Betrifft: AW: In Masse Bilder importieren
von: Nepumuk
Geschrieben am: 29.09.2020 09:56:10

Hallo Dennis,

teste mal:

Option Explicit

Public Sub InsertPictures()
    
    Dim strPath As String, strFileName As String
    Dim lngRow As Long
    Dim objShape As Shape
    
    For lngRow = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        
        With Cells(lngRow, 1)
            
            If Dir$(.Text) <> vbNullString Then
                
                Set objShape = ActiveSheet.Shapes.AddPicture(Filename:=.Text, LinkToFile:=msoFalse, _
                    SaveWithDocument:=msoTrue, Left:=.Offset(0, 1).Left, Top:=.Top, Width:=-1, Height:=-1)
                
            Else
                
                .Offset(0, 1).Value = "Bild nicht gefunden"
                
            End If
            
        End With
    Next
    
    Set objShape = Nothing
    
End Sub

Gruß
Nepumuk

Betrifft: AW: In Masse Bilder importieren
von: Dennis
Geschrieben am: 29.09.2020 12:01:06

Hi Nepumuk,

vielen Dank erstmal für deine Hilfe.

Die Bilder liegen alle im gleichen Ordner wie das Excel-File, es wird mir aber immer "Bild nicht gefunden" ausgegeben. Hast du noch eine Idee??

Betrifft: AW: In Masse Bilder importieren
von: Nepumuk
Geschrieben am: 29.09.2020 12:05:26

Hallo Dennis,

steht in den Zellen nur der Dateiname des Bildes inklusive Endung?

Gruß
Nepumuk

Betrifft: AW: In Masse Bilder importieren
von: Dennis
Geschrieben am: 29.09.2020 12:31:49

Ja genau

Betrifft: AW: In Masse Bilder importieren
von: Nepumuk
Geschrieben am: 29.09.2020 12:35:59

Hallo Dennis,

dann so:

Option Explicit

Public Sub InsertPictures()
    
    Dim strPath As String, strFileName As String
    Dim lngRow As Long
    Dim objShape As Shape
    
    strPath = ThisWorkbook.Path & "\"
    
    For lngRow = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        
        With Cells(lngRow, 1)
            
            If Dir$(strPath & .Text) <> vbNullString Then
                
                Set objShape = ActiveSheet.Shapes.AddPicture(Filename:=strPath & .Text, LinkToFile:=msoFalse, _
                    SaveWithDocument:=msoTrue, Left:=.Offset(0, 1).Left, Top:=.Top, Width:=-1, Height:=-1)
                
            Else
                
                .Offset(0, 1).Value = "Bild nicht gefunden"
                
            End If
            
        End With
    Next
    
    Set objShape = Nothing
    
End Sub

Gruß
Nepumuk