0

您好，我正在尝试将图像从 excel 复制到 powerpoint。我的代码已经复制并粘贴到 excel 中，但我遇到了自动调整大小的代码问题。使用此当前代码，我得到对象所需的运行时错误 424。任何帮助将不胜感激。我的缩写代码如下。

Sub CopyDataToPPT()
'Const ppLayoutBlank = 12
Dim objWorkSheet As Worksheet
Dim objRange As Range
Dim objPPT As PowerPoint.Application
Dim objPresentation As Presentation
Dim shapePPTOne As Object
Dim intLocation As Integer
Dim intHeight As Integer
Dim inLayout As Integer
Dim strRange As String
Dim boolOK As Boolean
Set objPPT = CreateObject("PowerPoint.Application")
Set objPresentation = objPPT.Presentations.Add

 'First 1 Xor 2 charts
    If Sheets("Summary Table").Cells(15, 4) <> "Not Found" Then
        strRange = "B4:N24"
        intHeight = 380
    Else
        strRange = "B4:N13"
        intHeight = 190
    End If

    Set objslide = objPresentation.Slides.Add(1, inLayout)
    objPresentation.Slides(1).Layout = ppLayoutTitleOnly

    objPresentation.Slides(1).Shapes.Title.TextFrame.TextRange.Text = Sheets("Summary Table").Cells(2, 5) & " - " & Sheets("Summary Table").Cells(4, 2)
    Set objRange = Sheets("Summary Table").Range(strRange)
    objRange.Copy

    DoEvents
    Set shapePPTOne = objslide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile, Link:=msoFalse)

    shapePPTOne.Height = intHeight
    shapePPTOne.Left = 50
    shapePPTOne.Top = 100

    Application.CutCopyMode = False
Next intLocation
4

1 回答 1

1

这（您的代码的简化版本）对我来说很好：

Sub CopyDataToPPT()

Dim objslide
Dim objRange As Range
Dim objPPT As PowerPoint.Application
Dim objPresentation As Presentation
Dim shapePPTOne As Object


    Set objPPT = CreateObject("PowerPoint.Application")
    Set objPresentation = objPPT.Presentations.Add

    Set objslide = objPresentation.Slides.Add(1, ppLayoutTitleOnly) 'you had inLayout???
    objslide.Shapes.Title.TextFrame.TextRange.Text = "blah blah"

    Sheets("Sheet1").Range("C6:G22").Copy
    DoEvents

    Set shapePPTOne = objslide.Shapes.PasteSpecial( _
                DataType:=ppPasteEnhancedMetafile, Link:=msoFalse)

    With shapePPTOne
        .Height = 200
        .Left = 50
        .Top = 100
    End With

    Application.CutCopyMode = False

End Sub
于 2014-03-18T21:47:45.090 回答