有没有办法从Excel中复制形状并将它们粘贴为Powerpoint中相同的形状类型？

基本上，我试图在Excel中使用一个范围来自动生成一组PowerPoint中的自定义布局。遵循此代码，我可以循环遍历预定义范围内的所有形状，将预定义范围内的所有形状复制到新创建的演示文稿中的自定义布局。有没有办法从Excel中复制形状并将它们粘贴为Powerpoint中相同的形状类型？

我的问题是它从Excel复制到Powerpoint的任何东西都变成图片而不是形状。

这里是我的代码的一部分：

Dim WS As Worksheet 
Dim PPT As Object 
Dim PRES As Object 
Dim PPTlay As Object 
Dim shp As Shape 
Dim r as Range 

Set WS = ActiveWorksheet 
Set r = WS.Range("A1:L36") 

'New PPT Presentation 
On Error Resume Next 

Set PPT = GetObject(class:="PowerPoint.Application") 

On Error GoTo 0 

If PPT Is Nothing Then Set PPT = CreateObject(class:="PowerPoint.Application") 

Set PRES = PPT.Presentations.Add 
PRES.PageSetup.SlideSize = ppSlideSizeOnScreen 

'Delete all layouts in slideMaster 
For i = PRES.SlideMaster.CustomLayouts.Count To 1 Step -1 
    PRES.SlideMaster.CustomLayouts(i).Delete 
Next i 

'Create new custom layout 
Set PPTlay = PRES.SlideMaster.CustomLayouts.Add(PRES.SlideMaster.CustomLayouts.Count + 1) 

'Delete all placeholders and shapes on newly created custom layout 
For i = PPTlay.Shapes.Count To 1 Step -1 
    PPTlay.Shapes(i).Delete 
Next i 

'Loop through all shape in Excel range "r" 
'Copy/paste to powerpoint custom Layout 
For Each shp In WS.Shapes 
    If Not Intersect(WS.Range(shp.TopLeftCell, shp.BottomRightCell), r) Is Nothing Then 
     shp.Select 
     Selection.Copy 
     PPTlay.Shapes.Paste 
     i = PPTlay.Shapes.Count 
     PPTlay.Shapes(i).LEFT = shp.LEFT 
     PPTlay.Shapes(i).TOP = shp.TOP 
    End If 
Next shp

我也试图在选择范围内的所有形状，选择复制，然后将其粘贴在演示文稿，但发生同样的问题。

任何暗示都会受到欢迎。

谢谢！

来源

2017-07-11 Max

尝试

PPTlay.Shapes.PasteSpecial DataType:= ppPasteShape

，而不是

PPTlay.Shapes.Paste

来源

2017-07-12 11:45:20 ZebraOnWheels

感谢您的答复！不幸的是，当我尝试它时，我得到一个错误['-2147188160（80048240）Shapes.PasteSpecial：无效的请求。指定的数据类型不可用。]为了确保它不是由一个特定形状触发的，我使用了On Error Resume Next。但不是形状被复制到演示文稿。 – Max

有没有办法从Excel中复制形状并将它们粘贴为Powerpoint中相同的形状类型？

回答

相关问题