Probleem met imprteren van jpg plaatjses

[Bjorkie]

heren en dames,
ik zit met volgende probleempje:
Ik heb een scrips (van vroeger op deze site), waarmee ik ging checken welke waarde (text) in column D stond, ging zoeken in de folder \images\ en voegde de gelijknamige foto in de zelfde rij, in column A
nu, dit werkt niet meer, en ik krijg ook geen foutmeldingen. ik weet even niet meer waar zoeken om eerlijk te zijn.

'Import jpg images from created list
'    Const Afb_map = ActiveWorkbook.Path & "\images\"
    Dim Afb_map As String
    Afb_map = ActiveWorkbook.Path & "C:\temp\Geutebreuck Project calculator 2023 Bjorn\images"
    myarray = WorksheetFunction.Transpose(Range("D3", Range("D" & Rows.Count).End(xlUp)).Value)
    ActiveSheet.Protect False, False, False, False, False
    If Not IsArray(myarray) Then Exit Sub
    On Error Resume Next
    lRow = 3
    For lLoop = LBound(myarray) To UBound(myarray)
        Set sShape = ActiveSheet.Shapes.AddPicture(Afb_map & myarray(lLoop) & ".jpg", msoFalse, msoCTrue, _
                Cells(1, 1).Left + 15, Cells(lRow, 2).Top + 8, -1, -1)
                With sShape
                    .ShapeRange.LockAspectRatio = msoTrue
                    .Height = 20
                End With
        lRow = lRow + 1
    Next lLoop
' select Cel A1 on Equipment page with cursor
'    Worksheets("Equipment list").Range("A1").Select
Application.ScreenUpdating = True
'Protect with a password
ThisWorkbook.Protect Password:="test"
End Sub

Start dus vanaf lijn 3 tot aan de volgende lege lijn.
waarde van column D+.jpg = de bestandsnaam in de aangegeven map.

iemand een tip voor mij?

bestand zelf kan ik echter niet delen.

 

[AHulpje]

Jouw code werkt bij mij zonder probleem, tenminste als je Afb_map afsluit met een backslash:

Afb_map = ActiveWorkbook.Path & "C:\temp\Geutebreuck Project calculator 2023 Bjorn\images[COLOR=#ff0000][B]\[/B][/COLOR]"

Hoeft niet rood te zijn hoor ;-)

 

[Bjorkie]

Jouw code werkt bij mij zonder probleem, tenminste als je Afb_map afsluit met een backslash:

Afb_map = ActiveWorkbook.Path & "C:\temp\Geutebreuck Project calculator 2023 Bjorn\images[COLOR=#ff0000][B]\[/B][/COLOR]"

Hoeft niet rood te zijn hoor ;-)

 

[Bjorkie]

Beste AHulpje.
Is het mogelijk dat het niet werkt doordat de worksheet beveiligd is? Klinkt vreemd want dit script is een klein deel van een veel groter, en de andere delen doen het perfect

 

[AHulpje]

Dat kan zeker een oorzaak zijn, en dat valt niet op omdat:

    On Error Resume Next

Als je die uit zet dan zie je ook dat

.ShapeRange.LockAspectRatio = msoTrue

een foutmelding geeft, dat had moeten zijn:

.LockAspectRatio = msoTrue

Stap maar eens met F8 door de code en controleer de tussenresultaten.

 

[Bjorkie]

Ok, thx
Ga ik vandaag eens proberen.

 

[Bjorkie]

Ik heb na vele tests en opzoekingen tot volgende werkende oplossing gekomen

'Import jpg images from created list
sub Import()
'   Declare variables
    Dim Afb_map As String
    Dim myarray As Variant
    Dim sShape As Shape
    Dim lRow As Long
    Dim lLoop As Long
'   Const Afb_map = ActiveWorkbook.Path & "\images\"
    Afb_map = ActiveWorkbook.Path & "\images\"
    
    myarray = WorksheetFunction.Transpose(Range("D3", Range("D" & Rows.Count).End(xlUp)).Value)
''    ActiveSheet.Protect False, False, False, False, False
    ' Check if myarray is an array
    If Not IsArray(myarray) Then Exit Sub
'    On Error Resume Next
    ' Loop through the array and insert images
    lRow = 3
    For lLoop = LBound(myarray) To UBound(myarray)
        ' Construct the full path to the image
        Dim imagePath As String
        imagePath = Afb_map & "\" & myarray(lLoop) & ".jpg"
        ' Check if the image file exists before adding it
        If Dir(imagePath) <> "" Then
            Set sShape = ActiveSheet.Shapes.AddPicture(imagePath, msoFalse, msoCTrue, _
                Cells(1, 1).Left + 15, Cells(lRow, 2).Top + 8, -1, -1)
            With sShape
                .LockAspectRatio = msoTrue
                .Height = 20
            End With
         lRow = lRow + 1
        End If
        Application.ScreenUpdating = True
    Next

end sub


Alvast dankaan allen die geholpen hebben. :thumb: