关于excel图表生成ppt的代码

ovxyz

Sub PPT_Example()
    Dim pptApp As PowerPoint.Application
    Dim pptPres As PowerPoint.Presentation
    Dim sh As Worksheet
    Dim ch As ChartObject

    Set pptApp = New PowerPoint.Application
    pptApp.Visible = True
    Set pptPres = pptApp.Presentations.Add
    pptPres.PageSetup.SlideSize = PpSlideSizeType.ppSlideSizeOnScreen16x9

    For Each sh In ActiveWorkbook.Sheets
            For Each ch In sh.ChartObjects
                Dim pptSlide As Slide
                Dim Title As Object
                Dim Box As Object
                Dim Txt As Object
                Set pptSlide = pptPres.Slides.Add(pptPres.Slides.Count + 1, ppLayoutBlank)
                ch.Copy
                With pptSlide.Shapes.Paste
                    .Top = Application.CentimetersToPoints(3.3)
                    .Left = Application.CentimetersToPoints(0.76)
                    .Width = Application.CentimetersToPoints(16)
                    .Height = Application.CentimetersToPoints(10.16)
                End With
            'Insert Box
            Set Box = pptSlide.Shapes.AddShape(Type:=msoShapeRectangle, _
            Left:=Application.CentimetersToPoints(17.1), _
            Top:=Application.CentimetersToPoints(3.3), _
            Width:=Application.CentimetersToPoints(7.22), _
            Height:=Application.CentimetersToPoints(9.29))
            Prop_Box.Name = "Box"
            pptSlide.Shapes("Box").Fill.ForeColor.RGB = RGB(219, 233, 255)
            pptSlide.Shapes("Box").Line.ForeColor.RGB = RGB(0, 102, 255)

            'Insert the text box
            Set Txt = pptSlide.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
            Left:=Application.CentimetersToPoints(17.1), _
            Top:=Application.CentimetersToPoints(3.3), _
            Width:=Application.CentimetersToPoints(7.22), _
            Height:=Application.CentimetersToPoints(9.29))
            Txt.Name = "Txt"
            pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Size = 14
            pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Bold = msoCTrue
            pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Name = "Arial"
            pptSlide.Shapes("Txt").TextFrame.TextRange.Text = "Sample Text"

            'Clear the Clipboard
            Dim oData   As New DataObject 'object to use the clipboard
            oData.SetText Text:=Empty 'Clear
            oData.PutInClipboard
            Next
    Next
End Sub

这是网上有限的资料上copy到的一段代码，运行到红色处就报错。  错误代码：424，要求对象。有懂这方面的大佬没？

smiletwo

Prop_Box未定义，name属性需要依附对象

lss001

Prop_Box.Name = "Box"
改为→Box.Name = "Box"

Dim oData   As New DataObject
改为→Set oData = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")