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

muhammad susanto

Well-known Member
Joined
Jan 8, 2013
Messages
1,821
Office Version
  1. 2013
Platform
  1. Windows
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:
VBA 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.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
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

Well-known Member
Joined
Jan 8, 2013
Messages
1,821
Office Version
  1. 2013
Platform
  1. Windows
hi marc L, sorry i am stuck about this...i'm newbie about macro..
if you have time, please read complete code . thank
 

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.

yky

Well-known Member
Joined
Jun 7, 2011
Messages
1,874
Office Version
  1. 2010
Platform
  1. Windows
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

Well-known Member
Joined
Jan 8, 2013
Messages
1,821
Office Version
  1. 2013
Platform
  1. Windows
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
VBA Code:
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

Well-known Member
Joined
Jun 7, 2011
Messages
1,874
Office Version
  1. 2010
Platform
  1. Windows
hi yky, not correct code, i have try like this
VBA Code:
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.

VBA Code:
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

Well-known Member
Joined
Jan 8, 2013
Messages
1,821
Office Version
  1. 2013
Platform
  1. Windows

ADVERTISEMENT

hi yky, still not working
some code maybe wrong show message "compiled error, invalid use of property.
here my completed code
VBA 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
VBA Code:
Set pic = ActiveSheet.Shapes.AddPicture(Filename:=sPicture, LinkToFile:=False, SaveWithDocument:=True_)
    ActiveCell.MergeArea.Top cBorder, ActiveCell.MergeArea.Left + cBorder, -1, -1
 

yky

Well-known Member
Joined
Jun 7, 2011
Messages
1,874
Office Version
  1. 2010
Platform
  1. Windows
You need to put the parentheses at the correct positions so they enclose all the parameters. I already told you so.
 

muhammad susanto

Well-known Member
Joined
Jan 8, 2013
Messages
1,821
Office Version
  1. 2013
Platform
  1. Windows

ADVERTISEMENT

hi yky..i have do what your suggestion but still not work
"syantax error"
here complete code
VBA 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

Well-known Member
Joined
Jun 7, 2011
Messages
1,874
Office Version
  1. 2010
Platform
  1. Windows
Try this:

VBA Code:
[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

Well-known Member
Joined
Jan 8, 2013
Messages
1,821
Office Version
  1. 2013
Platform
  1. Windows
Try this:

VBA Code:
[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.
 
Last edited:

yky

Well-known Member
Joined
Jun 7, 2011
Messages
1,874
Office Version
  1. 2010
Platform
  1. Windows
Need to delare pic as object.
 

Watch MrExcel Video

Forum statistics

Threads
1,133,610
Messages
5,659,830
Members
418,532
Latest member
roynaz11

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top