Strange behavior of xlMoveAndSize in code; does not work properly

[jayexcel1]

Hi,

The code below prompts the user to select an image file and a cell to paste the image to. Attached is the sample file with the macro.

Issue: When I run the macro, an error message pops up "Run time error 1004 - Application defined or object defined error." and when I click on Debug, the code line ".Placement = xlMoveAndSize" is highlighted. The selected image do get pasted but in an enlarged size without xlMoveAndSize.
If I click End multiple times and run the macro again, the image fits into the cell as required.
Quite weird. I have no idea what is going wrong.
Request help to sort this issue.

Option Explicit
Sub FitPic()
' Keyboard Shortcut: Ctrl+Shift+P
Dim sFile As Variant, r As Range
sFile = Application.GetOpenFilename(FileFilter:="Pic Files (*.jpg;*.bmp), *.jpg;*.bmp", Title:="Browse to select a picture")
If sFile = False Then Exit Sub
On Error Resume Next
Set r = Application.InputBox("Click in the cell to hold the picture", Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
If r.Count > 1 Then Exit Sub
ActiveSheet.Pictures.Insert (sFile)
    With ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
        .LockAspectRatio = True
        .Top = r.Top
        .Left = r.Left
        .Height = r.RowHeight
        .Placement = xlMoveAndSize
    End With
End Sub

 

[Luke M]

Hmm. Macro seems to be working perfectly on my machine...since it's a line about sizing, is there perhaps a limit we're running into w/ regard to size of original picture? Try testing with different sized pics, see if code still works?

 

[jayexcel1]

Hi Luke,

Thanks a lot for your reply.

I was trying to upload the "Sample Pictures" that comes by default with MS windows 7.
For e.g. if I tried uploading the Lighthouse.jpg image file, Run Time error 1004 keeps coming up multiple times; and after some time I'm able to upload the same Lighthouse.jpg without any issue. And then again, after some successful attempts, the error message pops up.

jay.

 

[Luke M]

Stranger still. Worked ok here:


Ok, going through full gambit:

• In the attached sample file, the button was originally assigned a macro called "piccy", but the only macro (other than sheet event) is called FitPic. Is this intentional, and/or is there some other macro in between that may be interfering?
• Is the workbook protected?
• Is the sheet protected?
• Are there any other event type macros?
• More than one workbook open at a time?
• Any merged cells?
• AutoFilter?
• XL Table structures?

Ah ha! As I was typing the above, I realized that the last item was true. If I select a cell within the Table, code errors out. Now, we can focus investigation on why tables and pictures don't play nice...

 

[Luke M]

Booya! I figured it out. PRevious code would insert a shape, and then used a with statement on last shape...however, the picture you just inserted is not always that last shape. Sometimes the ordering gets messed up, or it comes in as a picture. I found this by testing

ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Name

and got the unexpected "Drop Down 2"

You can't change a Drop Down's sizing properties, hence the error.

Now, how to fix code? Let's assign the picture to a variable upon creation, and reference that

Sub FitPic()
' Keyboard Shortcut: Ctrl+Shift+P
Dim sFile As Variant, r As Range
Dim sh As Picture
sFile = Application.GetOpenFilename(FileFilter:="Pic Files (*.jpg;*.bmp), *.jpg;*.bmp", Title:="Browse to select a picture")
If sFile = False Then Exit Sub
On Error Resume Next
Set r = Application.InputBox("Click in the cell to hold the picture", Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
If r.Count > 1 Then Exit Sub
Set sh = ActiveSheet.Pictures.Insert(sFile)
    With sh
        .Top = r.Top
        .Left = r.Left
        .Height = r.RowHeight
        .Placement = xlMoveAndSize
    End With
End Sub

 

[jayexcel1]

Thanks a lot Luke. Works perfect.

An add-on query: Is it possible to have a Yes/No value in a column based on whether column L has an image or not?

jay.

 

[Luke M]

Not with native functions, but you could use a UDF like this one

Function HasShape(r As Range) As Boolean
Dim sh As Shape
Dim ws As Worksheet
Application.Volatile

Set ws = r.Parent

For Each sh In ws.Shapes
    If Not (Intersect(sh.TopLeftCell, r) Is Nothing) Then
        HasShape = True
        Exit Function
    End If
Next sh

End Function

Formula then in worksheet would be like:
=IF(HasShape(A2),"Yes","No")

Won't be perfect, as adding shapes doesn't trigger a recalculation, so the formula wouldn't be true "real time", but it'll update the next time a calculation occurs (cell edit or hitting F9).

 

[jayexcel1]

Hi Luke,

Now, I'm facing an issue where if I send this file to a different user and he opens the file then the images which I had added are not showing up in the excel sheet. Instead the below message is shown in place of each image

"The linked image cannot be displayed. The file may have been moved, renamed, or deleted. Verify that the link points to the correct file and location."

The user is not on the same network that I'm working on.

jay

 

[Luke M]

Ah. Looks like we need to use the AddPicture method instead.
http://stackoverflow.com/questions/17110425/vba-to-insert-embeded-picture-excel

Code re-write:

Sub FitPic()
' Keyboard Shortcut: Ctrl+Shift+P
Dim sFile As Variant, r As Range
Dim sh As Shape
sFile = Application.GetOpenFilename(FileFilter:="Pic Files (*.jpg;*.bmp), *.jpg;*.bmp", Title:="Browse to select a picture")
If sFile = False Then Exit Sub
On Error Resume Next
Set r = Application.InputBox("Click in the cell to hold the picture", Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
If r.Count > 1 Then Exit Sub

'Embeds image w/o a link
Set sh = ActiveSheet.Shapes.AddPicture(Filename:=sFile, linktofile:=msoFalse, _
            savewithdocument:=msoCTrue, Left:=r.Left, Top:=r.Top, Width:=r.Width, Height:=r.Height)
   
    'Resize and change placement setting
    With sh
        .Top = r.Top
        .Left = r.Left
        .Height = r.RowHeight
        .Placement = xlMoveAndSize
    End With
End Sub