无法在 PowerPoint 中调整形状大小和位置

Question

我正在编写一个 VBA 脚本，它可以将一些范围从 Excel 文档复制到 PowerPoint 文档。我能够成功地做到这一点而没有任何错误。但是，在复制范围后，当我调整大小并重新对齐形状时，我无法这样做。我可能遗漏了什么？

我在单独的文件中定义了 Excel、幻灯片编号和主要 Excel sheet 的范围。所以到目前为止，我正在从那个单独的文件中获取所有值。

Option Explicit

Sub ExportToPPT()

    Dim ppt_app As New PowerPoint.Application
    Dim pre As PowerPoint.Presentation
    Dim slide As PowerPoint.slide
    Dim shp As PowerPoint.Shape
    Dim wb As Workbook
    Dim rng As Range

    Dim vSheet$
    Dim vRange$
    Dim vWidth As Double
    Dim vHeight As Double
    Dim vTop As Double
    Dim vLeft As Double

    Dim expRng As Range
    Dim vslidenum As Long

    Dim Adminsh As Worksheet
    Dim configRng As Range

    Dim xlfile$
    Dim pptfile$

    Application.DisplayAlerts = False
    Set Adminsh = ThisWorkbook.Sheets("Admin")
    ' "RangeLoop" is the loop range where we are defining the sheets
    Set configRng = Adminsh.Range("RangeLoop")

    xlfile = Adminsh.[ExcelPath]
    pptfile = Adminsh.[PPTPath]

    Set wb = Workbooks.Open(xlfile)
    Set pre = ppt_app.Presentations.Open(pptfile)

    wb.Activate

    For Each rng In configRng

        ' Pick values from the Excel sheet --------------------------------

        With Adminsh
            vSheet$ = .Cells(rng.Row, 2).Value
            vRange$ = .Cells(rng.Row, 3).Value

            vWidth = .Cells(rng.Row, 4).Value
            vHeight = .Cells(rng.Row, 5).Value
            vTop = .Cells(rng.Row, 6).Value
            vLeft = .Cells(rng.Row, 7).Value
            vslidenum = .Cells(rng.Row, 8).Value
        End With

        wb.Activate
        Sheets(vSheet$).Activate
        Set expRng = Sheets(vSheet$).Range(vRange$)
        expRng.Copy

        ' Paste values in PowerPoint-----------------------------------------------
        Set slide = pre.Slides(vslidenum)
        'ppt_app.Activate
        slide.Shapes.PasteSpecial ppPasteBitmap
        'ppt_app.ActiveWindow.View.PasteSpecial ppPasteOLEObject, msoFalse
        'slide.Shapes.PasteSpecial DataType:=ppPasteBitmap, Link:=msoFalse
        Set shp = slide.Shapes(1)

        With shp
            .Top = vTop
            .Left = vLeft
            .Width = vWidth
            .Height = vHeight
        End With

        Application.CutCopyMode = False
        Set shp = Nothing
        Set slide = Nothing

        ' The line below is showing an error (compile error)
        'Application.CutCopyMode = False
        'Application.CutCopyMode = False

        'aPPLICATION.CU
        Set expRng = Nothing

    Next rng

    pre.Save

    'pre.Close

    Set pre = Nothing
    Set ppt_app = Nothing
    Set expRng = Nothing
    wb.Close False
    Set wb = Nothing

    Application.DisplayAlerts = True

End Sub

Answer 1

我认为您可能使用常量索引 1 引用了错误的形状。

Set shp = slide.Shapes(1)

您插入的形状可能会在列表的末尾。

尝试这样做：

Set shp = slide.Shapes(slide.Shapes.Count)

Answer 2

您可以一次完成，而不是先粘贴然后指定形状...

这是一个例子

Set shp = slide.Shapes.PasteSpecial(ppPasteBitmap)

With shp
    '~~> Do what you want
End With

无法在 PowerPoint 中调整形状大小和位置

Not able to resize and position shapes in PowerPoint

excel

powerpoint

vba