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 - Tek-Tips

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 p

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!