将形状从Powerpoint复制到Excel时保留格式的VBA

Sub CopyShapeFromPowerPointToExcel()
    ' 打开PowerPoint应用程序
    Dim pptApp As Object
    Set pptApp = CreateObject("PowerPoint.Application")
    
    ' 打开PowerPoint演示文稿
    Dim pptPresentation As Object
    Set pptPresentation = pptApp.Presentations.Open("C:\Path\to\presentation.pptx")
    
    ' 选择要复制的形状
    Dim pptSlide As Object
    Set pptSlide = pptPresentation.Slides(1) ' 选择第一张幻灯片
    Dim pptShape As Object
    Set pptShape = pptSlide.Shapes("ShapeName") ' 根据形状名称选择
    
    ' 复制形状到剪贴板
    pptShape.Copy
    
    ' 打开Excel应用程序
    Dim excelApp As Object
    Set excelApp = CreateObject("Excel.Application")
    
    ' 打开Excel工作簿
    Dim excelWorkbook As Object
    Set excelWorkbook = excelApp.Workbooks.Open("C:\Path\to\workbook.xlsx")
    
    ' 选择要粘贴形状的工作表和单元格
    Dim excelWorksheet As Object
    Set excelWorksheet = excelWorkbook.Worksheets("Sheet1") ' 选择工作表
    Dim excelRange As Object
    Set excelRange = excelWorksheet.Range("A1") ' 选择要粘贴的单元格
    
    ' 在Excel中粘贴形状并保留格式
    excelWorksheet.PasteSpecial Format:="Picture (Enhanced Metafile)", Link:=False, DisplayAsIcon:=False
    
    ' 关闭并保存Excel工作簿
    excelWorkbook.Close SaveChanges:=True
    
    ' 关闭PowerPoint演示文稿
    pptPresentation.Close
    
    ' 退出PowerPoint和Excel应用程序
    pptApp.Quit
    excelApp.Quit
End Sub