VBA Excel copy image from active workbook to another workbook

Question

This question could be related to this one:

Copy image from one workbook to another workbook

But it has a different approach.

My goal is to copy the image from my current workbook to another workbook, using the image ID. Basically, if we paste the image, the object is called as "Picture2", "Picture3", "Picture4", etc.

In this event I was trying to set the code universal for these names.

My whole code looks as follows:

 Sub Splicing()
  Dim PoP As String, SN As String
  Dim name As String, name2 As String, custom_name As String
  Dim Fibre As Variant
  Dim shp As Shape


  Dim newbook As Workbook
  Dim fs As Worksheet

  Set fw = Sheets("Frontsheet")
 'name = fw.Range("AA9")
  name = fw.Range("D18")
  name2 = fw.Range("D38")
  custom_name = name & " - Splicing As-build_v." & name2 & ".0"

  PoP = ActiveWorkbook.Sheets("Frontsheet").Range("D10").Value
  SN = ActiveWorkbook.Sheets("Frontsheet").Range("D12").Value


  Fibre = ThisWorkbook.Sheets("Fibre Drop Release Sheet").Range("A2:H20")

  Path = ActiveWorkbook.Path & "\Splicing Template_V1.0.xlsm"
  Set newbook = Workbooks.Open(Path)

  newbook.Sheets("Frontsheet").Cells(10, 4).Value = PoP
  newbook.Sheets("Frontsheet").Cells(12, 4).Value = SN


  newbook.Sheets("Fibre drop release sheet").Range("B3:H20").Value = Fibre

   ' COPYING THE PICTURE

  For Each shp In ActiveWorkbook.Shapes
  If shp.name Like "*Picture*" Then
    If Not Intersect(shp.TopLeftCell, rng) Is Nothing Then
    shp.Copy
    Application.Goto newbook.Sheets("Locality").Range("A6")

    Rows(6).Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove 


    Workbooks(Path).Sheets("Locality").Paste
    End If
  End If
  Next shp

 ' END OF THE CODE WITH COPYING THE PICTURE


  Path = ActiveWorkbook.Path & "\" & custom_name & ".xlsm"

 'Application.DisplayAlerts = False
  ActiveWorkbook.SaveAs filename:=Path, FileFormat:=52


  End Sub

I modified my part of the code from here

https://www.ozgrid.com/forum/index.php?thread/149244-copy-image-from-one-workbook-to-another-workbook/

Why my debugger says, that ** object doesn't support this method** under the For Each ship in ActiveWorkbook.Shapes ?

How can I tweak this code to make it running?

Answer 1

My correct code should look as follows:

 Sub Splicing()
   Dim PoP As String, SN As String
   Dim name As String, name2 As String, custom_name As String
   Dim Fibre As Variant
   Dim shp As Shape


   Dim newbook As Workbook
   Dim fs As Worksheet, ls as Worksheet   'Dim my another source sheet

   Set fw = Sheets("Frontsheet")
   Set ls = Sheets("Location") ' Setting new worksheet in our document

   name = fw.Range("D18")
   name2 = fw.Range("D38")
   custom_name = name & " - Splicing As-build_v." & name2 & ".0"

   PoP = ActiveWorkbook.Sheets("Frontsheet").Range("D10").Value
   SN = ActiveWorkbook.Sheets("Frontsheet").Range("D12").Value


   Fibre = ThisWorkbook.Sheets("Fibre Drop Release Sheet").Range("A2:H20")

   Path = ActiveWorkbook.Path & "\Splicing Template_V1.0.xlsm"
   Set newbook = Workbooks.Open(Path)

   newbook.Sheets("Frontsheet").Cells(10, 4).Value = PoP
   newbook.Sheets("Frontsheet").Cells(12, 4).Value = SN


   newbook.Sheets("Fibre drop release sheet").Range("B3:H20").Value = Fibre

  ' COPYING THE PICTURE

  For Each shp In ls.Shapes  ' We are changing "Workbook" to the Worksheet set above
  If shp.name Like "*Picture*" Then
  shp.Copy
  Application.Goto newbook.Sheets("Locality").Range("A6")

  newbook.Sheets("Locality").Paste
  End If
  Next shp

  ' END OF THE CODE WITH COPYING THE PICTURE


  Path = ActiveWorkbook.Path & "\" & custom_name & ".xlsm"

 'Application.DisplayAlerts = False
  ActiveWorkbook.SaveAs filename:=Path, FileFormat:=52


  End Sub

Basically it's a simple implementation of For Each statement. We are not copying image with a specified name, but image with potential name, which matches our wildcard.