如何将excel中的图片复制到PPT的Shape中？

Question

我试试这段代码，从excel复制到ppt:

  Dim presentation As Object
  Set ppt = CreateObject("PowerPoint.Application")
  Set presentation = ppt.Presentations.Open2007("D:\temp.pptx", MsoTriState.msoFalse, MsoTriState.msoFalse, MsoTriState.msoTrue)

 Dim oSlide As Object        
 Set oSlide = presentation.Slides(7)
 Dim oSheet As Worksheet
 Set oSheet = ThisWorkbook.Sheets(2)
 Dim oImageOb As Object
 Set oImageOb = oSheet.Shapes(1)
 oImageOb.Copy

 oSlide.Shapes.PasteSpecial DataType:=2

但是执行PasteSpecial后PPT退出.

如何将图片从excel复制到PPT的Shape中？

Answer 1

不确定它是否有所作为，但我想明确说明在使用 VBA 从 Excel 到 PowerPoint 时我指的是哪种对象：

Dim presentation As PowerPoint.Presentation
Set ppt = New PowerPoint.Application
Set presentation = ppt.Presentations.Open2007("D:\temp.pptx", MsoTriState.msoFalse, MsoTriState.msoFalse, MsoTriState.msoTrue)

Dim oSlide As Object        
Set oSlide = presentation.Slides(7)
Dim oSheet As Worksheet
Set oSheet = ThisWorkbook.Sheets(2)
Dim oImageOb As Object
Set oImageOb = oSheet.Shapes(1)
oImageOb.Copy

oSlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile

这段代码对我来说工作正常（当然只是替换 PPT-file 的位置）。 "works"，我的意思是 figure/image/shape 从 excel 复制到 powerpoint，之后 powerpoint 没有关闭

Answer 2

这似乎是一个时间问题。它会咬一些 people/some 个人电脑而不是其他人。您粘贴形状，然后在 PPT 仍在处理请求时尝试对其执行某些操作，因此 "do something wit it" 部分失败。

通常的解决方法是多给它一点时间，多试几次：

在您模块的声明部分，包括：

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

这是针对 32 位 PowerPoint 的；让它在 64 位 PPT 或两者中工作是可能的，但不同线程的主题。

然后在你的子程序中粘贴形状的部分，尝试粘贴几次，每次尝试之间暂停一下：

Dim oShp as Shape
Dim x as Long

On Error Resume Next

For x = 1 to 3 ' or whatever number you want to try
  Set oShp = oSlide.Shapes.PasteSpecial DataType:=2
  Sleep(1000)  ' Adjust this as needed
  If Not oShp is Nothing Then
    Exit For
  End If
Next

If oShp is Nothing Then
  ' It didn't work.
  ' Do whatever you need to do to recover
End If

On Error GoTo YourRegularErrorHandler
' Which you should add

Answer 3

为了将图像粘贴到 PowerPoint 中的指定形状，有一些注意事项：

形状必须是允许图像的类型，例如某些内容占位符。您不能将图像插入文本框、图表占位符等。
形状必须 Selected。虽然我们习惯于告诉人们 avoid using Select or Activate in Excel VBA，但在 PowerPoint 和 Word 中，某些操作只能在对象处于视图 and/or 选中时执行。为了Select形状，我们需要Select幻灯片。

我已经通过将变量声明移到顶部清理了您的过程，并修改了 path/slide 索引等。我创建了一个新变量 pptShape，我们将使用它处理幻灯片上的特定形状实例。

请注意，我已经更改了路径和 slide/shape 索引。

Option Explicit

Sub foo()
Dim ppt As Object 'PowerPoint.Application
Dim oSlide As Object 'PowerPoint.Slide
Dim pptShape As Object 'PowerPoint.Shape
Dim oImageOb As Object
Dim oSheet As Worksheet
Dim pres As Object 'PowerPoint.Presentation

Set ppt = CreateObject("PowerPoint.Application")
Set pres = ppt.Presentations.Open2007("c:\debug\empty ppt.pptx", MsoTriState.msoFalse, MsoTriState.msoFalse, MsoTriState.msoTrue)
Set oSlide = pres.Slides(3)

Set oSheet = ThisWorkbook.Sheets(1)  ' ## MODIFY AS NEEDED
Set oImageOb = oSheet.Shapes(1)      ' ## MODIFY AS NEEDED
oImageOb.Copy

Set pptShape = oSlide.Shapes(1)      ' ## MODIFY AS NEEDED

'## to preserve aspect ratio and prevent stretching/skewing image:
pptShape.Width = oImageOb.Width
pptShape.Height = oImageOb.Height

' ## Select the slide
oSlide.Select
' ## Selct the shape
' ## NOTE: This shape MUST be of a type that contains a picture frame, otherwise
'          an error will occur
pptShape.Select

' ## All of the following methods work for me:
'ppt.CommandBars.ExecuteMso "PasteJpeg"
'ppt.CommandBars.ExecuteMso "PasteBitmap"
'ppt.CommandBars.ExecuteMso "PasteAsPicture"
ppt.CommandBars.ExecuteMso "Paste"


End Sub

这是我的 Excel sheet 图片：

和输出，将图像粘贴到适当的图像占位符中：

如何将excel中的图片复制到PPT的Shape中？

How can I copy an image from excel to a Shape of PPT?

excel

powerpoint

vba