VBA for Image Insert with Command Button

Hello

I am trying to create a Command Button with a sheet that once it is pressed

Will take me to my Documents folder

Where I can chose a Passport size picture

and it will place it into the Sheet in a specific merged cell

Any assistance would be grateful

i.e. I did find a youtube video of something similar , but it was in a foreign language to me

So could understand it all

But showed it was possible

Any assistance would be Grateful

Bod213

Capture.PNG

Hopefully here is a picture of my spread sheet with the Command Button

And the Merged Cell where I want the Picture to be placed

Pic.PNG

A pic of a similar VBA for Image Insert with Command Button

Sub InsertPictureInActiveCell()
Dim strFile As String
Dim rng As Range
Dim sh As Range
Const cFile As String = "Image Files(*.bmp; *.jpg; *.jepg; *.png),"
strFile = Application.GetOpenFilename(filefilter:=cFile, Title:=ES)
If strFile = "False" Then
Else
Set rng = ActiveCell
Set rng = mg.MergeArea
With rng
Set sh = ActiveSheet.Shapes.AddPicture(Filename:=strfFile, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)
sh.LockAspectRation = msoFalse
End With
Set sh = Nothing
Set rng = Nothing
End If
End Sub


I tried this code , but it didn't quite work

Sub SheetA.1_Button1_Click()

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
'Innsert
Set pic = ActiveSheet.Pictures.Insert(sPicture)
With pic
.ShapeRange.LockAspectRatio = msoFalse
.Height = ActiveCell.Height
.Width = ActiveCell.Width
.Top = ActiveCell.Width
.Left = ActiveCell.Left
.Placement = x1MoveAndSize
End With

Set pic = Nothing

and I also tried this code , which didn't work either

Sub InsertPictureInActiveCell()

Dim strFile As String
Dim rng As Range
Dim sh As Range

Const cFile As String = "Image Files(*.bmp; *.jpg; *.jepg; *.png),"
strFile = Application.GetOpenFilename(filefilter:=cFile)


End Sub

this part of the Code works - In that it opens up the document file

its the other part of the code that does place the pic in the active cell

Sub InsertPictureInActiveCell()
Dim strFile As String
Dim rng As Range
Dim sh As Range
Const cFile As String = "Image Files(*.BMP; *.JPG; *.JEPG; *.PNG),"
strFile = Application.GetOpenFilename(filefilter:=cFile, Title:=Ts)
If strFile = "False" Then
Else
Set rng = ActiveCell
Set rng = rng.MergeArea
With rng
Set sh = ActiveSheet.Shapes.AddPicture(Filename:=strFile, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)
sh.LockAspectRation = msoFalse
End With
Set sh = Nothing
Set rng = Nothing
End If
End Sub

I have played about with the code and managed to get it to work slightly

It will run with the command button
It will take me to document file
It will allow a pic to be chosen

But I get this error message

pIC 3.PNG

On pressing OK

I does insert the pic

But cant work out why I am getting the error message first

I also want to use this on everyone of the 26 sheets in the work book

Public Sub InsertPictureInActiveCell()
Dim strFile As String
Dim rng As Range
Dim sh
Const cFile As String = "Image Files(*.bmp; *.jpg; *.jepg; *.png; *.tif),"

strFile = Application.GetOpenFilename(filefilter:=cFile, Title:=Ts)

If strFile = "False" Then
Else
Set rng = ActiveSheet.Range("B2").MergeArea
With rng
Set sh = ActiveSheet.Shapes.AddPicture(Filename:=strFile, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)
sh.LockAspectRatio = msoFalse
End With
Set sh = Nothing
Set rng = Nothing
End If
End Sub

This is the Solved Solution for me anyway