VBA Insert Picture Fully Filed in A Cell

muhammad susanto

Well-known Member
Joined
Jan 8, 2013
Messages
1,762
Office Version
  1. 2016
  2. 2010
Platform
  1. Windows
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
VBA Code:
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
 

Attachments

  • picture_problem.png
    picture_problem.png
    168.2 KB · Views: 11

Some videos you may like

Excel Facts

What does custom number format of ;;; mean?
Three semi-colons will hide the value in the cell. Although most people use white font instead.

GWteB

Well-known Member
Joined
Sep 10, 2010
Messages
1,295
Office Version
  1. 2013
Platform
  1. Windows
How about ...
VBA Code:
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
 
Solution

muhammad susanto

Well-known Member
Joined
Jan 8, 2013
Messages
1,762
Office Version
  1. 2016
  2. 2010
Platform
  1. Windows
hi GWteB....a long time, i'm waiting this..
THANK YOU SO MUCH!!!!
 

GWteB

Well-known Member
Joined
Sep 10, 2010
Messages
1,295
Office Version
  1. 2013
Platform
  1. Windows
You're welcome (y)
 

Watch MrExcel Video

Forum statistics

Threads
1,118,776
Messages
5,574,168
Members
412,574
Latest member
shadowfighter666
Top