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]

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.