Afbeeldingen in cel uitlijnen

[meijerg56]

Hallo

ik heb een macro in excel die ëen foto netje uitlijnt in de cel links
dit gaat echter met 1 foto tegelijk
als ik meerdere foto selecteer krijg ik de melding "'selecteer een afbeelding"
ik zou graag alle afbeeldingen in een keer uit willen lijnen
wie kan mij helpen

ik heb een voorbeeldje bijgevoegd

 

[alphamax]

[SIZE=1]Option Explicit

Public Sub FitPic()
    On Error GoTo NOT_SHAPE
    Dim PicWtoHRatio As Single
    Dim CellWtoHRatio As Single
    Dim objPicture As Object
        For Each objPicture In Selection
            With objPicture
                PicWtoHRatio = .Width / .Height
                With objPicture.TopLeftCell
                    CellWtoHRatio = .Width / .RowHeight
                End With
                Select Case PicWtoHRatio / CellWtoHRatio
                Case Is > 1
                    .Width = .TopLeftCell.Width
                    .Height = .Width / PicWtoHRatio
                Case Else
                    .Height = .TopLeftCell.RowHeight
                    .Width = .Height * PicWtoHRatio
                End Select
                .Top = .TopLeftCell.Top
                .Left = .TopLeftCell.Left
            End With
        Next
        Exit Sub
NOT_SHAPE:
        MsgBox "Select a picture before running this macro."
End Sub[/SIZE]

 

[meijerg56]

Bedankt het werkt nu perfect

[SIZE=1]Option Explicit

Public Sub FitPic()
    On Error GoTo NOT_SHAPE
    Dim PicWtoHRatio As Single
    Dim CellWtoHRatio As Single
    Dim objPicture As Object
        For Each objPicture In Selection
            With objPicture
                PicWtoHRatio = .Width / .Height
                With objPicture.TopLeftCell
                    CellWtoHRatio = .Width / .RowHeight
                End With
                Select Case PicWtoHRatio / CellWtoHRatio
                Case Is > 1
                    .Width = .TopLeftCell.Width
                    .Height = .Width / PicWtoHRatio
                Case Else
                    .Height = .TopLeftCell.RowHeight
                    .Width = .Height * PicWtoHRatio
                End Select
                .Top = .TopLeftCell.Top
                .Left = .TopLeftCell.Left
            End With
        Next
        Exit Sub
NOT_SHAPE:
        MsgBox "Select a picture before running this macro."
End Sub[/SIZE]