使用VBA-Excel在Powerpoint幻灯片中粘贴多个形状

Sub PasteShapesInPowerPoint()
    Dim pptApp As PowerPoint.Application
    Dim pptPres As PowerPoint.Presentation
    Dim pptSlide As PowerPoint.Slide
    Dim pptShape As PowerPoint.Shape
    Dim excelApp As Excel.Application
    Dim excelSheet As Excel.Worksheet
    Dim rng As Excel.Range
    Dim shapeLeft As Double
    Dim shapeTop As Double
    
    ' 创建PowerPoint应用程序对象
    Set pptApp = New PowerPoint.Application
    pptApp.Visible = True
    
    ' 创建一个新的幻灯片演示文稿
    Set pptPres = pptApp.Presentations.Add
    
    ' 创建一个新的幻灯片
    Set pptSlide = pptPres.Slides.Add(1, ppLayoutBlank)
    
    ' 打开Excel应用程序
    Set excelApp = New Excel.Application
    excelApp.Visible = True
    
    ' 打开Excel工作簿
    Set excelWorkbook = excelApp.Workbooks.Open("C:\path\to\your\excel\workbook.xlsx")
    
    ' 获取Excel工作表
    Set excelSheet = excelWorkbook.Worksheets("Sheet1")
    
    ' 设置形状的初始位置
    shapeLeft = 100
    shapeTop = 100
    
    ' 循环遍历Excel工作表中的数据，并在幻灯片中粘贴形状
    For Each rng In excelSheet.UsedRange
        ' 创建一个新的形状
        Set pptShape = pptSlide.Shapes.AddShape(msoShapeRectangle, shapeLeft, shapeTop, 100, 50)
        
        ' 设置形状的文本内容为Excel单元格的值
        pptShape.TextFrame.TextRange.Text = rng.Value
        
        ' 更新形状的位置
        shapeLeft = shapeLeft + 150
        
        ' 当形状超出幻灯片边界时，换行显示
        If shapeLeft + 100 > pptSlide.Width Then
            shapeLeft = 100
            shapeTop = shapeTop + 100
        End If
    Next rng
    
    ' 关闭Excel工作簿和应用程序
    excelWorkbook.Close
    excelApp.Quit
    
    ' 释放对象
    Set rng = Nothing
    Set excelSheet = Nothing
    Set excelWorkbook = Nothing
    Set excelApp = Nothing
    
    ' 保存并关闭PowerPoint演示文稿
    pptPres.SaveAs "C:\path\to\your\powerpoint\presentation.pptx"
    pptPres.Close
    
    ' 释放对象
    Set pptShape = Nothing
    Set pptSlide = Nothing
    Set pptPres = Nothing
    Set pptApp = Nothing
End Sub