• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Afbeeldingen importeren in Excel met vaste verhoudingen

Status
Niet open voor verdere reacties.
C

CamJacobus

Verenigingslid
Lid geworden
29 mrt 2016
Berichten
58
Ha allen,

Ik gebruik onderstaande code om foto's in te voegen in Excel. De verhouding van de foto's wordt nu vastgezet op een breedte van 80 pixels en een hoogte van 60 pixels. Ik wil een vaste hoogte hebben, maar de breedte naar verhouding aanpassen. Hoe doe ik dat? Ik heb al wat geëxperimenteerd met .LockAspectRatio, maar kom er niet helemaal uit. Kan iemand mij helpen?

Code: 
Sub Insert_Pict1()
    Const Afb_map = "N:\Foto's\"
    myarray = WorksheetFunction.Transpose(Range("J4", Range("J" & Rows.Count).End(xlUp)).Value)
    ActiveSheet.Protect False, False, False, False, False
    If Not IsArray(myarray) Then Exit Sub
    On Error Resume Next
    lRow = 4
    For lLoop = LBound(myarray) To UBound(myarray)
        Set sShape = ActiveSheet.Shapes.AddPicture(Afb_map & myarray(lLoop) & ".jpg", msoFalse, msoCTrue, _
                Cells(1, 9).Left + 9, Cells(lRow, 2).Top + 8, 80, 60)
        lRow = lRow + 1
    Next lLoop
End Sub

Groeten,
Jaco
 
Ik ben nog wat verder gegaan met het proberen de .LockAspectRatio goed toe te passen. Het is nu gelukt.

De code moet als volgt worden aangepast:
Code: 
Sub Insert_Pict1()
    Const Afb_map = "N:\Foto's\"
    myarray = WorksheetFunction.Transpose(Range("J4", Range("J" & Rows.Count).End(xlUp)).Value)
    ActiveSheet.Protect False, False, False, False, False
    If Not IsArray(myarray) Then Exit Sub
    On Error Resume Next
    lRow = 4
    For lLoop = LBound(myarray) To UBound(myarray)
        Set sShape = ActiveSheet.Shapes.AddPicture(Afb_map & myarray(lLoop) & ".jpg", msoFalse, msoCTrue, _
                Cells(1, 9).Left + 9, Cells(lRow, 2).Top + 8, -1, -1)
                With sShape
                    .ShapeRange.LockAspectRatio = msoTrue
                    .Height = 80
                End With
                
        lRow = lRow + 1
    Next lLoop
End Sub

Voor een ieder die erover nagedacht heeft. Bedankt! :eek::thumb:
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan