Insert Picture in a Cell UDF

[Admin]

Hi

Try this version.

Function INSERTPICTURE(ByVal PictureFullName As String, Optional ByVal PicWidth As Single = 200, _
                                                        Optional ByVal PicHeight As Single = 150) As Boolean
        
    '// Author      : Kris @ ExcelFox.com
        
    Dim CA              As Range
    Dim picPicture
    
    Set CA = Application.Caller
    
    If Val(Application.Version) < 12 Then
        For Each picPicture In ActiveSheet.Shapes
            If picPicture.TopLeftCell.Address = CA.Address Then
                If picPicture.Type = msoLinkedPicture Then
                    picPicture.Delete
                    Exit For
                End If
            End If
        Next
        Set picPicture = ActiveSheet.Shapes.AddPicture(PictureFullName, 1, 0, CA.Left, CA.Top, PicWidth, PicHeight)
        GoTo Finish
    End If
    
    For Each picPicture In ActiveSheet.Pictures
        If picPicture.TopLeftCell.Address = CA.Address Then
            picPicture.Delete
            Exit For
        End If
    Next

    Set picPicture = ActiveSheet.Pictures.Insert(PictureFullName)
    
    With picPicture
        .Left = CA.Left + 1
        .Top = CA.Top + 1
        .Width = PicWidth
        .Height = PicHeight
    End With
    INSERTPICTURE = True
    Exit Function
Finish:
INSERTPICTURE = True
End Function

Note: It works in 2003, not sure on older versions.

[zapamato]

Hi

Try this version.

Function INSERTPICTURE(ByVal PictureFullName As String, Optional ByVal PicWidth As Single = 200, _
                                                        Optional ByVal PicHeight As Single = 150) As Boolean
        
    '// Author      : Kris @ ExcelFox.com
        
    Dim CA              As Range
    Dim picPicture
    
    Set CA = Application.Caller
    
    If Val(Application.Version) < 12 Then
        For Each picPicture In ActiveSheet.Shapes
            If picPicture.TopLeftCell.Address = CA.Address Then
                If picPicture.Type = msoLinkedPicture Then
                    picPicture.Delete
                    Exit For
                End If
            End If
        Next
        Set picPicture = ActiveSheet.Shapes.AddPicture(PictureFullName, 1, 0, CA.Left, CA.Top, PicWidth, PicHeight)
        GoTo Finish
    End If
    
    For Each picPicture In ActiveSheet.Pictures
        If picPicture.TopLeftCell.Address = CA.Address Then
            picPicture.Delete
            Exit For
        End If
    Next

    Set picPicture = ActiveSheet.Pictures.Insert(PictureFullName)
    
    With picPicture
        .Left = CA.Left + 1
        .Top = CA.Top + 1
        .Width = PicWidth
        .Height = PicHeight
    End With
    INSERTPICTURE = True
    Exit Function
Finish:
INSERTPICTURE = True
End Function

Note: It works in 2003, not sure on older versions.

Thanks Kris for your kind support. It work fine on 2003. But I have another question, ist possible keep aspct ratio of original picture. I read several posts in web and can't find any fine answer. Thks a lot for your support, again.

Zapamato