VBA 问题调整大小和增强从 Excel 粘贴到 PowerPoint 的元文件

Question

我正在尝试创建一个 Excel 宏，它允许我选择 Excel 文件的任何范围，并将该选择导出到 PowerPoint，同时匹配所选 PowerPoint 形状/对象的大小。有时这些数据只是数据表，但有时它会选择图表和随附的数据表（因此决定导出为增强型元文件）。

我已在下面粘贴我的代码，问题似乎发生在“关闭宽高比”部分，因为我能够将链接的元文件粘贴到 PowerPoint 中，但宽高比锁定保持打开状态并且粘贴的项目与 PowerPoint 中所选项目的大小/位置不匹配。

值得注意的是，我对 VBA 相对缺乏经验，但过去确实使用过它。

Sub ExportToPPT()

Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim PPO As PowerPoint.ShapeRange

' Reference instance of PowerPoint
On Error Resume Next
' Check whether PowerPoint is running
Set PPApp = GetObject(, "PowerPoint.Application")
If PPApp Is Nothing Then
    MsgBox "You need to have powerpoint open and an object selected to use this macro"
    Exit Sub
End If
On Error GoTo 0

' Reference presentation and slide
On Error Resume Next
If PPApp.Windows.Count > 0 Then
    ' There is at least one presentation
    ' Use existing presentation
    Set PPPres = PPApp.ActivePresentation
    ' Use active slide
    Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
    Set PPO = PPPres.Slides(PPApp.ActiveWindow.Selection.ShapeRange(1))
    x = PPApp.ActiveWindow.Selection.ShapeRange(1).Name
    xx = PPApp.ActiveWindow.Selection.ShapeRange(1).Left
    xy = PPApp.ActiveWindow.Selection.ShapeRange(1).Top
    xh = PPApp.ActiveWindow.Selection.ShapeRange(1).Height
    xw = PPApp.ActiveWindow.Selection.ShapeRange(1).Width
    PPApp.ActiveWindow.Selection.ShapeRange(1).Delete
    'Debug.Print x
End If
On Error GoTo 0

On Error GoTo Whoops

' Copy the range as a picture

Excel.Selection.Copy

Application.Wait (Now + TimeValue("00:00:02"))

' Paste the range
PPSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile, Link:=msoTrue).Select

' Turn off aspect ratio
Dim oSh As PowerPoint.Shape
With PPApp.ActiveWindow.Selection
For Each oSh In .ShapeRange
   oSh.LockAspectRatio = False
Next
End With


' Position pasted chart
PPApp.ActiveWindow.Selection.ShapeRange.Left = xx
PPApp.ActiveWindow.Selection.ShapeRange.Top = xy
PPApp.ActiveWindow.Selection.ShapeRange.Height = xh
PPApp.ActiveWindow.Selection.ShapeRange.Width = xw
PPApp.ActiveWindow.Selection.ShapeRange.ZOrder (msoSendToBack)

' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing

Exit Sub

Whoops:
MsgBox "An error occurred; the transfer was not successful. Please recheck your 
selections in both PowerPoint and Excel and try again.", , "Error copying Excel Chart"

End Sub

Answer 1

这对我有用：

Sub ExportToPPT()

    Dim PPApp As PowerPoint.Application
    Dim PPPres As PowerPoint.Presentation
    Dim PPSlide As PowerPoint.Slide, ppObj As Object, ppObj2 As Object
    Dim t, l, w, h
    
    On Error Resume Next
    Set PPApp = GetObject(, "PowerPoint.Application")
    On Error GoTo 0
    If PPApp Is Nothing Then
        MsgBox "You need to have powerpoint open and an object selected to use this macro"
        Exit Sub
    Else
        If PPApp.Windows.Count = 0 Then
            MsgBox "No open powerpoint file!"
            Exit Sub
        End If
    End If
    
    Set PPPres = PPApp.ActivePresentation
    Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
    Set ppObj = PPApp.ActiveWindow.Selection.ShapeRange(1)
    With ppObj
        l = .Left
        t = .Top
        h = .Height
        w = .Width
        .Delete
    End With
    
    Excel.Selection.Copy
    Application.Wait (Now + TimeValue("00:00:02"))

    'Get the pasted shape object
    '  `PasteSpecial` returns `ShapeRange`, so get the first item
    Set ppObj2 = PPSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile, Link:=msoTrue)(1)
    With ppObj2
        .LockAspectRatio = msoFalse
        .Left = l
        .Top = t
        .Height = h
        .Width = w
        .ZOrder msoSendToBack
    End With

End Sub