如何将图像从excel复制到Shape of PPT？

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

但是PPT在执行PasteSpecial之后退出。

如何将图像从excel复制到Shape of PPT？

Answer 1

不确定是否会有所不同，但我想明确说明从Excel到PowerPoint使用VBA时所指的对象类型：

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文件的位置）。通过“作品”，我的意思是将图形/图像/形状从excel复制到PowerPoint，而之后Powerpoint不会关闭

Answer 2

这似乎是一个计时问题。它会咬伤某些人/某些PC，而不会咬伤其他人/某些PC。您粘贴形状，然后在PPT仍在处理请求时尝试对其进行处理，因此“执行此操作”部分失败。

通常的解决方法是给它一些额外的时间，然后尝试一些额外的时间：

在模块的声明部分中，包括以下内容：

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中将图像粘贴到指定的形状中，请注意以下事项：

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

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

请注意，我已经更改了路径和幻灯片/形状索引。

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工作表：

然后将输出滑动，将图像粘贴到适当的图像占位符中：