I have created a code to import a picture into a cell or merged cells and created a button for it. The code works, but i would like to know if it's possible to shrink the picture slightly so it fits within the cell as right now it cover's up the borders.
The code is
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