Vba : Excel File Can't Save Picture Within The File It Self

[muhammad susanto]

hi all.
i have macro code to insert picture from a folder. The code work properly.
i have problem, after running code the pict is displayed but then when save the file then the new file opened the other device/pc/notebook the picture not "show " and show message "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."
I need the code to be able to save the picture within the file itself. Here is the code for the macro:

Sub InsertPicture_r2()

    Const cBorder As Double = 5     ' << change as required
   
    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 = False       ' << change as required
       
        If Not .ShapeRange.LockAspectRatio Then
            .Width = ActiveCell.MergeArea.Width - (2 * cBorder)
            .Height = ActiveCell.MergeArea.Height - (2 * cBorder)
        Else
            If .Width >= .Height Then
                .Width = ActiveCell.MergeArea.Width - (2 * cBorder)
            Else
                .Height = ActiveCell.MergeArea.Height - (2 * cBorder)
            End If
        End If
        .Top = ActiveCell.MergeArea.Top + cBorder
        .Left = ActiveCell.MergeArea.Left + cBorder
        .Placement = xlMoveAndSize
    End With
   
    Set pic = Nothing
End Sub

maybe this link related can solve my problem

Excel 2010 Macro Changes? - Microsoft: Office

Was wondering if the macro coding has changed in the 2010 version of Excel. We have a workbook with several macros in it. A few of these macros are for adding pictures to the workbook. The code in the macros works for Excel 2003 and 2007, but doesn't do as it should in 2010. The problem we are...

www.tek-tips.com

how to fix it the problem and maybe modified my code above.

any help, greatly appreciated..
note I'm use Office 2010
.sst

 

[muhammad susanto]

Need to delare pic as object.

Please, i Don t understand what you mean. Where is delete pic as object?

 

[yky]

Declare

 

[muhammad susanto]

Declare

hi. ..
i am still confuse how to use or you mean "declare" would you show me with code?

 

[yky]

Dim pic as Object

 

[muhammad susanto]

Dim pic as Object

Hi yky, how to make Dim pic as object..
How to input into your code before.
Complete code, would you help me out.

 

[yky]

Change the word Picture to Object or Shape. Either will do.

Dim sPicture As String, pic As Picture

 

[muhammad susanto]

Change the word Picture to Object or Shape. Either will do.

Dim sPicture As String, pic As Picture

i have try but still not work please complete code

Sub InsertPicture_r2()

    Const cBorder As Double = 5     ' << change as required
  
    [B]Dim sPicture As Object, pic As Object [/B]
  
    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.Shapes.AddPicture(Filename:=sPicture, LinkToFile:=False, SaveWithDocument:=True,_
 Left:=ActiveCell.MergeArea.Left + cBorder, Top:=ActiveCell.MergeArea.Top + cBorder ,Width:=-1 ,Height:=-1)

    With pic
        .ShapeRange.LockAspectRatio = False       ' << change as required
      
        If Not .ShapeRange.LockAspectRatio Then
            .Width = ActiveCell.MergeArea.Width - (2 * cBorder)
            .Height = ActiveCell.MergeArea.Height - (2 * cBorder)
        Else
            If .Width >= .Height Then
                .Width = ActiveCell.MergeArea.Width - (2 * cBorder)
            Else
                .Height = ActiveCell.MergeArea.Height - (2 * cBorder)
            End If
        End If

        .Placement = xlMoveAndSize
    End With
      
    Set pic = Nothing
End Sub

 

[Domenic]

You need a space betweeen the comma ( , ) and the line continuation character ( _ )...

   Set pic = ActiveSheet.Shapes.AddPicture(Filename:=vPicture, LinkToFile:=False, SaveWithDocument:=True, _
                Left:=ActiveCell.MergeArea.Left + cBorder, Top:=ActiveCell.MergeArea.Top + cBorder, Width:=-1, Height:=-1)

Also, there are other issues with your code...

1) Application.GetOpenFilename returns a Variant. Therefore, replace...

Dim sPicture As Object

with

Dim vPicture As Variant

2) ActiveSheet.Shapes.AddPicture returns a Shape. Therere, replace...

pic As Object

with

pic As Shape

3) LockAspectRatio is the property of the Shape object. And so since pic refers to a Shape, replace...

.ShapeRange.LockAspectRatio = False

with

.LockAspectRatio = False

Here is your code, which has been amended accordingly...

Sub InsertPicture_r2()

    Const cBorder As Double = 5     ' << change as required
 
    Dim vPicture As Variant, pic As Shape
 
    vPicture = Application.GetOpenFilename("Pictures (*.gif; *.jpg; *.bmp; *.tif), *.gif; *.jpg; *.bmp; *.tif", , "Select Picture to Import")
 
    If vPicture = False Then Exit Sub

   Set pic = ActiveSheet.Shapes.AddPicture(Filename:=vPicture, LinkToFile:=False, SaveWithDocument:=True, _
                Left:=ActiveCell.MergeArea.Left + cBorder, Top:=ActiveCell.MergeArea.Top + cBorder, Width:=-1, Height:=-1)

    With pic
        .LockAspectRatio = False       ' << change as required
    
        If Not .LockAspectRatio Then
            .Width = ActiveCell.MergeArea.Width - (2 * cBorder)
            .Height = ActiveCell.MergeArea.Height - (2 * cBorder)
        Else
            If .Width >= .Height Then
                .Width = ActiveCell.MergeArea.Width - (2 * cBorder)
            Else
                .Height = ActiveCell.MergeArea.Height - (2 * cBorder)
            End If
        End If

        .Placement = xlMoveAndSize
    End With
    
    Set pic = Nothing
  
End Sub

Hope this helps!

 

[muhammad susanto]

hi Domenic, Worked Great!!!
A long time, I' waiting this...thank you so much.

 

[Domenic]

You're very welcome, cheers!