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]

The code jimmyZ25 posted contains the following line:

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

This is the line to be replaced.

 

[288enzo]

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

Hi, okay so I'm still super new to VBA and am learning. I am curious, why the code when someone can simply click on "Insert", then "Picture"? What am I missing?
Thanks

 

[Jason1H]

Thanks YKY,

288enzo - I am in the process of creating quality control and acceptance documents for my division at work. As I am creating these worksheets, I lock the format and but leave certain cells unlocked that my colleagues can fill out. The issue with locking the worksheet is it disables a lot of functions within the ribbon bar. The vba code allows people to insert pictures into predetermined cells without having to unlock the worksheet. Make sense?

 

[ccrew]

Help!!
How can I modify the following code to insert the picture as an image instead of a link to a picture?

TIA

Sub TwoPercentPLImage()
'
' TwoPercentPLImage Macro
'
Range("B58").Select
Dim sPicture As String, pic As Picture

ActiveSheet.Unprotect Password:="Pressure"
Sheets("Dynamic Pressure Loss").Unprotect Password:="Process"
sPicture = Application.GetOpenFilename _
("Pictures (*.gif; *.jpg; *.bmp; *.tif; *.png), *.gif; *.jpg; *.bmp; *.tif; *.png", _
, "Select Picture to Import")

If sPicture = "False" Then
ActiveSheet.Protect Password:="Pressure"
Sheets("Dynamic Pressure Loss").Protect Password:="Pressure"
Exit Sub
End If


Set pic = ActiveSheet.Pictures.Insert(sPicture)
With pic
.ShapeRange.LockAspectRatio = False
.Height = 306
.Width = 423
.Top = ActiveCell.Top
.Left = ActiveCell.Left
.Placement = xlMoveAndSize
End With

'
End Sub

 

[ner1277]

Same question, different problem: When I step through this code it put the image in the worksheet but gives me an error on the line in bold:

The error is object variable or with block variable not set. If It didn't get hung up on the error it would be fine. The goal is an image not linked so if i sent it to someone it works.

Sub xxx()

Dim fName As String
Dim pic1 As Object
Dim r As Range

filelocation = Range("path").Value & "\"
sheetstotal = Sheets.Count 'ADD
path = filelocation
file = Dir(path)
i = sheetstotal - 1 'EDIT
If Dir(filelocation) = "" Then Exit Sub

filelocation = path + file
Set r = ActiveCell

Set pic1 = Nothing
pic1 = ActiveSheet.Shapes.AddPicture(Filename:=filelocation, LinkToFile:=False, SaveWithDocument:=True, Left:=r.Left, Top:=r.Top, Width:=r.Width * 8, Height:=r.Height * 22)
pic1.Select

End Sub