Invoegen afbeelding middels Macro in juiste verhouding

[CamJacobus]

Goedemorgen,

Ik gebruik onderstaande code om meerdere afbeeldingen op een bepaalde volgorde in mijn Excelbestand toe te voegen. Zie bijlage voor het betreffende onderdeel van het bestand. De macro doet zijn werk, alleen wordt de verhouding van de afbeeldingen aangepast aan het celformaat. Ik wil dat de hoogte van de afbeelding wel wordt aangepast aan het celformaat, maar de breedte moet in verhouding blijven met de originele verhouding. Hoe doe ik dat?

Sub Invoegen_afbeeldingen()

    Dim PicList() As Variant
    Dim PicFormat As String
    Dim Rng As Range
    Dim sShape As Shape
    On Error Resume Next
    PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True)
    Sheets("Bijlage fotorapportage").Select
    Range("A8").Select
    xColIndex = Application.ActiveCell.Column
    If IsArray(PicList) Then
        xRowIndex = Application.ActiveCell.Row
        For lLoop = LBound(PicList) To UBound(PicList)
            Set Rng = Cells(xRowIndex, xColIndex)
            Set sShape = ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoTrue, msoCTrue, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
            xRowIndex = IIf(xColIndex >= 5, xRowIndex + 3, xRowIndex)
            xColIndex = IIf(xColIndex >= 5, 1, xColIndex + 2)
        Next
End If
End Sub

Alvast hartelijk bedankt voor jullie hulp!
Groeten,
Jaco

Bekijk bijlage test.xlsm

 

[edmoor]

Zet van de Shape het attribuut .LockAspectRatio op msoTrue en wijzig dan alleen de .Height

 

[wampier]

Zoiets?

Set sShape = ActiveSheet.Pictures.Insert(PicList(lLoop))
breedte = (Rng.Height / sShape.Height) * sShape.Width
sShape.Height = Rng.Height
sShape.Width = breedte
sShape.Top = Rng.Top
sShape.Left = Rng.Left

 

[CamJacobus]

Bedankt voor jullie reacties!

De volgende code werkt bij mij niet. Als ik nu nieuwe afbeeldingen wil invoegen worden deze niet toegevoegd.

Sub Invoegen_afbeeldingen()

    Dim PicList() As Variant
    Dim PicFormat As String
    Dim Rng As Range
    Dim sShape As Shape
    On Error Resume Next
    PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True)
    Sheets("Bijlage fotorapportage").Select
    Range("A8").Select
    xColIndex = Application.ActiveCell.Column
    If IsArray(PicList) Then
        xRowIndex = Application.ActiveCell.Row
        For lLoop = LBound(PicList) To UBound(PicList)
            Set Rng = Cells(xRowIndex, xColIndex)
            Set sShape = ActiveSheet.Shapes.AddPicture(PicList(lLoop))
            breedte = (Rng.Height / sShape.Height) * (sShape.Width)
            sShape.Height = Rng.Height
            sShape.Width = breedte
            sShape.Top = Rng.Top
            sShape.Left = Rng.Left
            xRowIndex = IIf(xColIndex >= 5, xRowIndex + 3, xRowIndex)
            xColIndex = IIf(xColIndex >= 5, 1, xColIndex + 2)
        Next
End If
End Sub

@edmoor: hoe moet ik het atribuut .LockAspectRatio in de code plaatsen? Ik ben nog een leek op het gebied van VBA..

 

[CamJacobus]

Goedemorgen, zou iemand mij nog kunnen helpen met bovenstaande vraag over de code en de .LockAspectRatio?

 

[CamJacobus]

Ik ben er nog niet uit hoe ik dit op de juiste wijze in de code moet plakken. Kan iemand mij helpen?

Alvast bedankt!