VBA Excel 将图像从活动工作簿复制到另一个工作簿

Question

这个问题可能与这个问题有关：

将图像从一个工作簿复制到另一个工作簿

但它有不同的方法。

我的目标是使用图像 ID 将图像从我当前的工作簿复制到另一个工作簿。 基本上，如果我们粘贴图像，object 被称为“Picture2”、“Picture3”、“Picture4”等。

在这种情况下，我试图为这些名称设置通用代码。

我的整个代码如下所示：

 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

我从这里修改了我的部分代码

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

为什么我的调试器说，** object 不支持此方法** For Each ship in ActiveWorkbook.Shapes下？

如何调整此代码以使其运行？

Answer 1

我的正确代码应如下所示：

 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

基本上它是 For Each 语句的简单实现。 我们不是在复制具有指定名称的图像，而是具有与我们的通配符匹配的潜在名称的图像。