Regulate size of imported pictures

[Keyser_Soeze]

Hi!

I'm running a macro that imports pictures from files on my computer, file adress in column A, picture in column B. I've been using code from googling around so I haven't really figured out what's what. I'd like the pictures to be bigger, is there any parameter in the code that regulates the size of the pictures?

Sub InsertPics2() 'Pictures saved with file
'Set column width (ie, pic width) before running macro

Dim r As Range, Shrink As Long
Dim shpPic As Shape
Application.ScreenUpdating = False
Shrink = 0 'Provides negative offset from cell borders when > 0
For Each r In Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
If r.Value <> "" Then
Set shpPic = ActiveSheet.Shapes.AddPicture(FileName:=r.Value, linktofile:=msoFalse, _
savewithdocument:=msoTrue, Left:=Cells(r.Row, 2).Left + Shrink, Top:=Cells(r.Row, 2).Top + Shrink, _
Width:=-1, Height:=-1)
With shpPic
.LockAspectRatio = msoTrue
.Width = Columns(2).Width - (2 * Shrink)
Rows(r.Row).RowHeight = .Height + (2 * Shrink)
End With
End If
Next r
Application.ScreenUpdating = True
End Sub

 

[rlv01]

Use the Width and Height properties of the shape object. For example if you want to increase the size to 150%

    With shpPic
        .LockAspectRatio = msoTrue
        .Width = .Width * 1.5
    End With

Note that because the aspect ratio is locked, I only need to adjust width.

 

[Keyser_Soeze]

Use the Width and Height properties of the shape object. For example if you want to increase the size to 150%

    With shpPic
        .LockAspectRatio = msoTrue
        .Width = .Width * 1.5
    End With

Note that because the aspect ratio is locked, I only need to adjust width.

I realized that my problem is the limitation of cell height, I cant make the pics bigger and still fit the cells because of that. Guess there's nothing to do about that. I'll see what I can do with zooming. Thanks a lot anyway!

 

[rlv01]

I realized that my problem is the limitation of cell height, I cant make the pics bigger and still fit the cells because of that. Guess there's nothing to do about that. I'll see what I can do with zooming. Thanks a lot anyway!

Other than make the cell bigger, no. If you want to invest A LOT of work you can theoretically add code to toggle the picture size when clicked.

Sub Picture1_Click()
    With ActiveSheet.Shapes("Picture 1")
        If .Height = ActiveSheet.Range("A1").Height Then
            .LockAspectRatio = msoTrue
            .Width = 400     'make bigger for viewing
        Else
            .LockAspectRatio = msoTrue
            .Height = ActiveSheet.Range("A1").Height    'return to cell size
        End If
    End With
End Sub

One or two images is no problem, the work comes when you have hundreds of images to do this to.