时间戳

首页 > 解决方案 > 如何在 Powerpoint 中使用 VBA 调整第二张图片的大小？

excel - 如何在 Powerpoint 中使用 VBA 调整第二张图片的大小？

问题描述

我设法通过 VBA 从 Excel 获取图片到 Powerpoint。这种方法效果很好。但是，我想重新定位和调整第二张图片的大小。

你能帮帮我吗？

Sub ExceltoPP()

Dim pptPres As Presentation     
Dim strPath As String           
Dim strPPTX As String           
Dim pptApp As Object



    strPath = "D:\"
    strPPTX = "Test.pptx"       

    Set pptApp = New PowerPoint.Application

    pptCopy = strPath & strPPTX

    pptApp.Presentations.Open Filename:=pptCopy, untitled:=msoTrue

    Set pptPres = pptApp.ActivePresentation   

    Sheets("NEW").Range("Table").CopyPicture xlScreen, xlPicture
    pptPres.Slides(2).Select
    pptPres.Slides(2).Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile

    Set Graphic = GetObject(, "Powerpoint.Application")
    With Graphic.ActiveWindow.Selection.ShapeRange
      .Left = 0.39 * 72
      .Top = 2 * 72
      .Width = 5 * 72
      .Height = 2 * 72
    End With

直到这部分它工作得很好。但是，当我尝试添加第二张图片时，Powerpoint 添加了图片，但重新定位和调整大小不起作用。

Sheets("NEW").Range("A1:M14").CopyPicture xlScreen, xlPicture
    pptPres.Slides(2).Select
    pptPres.Slides(2).Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile

    Set Graphic2 = GetObject(, "Powerpoint.Application")
    With Graphic2.ActiveWindow.Selection.ShapeRange
      .Left = 0.39 * 72
      .Top = 5 * 72
      .Width = 5 * 72
      .Height = 2 * 72
    End With


    pptPres.SaveAs strPath & Range("company") & ".pptx"  
    pptPres.Close      
    pptApp.Quit
    Set pptPres = Nothing
    Set pptApp = Nothing

End Sub

标签： excelvbapowerpoint

解决方案

正如 BigBen 所建议的，您可以按索引引用所需的形状。但是，不需要调用 GetObject。尝试...

Sheets("NEW").Range("A1:M14").CopyPicture xlScreen, xlPicture
With pptPres.Slides(2)
    .Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
    With .Shapes(.Shapes.Count) 'refers to last pasted shape
        .Left = 0.39 * 72
        .Top = 5 * 72
        .Width = 5 * 72
        .Height = 2 * 72
    End With
End With

但是，您的代码可以重写如下...

'Force the explicit declaration of variables
Option Explicit

Sub ExceltoPP()

    Dim pptApp As PowerPoint.Application
    Dim pptPres As PowerPoint.Presentation
    Dim strPath As String
    Dim strPPTX As String
    Dim pptCopy As String

    strPath = "D:\"
    strPPTX = "Test.pptx"

    pptCopy = strPath & strPPTX

    Set pptApp = New PowerPoint.Application

    Set pptPres = pptApp.Presentations.Open(Filename:=pptCopy, untitled:=msoTrue)

    Sheets("NEW").Range("Table").CopyPicture xlScreen, xlPicture
    With pptPres.Slides(2)
        .Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
        With .Shapes(.Shapes.Count) 'refers to last pasted shape
            .Left = 0.39 * 72
            .Top = 2 * 72
            .Width = 5 * 72
            .Height = 2 * 72
        End With
    End With

    Sheets("NEW").Range("A1:M14").CopyPicture xlScreen, xlPicture
    With pptPres.Slides(2)
        .Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
        With .Shapes(.Shapes.Count) 'refers to last pasted shape
            .Left = 0.39 * 72
            .Top = 5 * 72
            .Width = 5 * 72
            .Height = 2 * 72
        End With
    End With

    pptPres.SaveAs strPath & Range("company").Value & ".pptx"
    pptPres.Close
    pptApp.Quit

    Set pptPres = Nothing
    Set pptApp = Nothing

End Sub

推荐阅读