Afbeelding in cel o.b.v. andere celwaarden

[ArjanVos]

Goedendag, u die dit leest

Ik heb een map waarin alle productfoto's staan met als bestandsnaam altijd, zeg: F:\product images\<productnummer>.jpg.

A1 = F:\product images\
B1 = .jpg

Nu haal ik via een query de producten uit een inkooporder op in D1, E1, etc. Het is natuurlijk niet moeilijk om dan de link naar de afbeelding te vormen:
=hyperlink($A$1&D1&$B$1)
=hyperlink($A$1&E1&$B$1)
etc.

Maar kan ik nu o.b.v. deze link ook de bijbehorende afbeelding plaatsen in cel D2, E2, etc.? De afbeelding moet dus mee wijzigen indien de waarden in D1, E1, etc. wijzigen. En liefst ook leeg zijn, als de corresponderende cel leeg is.

Daarnaast: als de jpg-file wordt overschreven, dan moet Excel ook altijd de actuele foto tonen.

 

[HSV]

Als in D1 en E1 de bestandsnamen staan kan het als volgt.

Sub hsv()
Dim j As Long, bestand As String
For j = 4 To 5
 bestand = "F:\product images\" & Cells(1, j).Value & ".jpg"
If Dir(bestand) <> "" Then
    With ActiveSheet.Pictures.Insert(bestand)
        .Top = Cells(2, j).Top
        .Left = Cells(2, j).Left
        .Width = Cells(2, j).Width
    End With
   Else: Cells(2, j) = "Foto niet aanwezig"
  End If
 Next j
End Sub

 

[ArjanVos]

Bedankt Harry, hier ben ik al een eind mee op weg! Wel heb je rij en kolom omgedraaid, dus dat moet als volgt zijn.

Sub Plaats_afbeeldingen()

Dim j As Long, bestand As String
For j = 5 To 14
 bestand = "U:\Afbeeldingen LR\" & Cells(j, 1).Value & ".jpg"
If Dir(bestand) <> "" Then
    With ActiveSheet.Pictures.Insert(bestand)
        .Top = Cells(j, 2).Top
        .Left = Cells(j, 2).Left
        .Height = Cells(j, 2).Height
    End With
   Else: Cells(j, 2) = "Foto niet aanwezig"
  End If
 Next j
End Sub

Wat nog resteert is:

• Cellen leegmaken (bestaande afbeelding of tekst vanuit vorige keer uitvoeren macro) voordat de nieuwe afbeelding wordt geplaatst
• Afbeeldingen hebben verschillende hoogte- en breedte verhoudingen. Hij moet altijd binnen de cel passen en soms is dat gebaseerd op breedte, andere keren op hoogte.
• Macro altijd uitvoeren bij openen van bestand

Dan is het helemaal perfect!

 

[HSV]

Hoezo ben ik degene die rij en kolom heeft omgedraaid????????

Goedendag, u die dit leest
Nu haal ik via een query de producten uit een inkooporder op in D1, E1, etc.
Maar kan ik nu o.b.v. deze link ook de bijbehorende afbeelding plaatsen in cel D2, E2, etc.?

 

[ArjanVos]

Ahum... Shame on me! En excuses :thumb:

 

[HSV]

De juiste hoogte in verhouding tot de juiste breedte is altijd lastig omdat bijna geen plaatje gelijk is.
Dan zou je moeten overschakelen naar een 'Image' en die te voren in elke cel moeten zetten.

Begin met een schoon bestand zonder plaatjes, daar er namen aan de plaatjes worden gegeven.
In ThisWorkbook.

Private Sub Workbook_Open()
Dim sh As Worksheet, j As Long, bestand As String
Set sh = Sheets(1)
 For j = 4 To 5
  sh.Cells(2, j).ClearContents
   bestand = "F:\product images\" & sh.Cells(1, j).Value & ".jpg"
        If Dir(bestand) <> "" Then
            On Error Resume Next
              sh.Shapes("afb" & j).Delete
            On Error GoTo 0
         sh.Pictures.Insert(bestand).Name = "afb" & j
            With sh.Pictures("afb" & j)
               .Top = sh.Cells(2, j).Top
               .Left = sh.Cells(2, j).Left
               .Width = sh.Cells(2, j).Width
               .Height = sh.Cells(2, 1).Height
            End With
   Else
        sh.Cells(2, j) = "Foto niet aanwezig"
  End If
 Next j
End Sub

 

[ArjanVos]

Dankjewel! Weer een stap verder

Wat bedoel je met:

Dan zou je moeten overschakelen naar een 'Image' en die te voren in elke cel moeten zetten.

Is het niet mogelijk om de hoogte en breedte van de afbeelding op te halen en daarmee te gaan rekenen i.c.m. hoogte en breedte van de cel? Bijv. als volgt:

• vh1 = image.Height / sh.Cells(j, 2).Height
• vh2 = image.Width / sh.Cells(j, 2).Width
• vhmax = max (vh1, vh2)
• .Width = image.Width / vhmax
• .Height = image.Height / vhmax

 

[HSV]

Als het daarmee lukt is dat prima toch?
Een Image1 is een activeX-besturingselement, die je vooraf in een cel zet, het plaatje past zich automatisch aan de grootte van het element aan.

 

[ArjanVos]

Nou, mijn vraag is dus eigenlijk of ik de breedte en hoogte van de afbeelding inderdaad op kan halen en die dan dus als parameter kan gebruiken in de door mij genoemde formule (en zo ja, hoe).

 

[HSV]

