100 Foto's inladen en rangschikken

[NiekR]

Goedemiddag.

In excel heb ik een rapport, waarin vaak veel foto's in de bijlage moeten, soms wel meer dan 100. De foto's zijn allemaal van hetzelfde formaat (ook alle nieuwe foto's die er eventueel in moeten komen).

Deze foto's moet ik dan inladen, grootte aanpassen en netjes uitlijnen. Ik denk dat dit efficienter kan, maar weet niet precies hoe.
Ik heb al aan gedacht om 100 foto's standaard er in te zetten en deze via rechtermuisknop afbeelding wijzigen aanpassen, zodat grootte en uitlijnen goed is. Alleen dan moet dit nog 100 keer gedaan worden. Kan ik dit ook automatiseren?

 

[NiekR]

Het lukt me waarschijnlijk wel om een lijst met alle bestandsnamen te genereren via dos, van alle foto's die toegevoegd moeten worden.
Ik weet niet of dat een basis is voor een oplossing?

 

[snb]

Sub M_snb()
   for j=1 to 100
      sheet1.shapes.addpicture "G:\OF\voorbeeld" & j & ".jpg",0,0,sheet1.columns(5).left,sheet1.cells(1+j*6,1).top, 120,60
   next
End Sub

 

[keb]

'Load Fotonummers, later filenames
For n = 1 To 5
    On Error Resume Next
    'Get number of the picture (FotoN) that has be loaded
    varHulp = Sheets("Inventarislijst").Cells(row, 10 + n).Value
    'Get the filename of the pciture that has be loaded
    If varHulp <> "" Then
            'Call the filename of the picture
            strFilename = Application.WorksheetFunction.VLookup(varHulp, Worksheets("Fotolijst").Range("A:B"), 2, False)
            ActiveSheet.Cells(24, intXpos(n)) = strFilename
        Else
            strFilename = "0000_leeg.jpg"
        End If
            
    'Load the picture
    If FileExists(curPath + "\" + strInputFolder + "\" + strFilename) = True Then
        Cells(25, intXpos(n)).Activate
        Set pic = ActiveSheet.Pictures.Insert(curPath + "\" + strInputFolder + "\" + strFilename)
        'MsgBox pic.Name
        Else
        MsgBox strFilename & " staat niet in de map " & strInputFolder
        Exit Sub
        End If

    'Resize the place picture
    On Error GoTo 0
    If Not pic Is Nothing Then
        Set rng = ActiveCell
        With pic
        If .Width < .Height Then
            .Width = 130
            Else
            .Height = 130
            End If
            .Left = rng.Left
            .Top = rng.Top
            .Placement = xlMoveAndSize
        End With
    End If
    
    Next 'Next picture

'Range("V3").Value = "Up"
'Range("V5").Value = "Down"
'Range("V3").Interior.ColorIndex = 27
'Range("V5").Interior.ColorIndex = 27

Range("v1").Activate
End Sub

 

[Timshel]

@ keb.
Onzincode.

 

[NiekR]

In de bijlage heb ik een voorbeeld hoe het ongeveer moet worden.
Mijn ideale werkproces is:
1. Zet foto's in een map, zonder namen aan te passen. Dus dat de foto's niet een standaard naam hebben.
2. Druk op een knop en alle foto's staan zoals in het voorbeeld. (Afhankelijk van of het er 10 of 50 zijn)

Met de code van SNB kom ik er niet uit. Die geeft een foutmelding zonder dat er iets gebeurd, of komt dat omdat ik geen 100 foto's in de map heb staan?


Bekijk bijlage voorbeeld.xlsx

 

[keb]

@ timshel
Graag een toelichting waarom JIJ vind dat mijn code onzin is.

De code is een fragment uit een WERKEND Inventarisbeheer-programma waabij ik vijf foto's uit een separaat fotoarchief (aparte map) ophaal en in een werkblad plaats. (bij elk object horen één tot maximaal foto's).
Voor het importeren van bestandsnamen zie bijlage.

 

[Timshel]

@ keb.
Je plaatst een incompleet codefragment, zonder enige context. Functies worden aangeroepen die niet in je code staan. Ga zo maar door.
Het zal voor jou best werken maar hier heeft verder niemand wat aan. Kopiëren plakken kan iedereen, maar zorg er ajb voor dat je posts relevant en adequaat blijven.

 

[Warme bakkertje]

Bestandslijst genereren.

Sub FilenamesFilteren()

    Dim  sDir As String, sExt As String, sn
    sDir = "G:\Mijn documenten\Afbeeldingen\"
    sExt = "*.jp*"
    sn = Split(CreateObject("wscript.shell").Exec("cmd /c Dir """ & sDir & sExt & """ /b").StdOut.ReadAll, vbCrLf)   'array maken met alle filenames

    If UBound(sn) > 0 Then
        Cells(1).Resize(UBound(sn)) = sn
    End If
    
End Sub

 

[mastermindzh]

@Timshel

Ik denk dat niemand het leuk vindt als hij/zij te horen krijgt dat zijn werk "onzincode" is.
Keb probeert hier te zo goed als hij/zij kan. U mag natuurlijk zeggen dat er een aantal dingen ontbreken maar simpelweg zeggen dat het onzincode is gaat wat ver.

Bij deze dus ook de vraag iets vriendelijker te reageren richting de andere helpers

 

[Timshel]

Ok sorry.