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
 

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest

yky

Well-known Member
Joined
Jun 7, 2011
Messages
1,874
Office Version
  1. 2010
Platform
  1. Windows
Dim pic as Object
 

muhammad susanto

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

ADVERTISEMENT

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

Well-known Member
Joined
Jun 7, 2011
Messages
1,874
Office Version
  1. 2010
Platform
  1. Windows
Change the word Picture to Object or Shape. Either will do.

VBA Code:
Dim sPicture As String, pic As Picture
 

muhammad susanto

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

ADVERTISEMENT

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

VBA Code:
Dim sPicture As String, pic As Picture
i have try but still not work please complete code
VBA 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

MrExcel MVP
Joined
Mar 10, 2004
Messages
19,647
You need a space betweeen the comma ( , ) and the line continuation character ( _ )...

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

VBA Code:
Dim sPicture As Object

with

VBA Code:
Dim vPicture As Variant

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

VBA Code:
pic As Object

with

VBA Code:
pic As Shape

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

VBA Code:
.ShapeRange.LockAspectRatio = False

with

VBA Code:
.LockAspectRatio = False

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

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

muhammad susanto

Well-known Member
Joined
Jan 8, 2013
Messages
1,821
Office Version
  1. 2013
Platform
  1. Windows
hi Domenic, Worked Great!!!
A long time, I' waiting this...thank you so much. :)
 

Watch MrExcel Video

Forum statistics

Threads
1,133,625
Messages
5,659,941
Members
418,538
Latest member
alc51103

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