Zo worden de beelden wel uit elkaar getrokken, maar de grootte is nu gelijk aan de cel.

Sub hsv()
Dim sh As Worksheet, j As Long, bestand As String
Set sh = Sheets(1)
For j = 4 To 5
 sh.Cells(2, j).ClearContents
 bestand = "F:\product images\" & sh.Cells(1, j).Value & ".jpg"
If Dir(bestand) <> "" Then
        On Error Resume Next
          sh.Shapes("afb" & j).Delete
        On Error GoTo 0
sh.Pictures.Insert(bestand).Name = "afb" & j
     With sh.Pictures("afb" & j)
       [COLOR=#FF0000] .ShapeRange.LockAspectRatio = msoFalse[/COLOR]
        .Top = sh.Cells(2, j).Top
        .Left = sh.Cells(2, j).Left
        .Width = sh.Cells(2, j).Width
        .Height = sh.Cells(2, j).Height
     End With
   
   Else: sh.Cells(2, j) = "Foto niet aanwezig"
  End If
 Next j
End Sub

 

[ArjanVos]

Het is wel wenselijk dat de verhoudingen bewaard blijven, anders was dit inderdaad akkoord.

 

[HSV]

Volgens mij zal dat nooit lukken.
De plaatjes hebben een andere grootte in de breedte en hoogte dan de cel.
Met onderstaande code komen de plaatjes netjes in de hoogte van de cel maar niet in de breedte.

Sub hsv()
Dim sh As Worksheet, j As Long, bestand As String
Set sh = Sheets(1)
For j = 4 To 5
sh.Cells(2, j).ClearContents
bestand =  "F:\product images\" & sh.Cells(1, j).Value & ".jpg"
If Dir(bestand) <> "" Then
        On Error Resume Next
          sh.Shapes("afb" & j).Delete
        On Error GoTo 0
sh.Pictures.Insert(bestand).Name = "afb" & j
     With sh.Pictures("afb" & j)
        .Top = sh.Cells(2, j).Top
        .Left = sh.Cells(2, j).Left
        .Height = sh.Cells(2, j).RowHeight
     End With
   
   Else: sh.Cells(2, j) = "Foto niet aanwezig"
  End If
 Next j
End Sub

 

[ArjanVos]

Het is me gelukt!

Ik heb eerst de foto als 'hulpobject' geplaatst en daarmee de factor bepaald waarmee je hoogte en breedte moet delen om hem in de juiste cel te laten passen. Vervolgens plaats ik de definitieve foto, waarbij ik breedte en hoogte deel door deze factor. Tot slot verwijder ik het hulpobject. En dit herhaal ik dan voor iedere cel.

Sub Plaats_afbeeldingen()

Dim sh As Worksheet, j As Long, bestand As String
Set sh = Sheets(1)

 For j = 5 To 14
'Verwijder oude opmerking "Foto niet aanwezig".
  sh.Cells(j, 2).ClearContents
'Creëer pad naar de juiste foto.
   bestand = "U:\Afbeeldingen LR\" & sh.Cells(j, 1).Value & ".jpg"
'Verwijder oude foto.
        If Dir(bestand) <> "" Then
            On Error Resume Next
              sh.Shapes("afbb" & j).Delete
            On Error GoTo 0
'Plaats hulpafbeelding in kolom Y met originele verhoudingen.
        sh.Pictures.Insert(bestand).Name = "afba" & j
            With sh.Pictures("afba" & j)
                .Top = sh.Cells(j, 25).Top
                .Left = sh.Cells(j, 25).Left
            End With
'Bereken de factor waarmee de hoogte en breedte van de afbeelding moet worden aangepast om hem in de uiteindelijke cel te plaatsen.
        vh1 = sh.Shapes("afba" & j).Height / sh.Cells(j, 2).Height
        vh2 = sh.Shapes("afba" & j).Width / sh.Cells(j, 2).Width
            If vh1 > vh2 Then
                vhmax = vh1
            Else
                vhmax = vh2
            End If
'Plaats de uiteindelijke afbeelding in de juiste cel met het juiste formaat.
        sh.Pictures.Insert(bestand).Name = "afbb" & j
            With sh.Pictures("afbb" & j)
                .Top = sh.Cells(j, 2).Top
                .Left = sh.Cells(j, 2).Left
                .Width = sh.Shapes("afba" & j).Width / vhmax
                .Height = sh.Shapes("afba" & j).Height / vhmax
            End With
'Verwijder de hulpafbeelding.
        sh.Shapes("afba" & j).Delete
   Else
'Plaats opmerking indien er geen foto aanwezig is.
        sh.Cells(j, 2) = "Foto niet aanwezig"
  End If
 Next j
 
End Sub

Bedankt voor de hulp!!

 

[HSV]

Als alle foto's dezelfde afmeting hebben zal het prima werken.

Als jij tevreden bent is dat voor mij prima, maar ik zie toch alle plaatjes met verschillende hoogtes en breedtes die niet overeenkomen met de grootte van de cel.
Ik heb de rijen allemaal diverse hoogtes gegeven.
De foto in de cel is te smal of de hoogte niet juist.

Het kan ook niet anders als het plaatje dezelfde grootte moet hebben dan de cel om de foto uit zijn verband te trekken.

In ieder geval succes ermee.

 

[ArjanVos]

Oh, bij mij werkt het precies zoals ik zou willen met verschillende verhoudingen van de afbeeldingen en verschillende rijhoogtes. Zie de schermafbeelding.Misschien hebben we wat langs elkaar heen gepraat, maar dit is wat ik beoogde.