meirbabboon
New Member
- Joined
- May 5, 2015
- Messages
- 7
I have modified a macro that I found and have one issue with it. The macro will bring a picture into a selected area (merged cell) and scale to fit inside the boundaries of the merged cell, however if the width coming in matches the width of the range it does not scale the height. What I need it to do it scale both no matter what so the picture will fit correctly. See the attached macro. Any help would be appreciated. Thank you.
Code:
Sub AddPic()
Dim myPicture As String, pic As Object, MyRange As Range
If ActiveSheet.Pictures.Count > 0 Then
rsp = MsgBox("There is an existing picture. " & vbCr _
& "Do you wish to delete it ?", vbYesNoCancel)
If rsp = vbCancel Then Exit Sub
If rsp = vbYes Then
ActiveSheet.Pictures(1).Delete
End If
End If
myPicture = Application.GetOpenFilename _
("Pictures (*.gif; *.jpg; *.bmp; *.tif; *.bmp; *.png), *.gif; *.jpg; *.bmp; *.tif; *.bmp; *.png", _
, "Select Picture to Import")
If myPicture = "False" Then Exit Sub
Set MyRange = Application.InputBox("Select your range...", Type:=8)
InsertAndSizePic MyRange, myPicture
End Sub
Sub InsertAndSizePic(Target As Range, myPicture As String)
Dim pic As Object
Application.ScreenUpdating = False
Set pic = ActiveSheet.Shapes.AddPicture(myPicture, msoFalse, msoTrue, 0, 0, -1, -1)
pic.ScaleHeight 1, msoTrue
pic.ScaleWidth 1, msoTrue
If Target.Cells.Count = 1 Then Set Target = Target.MergeArea
With Target
If pic.Width <= pic.Height Then
pic.Height = .Height
Else: pic.Width = .Width
End If
pic.Top = .Top - ((pic.Height - .Height) / 2)
pic.Left = .Left - ((pic.Width - .Width) / 2)
End With
Set pic = Nothing
Dim DrObj
Dim Pict
Set DrObj = ActiveSheet.DrawingObjects
For Each Pict In DrObj
If Left(Pict.Name, 7) = "Picture" Then
ActiveSheet.Shapes(Pict.Name).OLEFormat.Object.Border.ColorIndex = 1
ActiveSheet.Shapes(Pict.Name).OLEFormat.Object.Border.Weight = 3
End If
Next
End Sub
Last edited by a moderator:
