Afbeeldingen invoegen

[ebbremmer]

Hallo,

In mijn excelbestand (excel 2019) staat een veld met daarin een maplocatie van een afbeelding. Dit veld wil ik gebruiken om in een ander veld de betreffende afbeelding in te voegen (in een bepaald formaat). Hoe kan dit gerealiseerd worden?

[ebbremmer]

Bedankt voor de reactie. Voor mij nogal een technisch verhaal  ik zal binnenkort een bestand posten.

[ebbremmer]

Hallo Philiep,

 

Zie bijlagen.

 

Groeten,

Eric

PC-Helpforum.zip

[bakerman]

Sub Insert_Pict1()
    Dim lRow As Long, lLoop As Long
    Dim sShape As Shape
    Dim myarray As Variant
    With Sheets("Export")
        myarray = Application.Transpose(.Range("M2", .Range("M1048576").End(xlUp)).Value)
        If Not IsArray(myarray) Then MsgBox "Geen bestanden geselecteerd.": Exit Sub
        On Error Resume Next
        lRow = 2
        For lLoop = LBound(myarray) To UBound(myarray)
            Set sShape = .Shapes.AddPicture(myarray(lLoop), msoFalse, msoCTrue, _
                .Cells(1, 14).Left + 9, .Cells(lRow, 14).Top + 8, 80, 60)
            lRow = lRow + 1
        Next lLoop
    End With
End Sub

 

[ebbremmer]

HARTELIJK DANK!!!

[ebbremmer]

Philiep,

 

Helaas krijg ik  errors tijdens het uitvoeren van de macro Zie hierna. Komt dit omdat er ook  bestanden verwerkt moeten worden met de extensie .jpeg en .gif? Geeft foutnummer 52. Ongeldige bestandsnaam.

 

Eric

 

Sub dotch()
Dim Cell As Range, Path As String
Path = "C:\#[Data]#\Music Collector\Images\"
With Sheets("Export")
    For Each Cell In .Range("M2:M" & .Cells(.Rows.Count, 13).End(xlUp).Row)
        If Dir(Path & Cell & ".jpg") <> "" Then
            With .Pictures.Insert(Path & Cell & ".jpg")
                .ShapeRange.LockAspectRatio = msoFalse
                .Left = Cell.Offset(, 1).Left: .Top = Cell.Offset(, 1).Top
                .Width = Cell.Offset(, 1).Width: .Height = Cell.Offset(, 1).Height
            End With
        End If
    Next Cell
End With
End Sub
 

[ebbremmer]

Oeps, vergeten te melden dat niet alle cellen met de maplocatie van een afbeelding gevuld zijn.

 

Er zou dus getest moeten worden of de cel gevuld is en zo ja, rekening houden met verschillende afbeeldingsformaten. Helaas is het voor mij abacadabra. Excuses voor het ongemak.

[bakerman]

dj is je blijkbaar vergeten dus spring ik maar even in.

 

Volgende zou je moeten verder helpen.

 

Sub dotch()
Dim Cell As Range, Path As String
Path = "C:\#[Data]#\Music Collector\Images\"
With Sheets("Export")
    For Each Cell In .Range("M2:M" & .Cells(.Rows.Count, 13).End(xlUp).Row)
        If Cell.Value <> vbNullString Then
            If Dir(Path & Cell & ".*") <> "" Then
                ext = CreateObject("scripting.filesystemobject").getextensionname(Dir(Path & Cell & ".*"))
                With .Pictures.Insert(Path & Cell & "." & ext)
                    .ShapeRange.LockAspectRatio = msoFalse
                    .Left = Cell.Offset(, 1).Left: .Top = Cell.Offset(, 1).Top
                    .Width = Cell.Offset(, 1).Width: .Height = Cell.Offset(, 1).Height
                End With
            End If
        End If
    Next Cell
End With
End Sub

 

[ebbremmer]

Hallo,

 

Bedankt voor de reactie. Helaas gaat het nog steeds fout op de regel:

 

  If Dir(Path & Cell & ".*") <> "" Then

 

fout 52 ongeldige bestandsnaam of ongeldig bestandsnummer

[bakerman]

Heb het getest met een lege cel, bestandsnaam die aanwezig is, bestandsnaam die niet aanwezig is en verschillende extensies.

 

Werkt feilloos hier.

 

Zoals de foutmelding al aangeeft schort er iets aan je bestandsnamen. Misschien ongeldige tekens in de bestandsnaam o.i.d..

5 juni 2022 aangepast door bakerman