有没有一种方法可以从excel中复制形状并将它们粘贴为Powerpoint中相同的形状类型？

Sub CopyShapesFromExcelToPowerPoint()
    Dim pptApp As Object ' PowerPoint.Application
    Dim pptPres As Object ' PowerPoint.Presentation
    Dim pptSlide As Object ' PowerPoint.Slide
    Dim excelApp As Object ' Excel.Application
    Dim excelWorkbook As Object ' Excel.Workbook
    Dim excelWorksheet As Object ' Excel.Worksheet
    Dim excelShape As Object ' Excel.Shape
    Dim pptShape As Object ' PowerPoint.Shape
    
    ' 创建PowerPoint应用程序对象
    Set pptApp = CreateObject("PowerPoint.Application")
    pptApp.Visible = True ' 可见性设置为True，方便调试
    
    ' 打开PowerPoint演示文稿
    Set pptPres = pptApp.Presentations.Open("C:\Path\to\Your\Presentation.pptx")
    
    ' 创建Excel应用程序对象
    Set excelApp = CreateObject("Excel.Application")
    excelApp.Visible = True ' 可见性设置为True，方便调试
    
    ' 打开Excel工作簿
    Set excelWorkbook = excelApp.Workbooks.Open("C:\Path\to\Your\Workbook.xlsx")
    
    ' 指定要复制形状的工作表
    Set excelWorksheet = excelWorkbook.Worksheets("Sheet1")
    
    ' 遍历Excel工作表中的形状
    For Each excelShape In excelWorksheet.Shapes
        ' 复制形状到剪贴板
        excelShape.Copy
        
        ' 在PowerPoint中创建新幻灯片
        Set pptSlide = pptPres.Slides.Add(pptPres.Slides.Count + 1, 11) ' 11表示幻灯片布局
        
        ' 将剪贴板中的形状粘贴到PowerPoint幻灯片中
        Set pptShape = pptSlide.Shapes.PasteSpecial(DataType:=2) ' 2表示形状
        
        ' 可以根据需要进行形状的位置、大小等调整
        ' pptShape.Left = ...
        ' pptShape.Top = ...
        ' pptShape.Width = ...
        ' pptShape.Height = ...
    Next excelShape
    
    ' 关闭并保存Excel工作簿
    excelWorkbook.Close SaveChanges:=False
    
    ' 关闭并保存PowerPoint演示文稿
    pptPres.Close SaveChanges:=True
    
    ' 释放对象
    Set pptShape = Nothing
    Set pptSlide = Nothing
    Set pptPres = Nothing
    pptApp.Quit
    Set pptApp = Nothing
    Set excelShape = Nothing
    Set excelWorksheet = Nothing
    Set excelWorkbook = Nothing
    excelApp.Quit
    Set excelApp = Nothing
End Sub