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

Select a hidden cell
Somehide hide payroll data in column G? Press F5. Type G1. Enter. Look in formula bar while you arrow down through G.

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,119,117
Messages
5,576,196
Members
412,706
Latest member
msousa25
Top