Code to insert picture not a link to picture?

[JimmyZ25]

I have a code that I've been using to insert a picture into a sheet, but I need it to insert a picture I can send not a link of that picture.


Sub CompressPicture()
Dim fName As String
Dim pic As Picture
Dim r As Range

fName = Application.GetOpenFilename( _
FileFilter:="Images (*.jpg;*.gif;*.png),*.jpg;*.gif;*.png", _
Title:="Please select an image...")
If fName = "False" Then Exit Sub

Set r = ActiveCell
Set pic = Worksheets(ActiveSheet.Name).Pictures.Insert(fName)

With pic
.ShapeRange.LockAspectRatio = msoFalse
.Left = r.Left
.Top = r.Top
.Width = r.Width * 8
.Height = r.Height * 22
.Select
End With

If TypeName(Selection) = "Picture" Then
Application.SendKeys "%a~"
Application.CommandBars.ExecuteMso "PicturesCompress"
End If
End Sub

 

[yky]

See if the following code works for you:

Set pic = Worksheets(ActiveSheet.Name).Shapes.AddPictue(filename:=fName, _
LinkToFile:=False, SaveWithDocument:=True, Left:=r.Left, Top:=r.Top, Width:=r.Width * 8, Height:=r.Height * 22)
pic.Select

 

[JimmyZ25]

See if the following code works for you:

Set pic = Worksheets(ActiveSheet.Name).Shapes.AddPictue(filename:=fName, _
LinkToFile:=False, SaveWithDocument:=True, Left:=r.Left, Top:=r.Top, Width:=r.Width * 8, Height:=r.Height * 22)
pic.Select

Worked great, thanks so much.

 

[yky]

Thanks for the feedback and glad I'm able to help.

 

[jkharmer]

Thanks for the feedback and glad I'm able to help.

Hope you are still looking at this thread YKY! I have the same problem with my solution - I want to insert the physical picture and not the link. I cannot fathom how I would modify this to get it to do what you managed to sort for Jimmy.

Sub InsertPicture1()

Application.ScreenUpdating = False

Dim rng As Range
Dim rng2 As Range
Dim fname As String

'Picture 1a
Const MY_PIC_1a As String = "MyPic1a"
On Error Resume Next
ActiveSheet.Shapes(MY_PIC_1a).Delete
On Error GoTo 0

'Picture 1b
Const MY_PIC_1b As String = "MyPic1b"
On Error Resume Next
ActiveSheet.Shapes(MY_PIC_1b).Delete
On Error GoTo 0

'Picture 1a
Range("Range_Picture1a").Select
Set rng = Selection
fname = Application.GetOpenFilename("Picture files (*.jpg;*.gif;*.bmp), *.jpgs;*.gif;*.bmp", , "Select the picture")
If fname = "False" Then Exit Sub
ActiveSheet.Pictures.Insert(fname).Select
With Selection
.ShapeRange.LockAspectRatio = msoTrue
.Width = rng.Width - 2
.Left = rng.Left + 1
.Top = rng.Top + ((rng.Height - Selection.Height) / 2)
.Placement = xlMoveAndSize
.PrintObject = True
.Name = MY_PIC_1a
End With

'Picture 1b
REPORT.Activate
ActiveSheet.Range("Range_Picture1b").Select
Set rng2 = Selection
ActiveSheet.Pictures.Insert(fname).Select
With Selection
.ShapeRange.LockAspectRatio = msoTrue
.Width = rng2.Width - 2
.Left = rng2.Left + 1
.Top = rng2.Top + ((rng2.Height - Selection.Height) / 2)
.Placement = xlMoveAndSize
.PrintObject = True
.Name = MY_PIC_1b
End With

INFO.Activate

Application.ScreenUpdating = True

End Sub

 

[yky]

I think it's better to post your question as a new thread. Since the code for 1a and 1b are basically identical, try the following code for 1a and modify it for 1b. Not sure what to do with printobject. I'll need to research it or maybe someone can answer it.

    Dim p As Object
    'Picture 1a
    Set rng = ActiveSheet.Range("Range_Picture1a")
    fname = Application.GetOpenFilename("Picture files (*.jpg;*.gif;*.bmp), *.jpgs;*.gif;*.bmp", , "Select the picture")
    If fname = "False" Then Exit Sub

    Set p = ActiveSheet.Shapes.AddPicture(Filename:=fname, LinkToFile:=False, SaveWithDocument:=True, _
        Left:=rng.Left + 1, Top:=rng.Top, Width:=-1, Height:=-1)

    With p
        .Width = rng.Width - 2
        .Top = rng.Top + ((rng.Height - p.Height) / 2)
        .Placement = xlMoveAndSize
        .Name = MY_PIC_1a
    End With
End Sub

 

[yky]

Try this. After "End With", add these two lines:

p.Select
Selection.PrintOject=msoTrue

 

[jkharmer]

Thanks its great - You just missed a "b" in object on this bit:

p.Select
Selection.PrintOject=msoTrue

I really appreciate your help!

 

[yky]

Glad to help.

 

[Jason1H]

Afternoon YKY, Just trying to figure out how to insert a pic into excel when I came across this thread. I am new to the VBA world and am trying to understand your original comment to JimmyZ25. Where he has "set pic...." in his code to replace it with your two lines of code below?

Set pic = Worksheets(ActiveSheet.Name).Shapes.AddPictue(filename:=fName, _
LinkToFile:=False, SaveWithDocument:=True, Left:=r.Left, Top:=r.Top, Width:=r.Width * 8, Height:=r.Height * 22)
pic.Select