VBA to insert a custom image

[dpaton05]

I have code to insert a set image. Could someone tell me how to alter it so it can insert a custom image please?

Sub cmdJakeSig()
    Dim shp As Shape
    Set shp = ThisWorkbook.Worksheets("sheet1").Shapes("textbox4")
        Sheets("Sheet2").Shapes("ImgJ").Copy
        Sheets("sheet1").Paste Destination:=Sheets("sheet1").Cells(1, 1)
        Selection.Top = shp.Top + shp.Height + "50"
    'ActiveSheet.Protect Password:=""
End Sub

 

[dpaton05]

or a bit shorter

.Top = lr + [COLOR=red]150[/COLOR] + shp.Top + shp.Height

I played around with those numbers and it didn't make any difference.

 

[Michael M]

There is data in Col "A" isn't there ?
That's what lr as based on.
I haven't got excel at the moment, but also try

.Top = Rows(lr) + 150 + shp.Top + shp.Height

 

[dpaton05]

This is the code I am using that appears to be working Michael.

Sub cmdCustomSig()
Dim fNameAndPath As Variant
Dim img As Picture, shp As Shape
Set shp = ThisWorkbook.Worksheets("NPSS_quote_sheet").Shapes("textbox4")

fNameAndPath = Application.GetOpenFilename(Title:="Select Picture To Be Imported")
If fNameAndPath = False Then Exit Sub
    Set img = Worksheets("NPSS_quote_sheet").Pictures.Insert(fNameAndPath)
    With img
       .Top = shp.Top + shp.Height + "50"
       .Left = "0"
    End With
     
End Sub

 

[dpaton05]

There is data in Col "A" isn't there ?
That's what lr as based on.
I haven't got excel at the moment, but also try

.Top = Rows(lr) + 150 + shp.Top + shp.Height

That code puts the image in the centre at row 6 in the sheet.

Column A has data, under the rows, there are buttons then the notes text box.

 

[Michael M]

So you have it working ??
Is Column "A" the col with the most used rows ??

 

[dpaton05]

Is pastes the image below the text box as I want it but if the box is nearing the bottom of the page on the sheet, the image is still split between both the first and additional page.

 

[Michael M]

Can you upload the latest version of the workbook please ?

 

[dpaton05]

The code that you gave me takes about 10 seconds to complete and puts the signature in the same spot as my code. This is that code.

Private Sub CommandButton1_Click()
'insert custom image code from michael
Dim fNameAndPath As Variant
Dim img As Picture, shp As Shape
Set shp = Worksheets("NPSS_quote_sheet").Shapes("TextBox4")
fNameAndPath = Application.GetOpenFilename(Title:="Select Signature To Be Imported")
If fNameAndPath = False Then Exit Sub
 Dim h As Long, lr As Long
lr = Cells(Rows.Count, "A").End(xlUp).Row
Set img = Worksheets("NPSS_quote_sheet").Pictures.Insert(fNameAndPath)
  For h = 1 To 100
    If Sheets("NPSS_quote_sheet").Rows(h).PageBreak <> xlPageBreakNone Then
    If lr >= h - 5 Then 'this is 5 rows before the page break
    With img
       .Left = 0
       .Top = Rows(lr) + 150 + shp.Top + shp.Height
    End With
    Else
    With img
       .Left = 0
       .Top = shp.Top + shp.Height + 50
    End With
    End If
    End If
  Next h
End Sub

 

[dpaton05]

My supervisor doesn't want me to upload it, sorry Michael.

 

[dpaton05]

Sorry, this is the code you gave me

Private Sub CommandButton1_Click()
'insert custom image code from michael
Dim fNameAndPath As Variant
Dim img As Picture, shp As Shape
Set shp = Worksheets("sheet1").Shapes("TextBox4")
fNameAndPath = Application.GetOpenFilename(Title:="Select Signature To Be Imported")
If fNameAndPath = False Then Exit Sub
 Dim h As Long, lr As Long
lr = Cells(Rows.Count, "A").End(xlUp).Row
Set img = Worksheets("sheet1").Pictures.Insert(fNameAndPath)
  For h = 1 To 100
    If Sheets("sheet1").Rows(h).PageBreak <> xlPageBreakNone Then
    If lr >= h - 5 Then 'this is 5 rows before the page break
    With img
       .Left = 0
       .Top = Rows(lr) + 150 + shp.Top + shp.Height
    End With
    Else
    With img
       .Left = 0
       .Top = shp.Top + shp.Height + 50
    End With
    End If
    End If
  Next h
End Sub