Excel To PPT VBA编码

Question

代码在清晰的空白PowerPoint幻灯片上无故障运行，但当我尝试将多幅图像从excel添加到PPT到同一张幻灯片时，它将失去其设置的位置和格式，并在图像2、3等上全面显示，无法识别该过程。

请查找下面用于运行脚本的代码

enter code here

'app
'  pre
'   slide
'    shapes
'     text frame
'      text

Sub ExporttoPPT()

Dim ppt_app作为新的PowerPoint.Application

Dim pre PowerPoint.Presentation

昏暗的泥泞如PowerPoint.Slide

像PowerPoint.Shape一样的昏暗

Dim wb作为工作簿

昏暗范围

Dim vSheet$

Dim vRange

Dim vWidth为双倍

Dim vHeight为双倍

Dim vTop为双倍

Dim vLeft为双倍

Dim vSlide_No等长

Dim expRng为范围

Dim adminSh作为工作表

Dim cofigRng为范围

Dim xlfile$

Dim pptfile$

Application.DisplayAlerts = False

设置adminSh =ThisWorkbook.Sheets(“管理”)

设置cofigRng = adminSh.Range("Rng_sheets")

xlfile = adminSh.excelPth

pptfile = adminSh.pptPth

Application.DisplayAlerts = False

设置wb = Workbooks.Open(xlfile，False，True)

Application.DisplayAlerts = False

设置pre = ppt_app.Presentations.Open(pptfile)

对于cofigRng中的每个rng

‘

用adminSh

  vSheet$ = .Cells(rng.Row, 4).Value

  vRange$ = .Cells(rng.Row, 5).Value

  vWidth = .Cells(rng.Row, 6).Value

  vHeight = .Cells(rng.Row, 7).Value

  vTop = .Cells(rng.Row, 8).Value

  vLeft = .Cells(rng.Row, 9).Value

  vSlide_No = .Cells(rng.Row, 10).Value

  End With

-出口到PPT

        wb.Activate

        Sheets(vSheet$).Activate

        Set expRng = Sheets(vSheet$).Range(vRange$)

        expRng.Copy

“停下来

        pre.Application.Activate

        Set slde = pre.Slides(vSlide_No)

        'Application.ActiveWindow.Panes(vSlide_No).Activate

        slde.Select

        slde.Shapes.PasteSpecial ppPasteBitmap 'ppPasteSecial' ppPasteBitmap

        Set shp = slde.Shapes(1)

        With shp

           .Top = vTop

           .Left = vLeft

           .Width = vWidth

           .Height = vHeight

        End With

        Set shp = Nothing

        Set slde = Nothing

        Set expRng = Nothing

Application.CutCopyMode = False

设置expRng = Nothing

下一轮

'pre.Save

'pre.Close

Set pre = Nothing

设置ppt_app = Nothing

wb.Close假

设置wb = Nothing

Application.DisplayAlerts =真

端子

Answer 1

您的问题是，在设置位置属性时，总是使用第一个形状:编写Set shp = slde.Shapes(1)。

一种解决方案是使用最后一个形状(将新创建的形状放在集合的末尾)：

slde.Shapes.PasteSpecial ppPasteBitmap 
Set shp = slde.Shapes(slde.shapes.count)

或者使用PasteSpecial的返回值。但是，返回值是一个ShapeRange (一组形状)。在您的示例中，组只包含一个形状，您可以使用

Set shp = slde.Shapes.PasteSpecial(ppPasteBitmap)(1)