VBA Insert Picture Fully Filed in A Cell

[muhammad susanto]

hi all...
the code below work properly..i just want to set margin top, bottom, left, right in a cell..i want to the picture not "fill full" a cell

Sub InsertPicture()
Dim sPicture As String, pic As Picture

sPicture = Application.GetOpenFilename _
("Pictures (*.gif; *.jpg; *.bmp; *.tif), *.gif; *.jpg; *.bmp; *.tif", _
, "Select Picture to Import")

If sPicture = "False" Then Exit Sub

Set pic = ActiveSheet.Pictures.Insert(sPicture)
With pic
.ShapeRange.LockAspectRatio = msoFalse
.Height = ActiveCell.MergeArea.Height
.Width = ActiveCell.MergeArea.Width
.Top = ActiveCell.MergeArea.Top
.Left = ActiveCell.MergeArea.Left
.Placement = xlMoveAndSize
End With

Set pic = Nothing

End Sub

to compare please, see my attactment picture

 

[GWteB]

How about ...

Sub InsertPicture_r2()

    Const cBorder As Double = 5     ' << change as required
    
    Dim sPicture As String, pic As Picture
    
    sPicture = Application.GetOpenFilename("Pictures (*.gif; *.jpg; *.bmp; *.tif), *.gif; *.jpg; *.bmp; *.tif", , "Select Picture to Import")
    
    If sPicture = "False" Then Exit Sub
    
    Set pic = ActiveSheet.Pictures.Insert(sPicture)
    With pic
        .ShapeRange.LockAspectRatio = False       ' << change as required
        
        If Not .ShapeRange.LockAspectRatio Then
            .Width = ActiveCell.MergeArea.Width - (2 * cBorder)
            .Height = ActiveCell.MergeArea.Height - (2 * cBorder)
        Else
            If .Width >= .Height Then
                .Width = ActiveCell.MergeArea.Width - (2 * cBorder)
            Else
                .Height = ActiveCell.MergeArea.Height - (2 * cBorder)
            End If
        End If
        .Top = ActiveCell.MergeArea.Top + cBorder
        .Left = ActiveCell.MergeArea.Left + cBorder
        .Placement = xlMoveAndSize
    End With
    
    Set pic = Nothing

End Sub

 

[muhammad susanto]

hi GWteB....a long time, i'm waiting this..
THANK YOU SO MUCH!!!!

 

[GWteB]

You're welcome