I have a button macro to import pictures to size fit inside a merged cell. I've noticed that the pictures lay over the border and i can't find a way to have it fit inside the border in my code.
Can someone help me
Sub ImportPictures()
'Import one or more pictures into one or more selected areas
Dim FName As Variant
Dim i As Integer
Dim Area As Range
'Be sure cells are selected
If Not TypeOf Selection Is Range Then
MsgBox "Select one or more cells and try again"
End If
'Let the user select files
FName = Application.GetOpenFilename( _
FileFilter:="Pictures (*.jpg;*.jpeg;*.gif;*.bmp), *.jpg;*.jpeg;*.gif;*.bmp", _
Title:="Select picture(s) to import", _
MultiSelect:=True)
'Abort?
If VarType(FName) = vbBoolean Then Exit Sub
'Initialize the counter
i = LBound(FName)
'Import all pictures into each area
For Each Area In Selection.Areas
InsertPicture FName(i), Area
i = i + 1
Next
End Sub
Private Function InsertPicture(ByVal FName As String, ByVal Where As Range, _
Optional ByVal LinkToFile As Boolean = False, _
Optional ByVal SaveWithDocument As Boolean = True, _
Optional ByVal LockAspectRatio As Boolean = False) As Shape
'Inserts the picture file FName as link or permanently into Where
Dim S As Shape, SaveScreenUpdating, SaveCursor
SaveCursor = Application.Cursor
SaveScreenUpdating = Application.ScreenUpdating
Application.Cursor = xlWait
Application.ScreenUpdating = False
With Where
'Insert in original size
Set S = Where.Parent.Shapes.AddPicture( _
FName, LinkToFile, SaveWithDocument, .Left, .Top, -1, -1)
'Keep the proportions?
S.LockAspectRatio = LockAspectRatio
'Scale it to fit the cell
S.Width = .Width
If S.Height > .Height Or Not LockAspectRatio Then S.Height = .Height
End With
Set InsertPicture = S
Application.Cursor = SaveCursor
Application.ScreenUpdating = SaveScreenUpdating
End Function
Bookmarks