Question

您好我尝试将图像从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

Answer 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

Excel to Powerpoint：问题调整图像大小

1 个答案: