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]

hi marc L, sorry i am stuck about this...i'm newbie about macro..
if you have time, please read complete code . thank

 

[yky]

Try this: use 1,1,-1,-1 for a, b, c, and d. After AddPicture, you can adjust the picture position and size using your existing code.

 

[muhammad susanto]

Try this: use 1,1,-1,-1 for a, b, c, and d. After AddPicture, you can adjust the picture position and size using your existing code.

hi yky, not correct code, i have try like this

Set pic = ActiveSheet.Shapes.AddPicture(Filename:=sPicture, LinkToFile:=False, SaveWithDocument:=True), [B]1, 1 ,-1 ,-1[/B]

in number 1,1,-1,-1 in red color

 

[yky]

hi yky, not correct code, i have try like this

Set pic = ActiveSheet.Shapes.AddPicture(Filename:=sPicture, LinkToFile:=False, SaveWithDocument:=True), [B]1, 1 ,-1 ,-1[/B]

in number 1,1,-1,-1 in red color

Your numbers are outside the parentheses. They should be inside.

Set pic = ActiveSheet.Shapes.AddPicture(Filename:=sPicture, LinkToFile:=False, SaveWithDocument:=True,  _
ActiveCell.MergeArea.Left + cBorder, ActiveCell.MergeArea.Top + cBorder ,-1 ,-1) 'see how to use left and top as variables

    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

 

[muhammad susanto]

hi yky, still not working
some code maybe wrong show message "compiled error, invalid use of property.
here my completed code

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.Shapes.AddPicture(Filename:=sPicture, LinkToFile:=False, SaveWithDocument:=True_)
    ActiveCell.MergeArea.Top cBorder, ActiveCell.MergeArea.Left + cBorder, -1, -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
        .Top = ActiveCell.MergeArea.Top + cBorder
        .Left = ActiveCell.MergeArea.Left + cBorder
        .Placement = xlMoveAndSize
    End With
  
    Set pic = Nothing
End Sub

show error in line

Set pic = ActiveSheet.Shapes.AddPicture(Filename:=sPicture, LinkToFile:=False, SaveWithDocument:=True_)
    ActiveCell.MergeArea.Top cBorder, ActiveCell.MergeArea.Left + cBorder, -1, -1

 

[yky]

You need to put the parentheses at the correct positions so they enclose all the parameters. I already told you so.

 

[muhammad susanto]

hi yky..i have do what your suggestion but still not work
"syantax error"
here complete code

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.Shapes.AddPicture(Filename:=sPicture, LinkToFile:=False, SaveWithDocument:=True,_
ActiveCell.MergeArea.Left + cBorder, ActiveCell.MergeArea.Top + cBorder ,-1 ,-1) 'see how to use left and top as variables

    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

in this line error
Set pic = ActiveSheet.Shapes.AddPicture(Filename:=sPicture, LinkToFile:=False, SaveWithDocument:=True,_
ActiveCell.MergeArea.Left + cBorder, ActiveCell.MergeArea.Top + cBorder ,-1 ,-1) 'see how to use left and top as variables

 

[yky]

Try this:

[B]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) [/B]

 

[muhammad susanto]

Try this:

[B]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) [/B]

hi...still not working show message "run time error 13, type mismatch"
note:
the pictures can be inserted must auto fit cell.

 

[yky]

Need to delare pic as object.