0

I have a problem integrating my InsertPicture code to my FitPicture macro. I'm confused on how to get the shape to resize it automatically after using Insert function. It gives me the error regarding with the object. Here's a link of the idea that I research but still can't make anything happen. Any help is appreciated. Thanks.

Here's the macro I'm using to fit the picture into a merged cell or single cell:

Sub FitPicture()
On Error GoTo NOT_SHAPE
Dim r As Range, sel As Shape
Set sel = ActiveSheet.Shapes(Selection.Name)
sel.LockAspectRatio = msoTrue
Set r = Range(sel.TopLeftCell.MergeArea.Address)

Select Case (r.Width / r.Height) / (sel.Width / sel.Height)
Case Is > 1
    sel.Height = r.Height * 0.9
Case Else
    sel.Width = r.Width * 0.9
End Select


sel.Top = r.Top + 0.05 * sel.Height: sel.Left = r.Left + 0.05 * sel.Width

Exit Sub
NOT_SHAPE:
MsgBox "Please select a picture first."
End Sub

Here's the macro I'm using to insert a picture:

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.Height
.Width = ActiveCell.Width
.Top = ActiveCell.Top
.Left = ActiveCell.Left
.Placement = xlMoveAndSize
End With

Set pic = Nothing

End Sub

How can I integrate my FitPicture code to InsertPicture code? I need to resize it automatically after inserting using my mentioned modification on FitPicture. By the way, I'm using excel 2013. Thanks mates.

Community
  • 1
  • 1
Serversta
  • 93
  • 1
  • 1
  • 12
  • What is the error you get? – Robin Mackenzie Nov 02 '17 at 08:24
  • @RobinMackenzie [link](https://stackoverflow.com/questions/17110425/vba-to-insert-embedded-picture-excel) After using this idea on the link, I get object error. I don't know how to use shapes.addpicture. – Serversta Nov 02 '17 at 08:29
  • Hi Mark - I just meant what exact error are you getting and on what line? If we can add that to your question it will help people provide you an answer and hopefully help people facing the same challenge. – Robin Mackenzie Nov 02 '17 at 08:39
  • @RobinMackenzie Run-time error 91. Object variable or With block variable not set. I update my post and the last part was the code I'm trying to work out. – Serversta Nov 02 '17 at 08:46
  • In the last part of the code, you never assign values to the r and sel variables, hence error 91. – Excelosaurus Nov 02 '17 at 13:10
  • I finish my macro. Thanks for the help. I notice that I should read more forum articles. I want to post my finish code here but I don't know how. @Excelosaurus – Serversta Nov 02 '17 at 13:53

1 Answers1

0

After a day of trying, I finished the macro. Working on single cell, merged cell or selected cell even not merged. 

Sub Insert()

Dim myPicture As String, MyRange As Range
myPicture = Application.GetOpenFilename _
("Pictures (.bmp; .gif; .jpg; .png; .tif),.bmp; .gif; .jpg; .png; .tif", _
, "Select Picture to Import")

Set MyRange = Selection
InsertAndSizePic MyRange, myPicture
End Sub


Sub InsertAndSizePic(Target As Range, PicPath As String)

Dim p As Picture
Application.ScreenUpdating = False

On Error GoTo EndOfSubroutine:
Set p = ActiveSheet.Pictures.Insert(PicPath)

'resize
Select Case (Target.Width / Target.Height) / (p.Width / p.Height)
Case Is > 1
p.Height = Target.Height * 0.9
Case Else
p.Width = Target.Width * 0.9
End Select

'center picture
p.Top = Target.Top + (Target.Height - p.Height) / 2: p.Left = Target.Left + 
(Target.Width - p.Width) / 2

Exit Sub

EndOfSubroutine:
End Sub
Serversta
  • 93
  • 1
  • 1
  • 12