如何在不使用 .Select 方法的情况下将图像从 Excel 粘贴到 PowerPoint VBA答案

【问题标题】：How to paste images from Excel to PowerPoint VBA without using .Select method如何在不使用 .Select 方法的情况下将图像从 Excel 粘贴到 PowerPoint VBA
【发布时间】：2017-06-18 17:46:21
【问题描述】：

我正在编写使用 Excel 文档中的数据从 Excel VBA 创建 PowerPoint 的代码。在本文档中，我有一个名为 IMG 的工作表，其中有一系列名为“图片 X”的图像，X 是当前图片的编号。我用于复制这些图片并将它们粘贴到它们各自的 PowerPoint 幻灯片上的代码使用 .Select 方法，根据我在这里阅读的内容，该方法使代码运行速度变慢，并且可以/必须是可以避免的。我想知道是否可以避免使用“.Select”方法，并且仍然能够从 excel 表中粘贴图像。

我使用的代码是：

Dim pptSlide As PowerPoint.Slide

Sheets("IMG").Select
    ActiveSheet.Shapes.Range(Array("Picture 1")).Select
    Selection.Copy

pptSlide.Shapes.PasteSpecial(ppPasteMetafilePicture).Select
pptSlide.Shapes(4).Width = 121
pptSlide.Shapes(4).Height = 51
pptSlide.Shapes(4).Left = 580
pptSlide.Shapes(4).Top = 3

谢谢

我的其余代码：

Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptShape As PowerPoint.Shape
Dim excelTable As Excel.Range
Dim SlideTitle As String
Dim SlideText As String
Dim SlideObject As Object
Dim pptTextbox As PowerPoint.Shape
Dim SlideNumber As String
Dim myPic As Object



On Error Resume Next
Set pptApp = New PowerPoint.Application


Set pptPres = pptApp.Presentations.Add
pptPres.PageSetup.SlideSize = ppSlideSizeOnScreen
pptPres.ApplyTemplate "c:\Program Files\Microsoft Office\Templates\1033\Blank.potx"

pptPres.PageSetup.FirstSlideNumber = 0

''Consolidados
Set excelTable1 = Worksheets("TDCSD").Range("N280:U287")
Set excelTable2 = Worksheets("TDEXITO").Range("N48:U55")
Set excelTable3 = Worksheets("TDGPA").Range("N81:U88")
Set excelTable4 = Worksheets("TDSACI").Range("N234:U241")
Set excelTable5 = Worksheets("TDSMU").Range("N47:U54")
Set excelTable6 = Worksheets("TDRPLY").Range("N76:U83")
Set excelTable7 = Worksheets("TDInR").Range("N44:U51")
Set excelTable8 = Worksheets("TDPA").Range("N59:U66")
Set excelTable9 = Worksheets("TDIRSA").Range("N31:U38")
Set excelTable10 = Worksheets("TCOM").Range("Q8:AC17")
Set excelTable11 = Worksheets("TCOM").Range("Q24:AC33")


'SLIDES

'Slide 0

Set pptSlide = pptPres.Slides.Add(1, ppLayoutTitle)

SlideTitle = ThisWorkbook.Sheets("PPT").Range("F7").Value
pptSlide.Shapes(1).TextFrame.TextRange.Text = SlideTitle

pptSlide.Shapes.Title.TextFrame.TextRange.Characters(Start:=36, Length:=65).Font.Size = 20
pptSlide.Shapes.Title.Width = 610

pptSlide.Shapes(2).TextFrame.TextRange.Text = ThisWorkbook.Sheets("PPT").Range("B7").Value

'Agregar el número de diapositiva en la esquina derecha:
Set pptTextbox = pptSlide.Shapes.AddTextbox( _
    msoTextOrientationHorizontal, 686, 510, 34, 29)

With pptTextbox.TextFrame
    .TextRange.InsertSlideNumber
    .TextRange.Font.Size = 8
    .TextRange.Font.Name = "Tahoma"
    .TextRange.Font.Color = RGB(137, 137, 137)
    .VerticalAnchor = msoAnchorMiddle
End With



'Slide 1:

Set pptSlide = pptPres.Slides.Add(2, ppLayoutCustom)
SlideTitle = "Introducción"
pptSlide.Shapes.Title.TextFrame.TextRange.Text = SlideTitle
pptSlide.Shapes.Title.TextFrame.TextRange.Font.Size = 22


Set pptTextbox = pptSlide.Shapes(1)

pptTextbox.TextFrame.TextRange.Text = ThisWorkbook.Sheets("PPT").Range("B11").Value
pptTextbox.Top = 88
pptTextbox.TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignJustify

'Agregar el número de diapositiva:
Set pptTextbox = pptSlide.Shapes.AddTextbox( _
    msoTextOrientationHorizontal, 686, 510, 34, 29)

With pptTextbox.TextFrame
    .TextRange.InsertSlideNumber
    .TextRange.Font.Size = 8
    .TextRange.Font.Name = "Tahoma"
    .TextRange.Font.Color = RGB(137, 137, 137)
    .VerticalAnchor = msoAnchorMiddle
End With




'Slide 2:
Set pptSlide = pptPres.Slides.Add(3, ppLayoutTitleOnly)
SlideTitle = "Agenda"
pptSlide.Shapes.Title.TextFrame.TextRange.Text = SlideTitle
pptSlide.Shapes.Title.TextFrame.TextRange.Font.Size = 22

Set pptTextbox = pptSlide.Shapes.AddTextbox( _
    msoTextOrientationHorizontal, 686, 510, 34, 29)

With pptTextbox.TextFrame
    .TextRange.InsertSlideNumber
    .TextRange.Font.Size = 8
    .TextRange.Font.Name = "Tahoma"
    .TextRange.Font.Color = RGB(137, 137, 137)
    .VerticalAnchor = msoAnchorMiddle
End With


'Slide 3:
''Crear Slide y añadir título
Set pptSlide = pptPres.Slides.Add(4, ppLayoutCustom)
SlideTitle = "Noticias Relevantes"
pptSlide.Shapes.Title.TextFrame.TextRange.Text = SlideTitle
pptSlide.Shapes.Title.TextFrame.TextRange.Font.Size = 22

''Insertar el texto desde Excel
Set pptTextbox = pptSlide.Shapes(1)

pptTextbox.TextFrame.TextRange.Text = ThisWorkbook.Sheets("PPT").Range("B24").Value
pptTextbox.Top = 68.8
pptTextbox.TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignJustify

''Añadir número de Slide
Set pptTextbox = pptSlide.Shapes.AddTextbox( _
    msoTextOrientationHorizontal, 686, 510, 34, 29)

With pptTextbox.TextFrame
    .TextRange.InsertSlideNumber
    .TextRange.Font.Size = 8
    .TextRange.Font.Name = "Tahoma"
    .TextRange.Font.Color = RGB(137, 137, 137)
    .VerticalAnchor = msoAnchorMiddle
End With

'Añadir imagenes
'Falabella
Sheets("IMG").Shapes("Picture 1").Copy
pptSlide.Shapes.PasteSpecial(ppPasteMetafilePicture).Select
pptSlide.Shapes(4).Width = 121
pptSlide.Shapes(4).Height = 51
pptSlide.Shapes(4).Left = 579.4
pptSlide.Shapes(4).Top = 3.4


'Slide 4:
''Crear Slide y añadir el título
Set pptSlide = pptPres.Slides.Add(5, ppLayoutCustom)
SlideTitle = "Noticias Relevantes"
pptSlide.Shapes.Title.TextFrame.TextRange.Text = SlideTitle
pptSlide.Shapes.Title.TextFrame.TextRange.Font.Size = 22

''Añadir texto
Set pptTextbox = pptSlide.Shapes(1)

pptTextbox.TextFrame.TextRange.Text = ThisWorkbook.Sheets("PPT").Range("B49").Value
pptTextbox.Top = 77
pptTextbox.TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignJustify

''Añadir número de Slide
Set pptTextbox = pptSlide.Shapes.AddTextbox( _
    msoTextOrientationHorizontal, 686, 510, 34, 29)

With pptTextbox.TextFrame
    .TextRange.InsertSlideNumber
    .TextRange.Font.Size = 8
    .TextRange.Font.Name = "Tahoma"
    .TextRange.Font.Color = RGB(137, 137, 137)
    .VerticalAnchor = msoAnchorMiddle
End With

''Añadir imagenes
'Grupo Éxito
Sheets("IMG").Shapes("Picture 2").Copy

pptSlide.Shapes.PasteSpecial (ppPasteMetafilePicture)
pptSlide.Shapes(4).Width = 108
pptSlide.Shapes(4).Height = 65
pptSlide.Shapes(4).Left = 592
pptSlide.Shapes(4).Top = 1.42

【问题讨论】：

标签： vba excel powerpoint

【解决方案1】：

很好地避免“选择”对象。我真正选择的唯一一次是当我有意将用户引导到选项卡/单元格时。

那么这个怎么样：

Dim s As Shape
Dim ws As Worksheet

Set ws = ThisWorkbook.Worksheets("IMG")
Set s = ws.Shapes("Picture 1")

s.Copy

当然，您可以遍历工作表上的每个形状：

for each s in ws.shapes
  debug.print s.name
  s.copy
  'Code for pasting the image
next s

祝你好运！希望对您有所帮助！

【讨论】：

【解决方案2】：

使用下面的代码从 Excel 工作表中复制图像（不使用Selecting），并将其粘贴到 PowerPoint 幻灯片中。

注意：我假设您设置 PowerPoint 演示文稿的部分，设置 pptSlide 适合您，剩下的唯一事情就是 复制 >> 粘贴图片。

代码

Option Explicit

Sub CopyPic_to_PPT()

Dim pptSlide As PowerPoint.Slide
Dim myPic   As Object                                                     

Sheets("IMG").Shapes("Picture 1").Copy '<-- copy the "Picture 1" image from "IMG" worksheet

' set myPic to current pasted shape in PowerPoint
Set myPic = pptSlide.Shapes.PasteSpecial(ppPasteMetafilePicture, msoFalse)

' modify current pic setting
With myPic
    .Width = 121
    .Height = 51
    .Left = 580
    .Top = 3
End With

End Sub

Extra（更安全的模式）：如果要遍历“IMG”工作表中的所有Shapes，请检查每个形状的名称是否为“图片1”，然后才复制此形状到 PowerPoint 幻灯片，然后也使用下面的代码：

Dim CurShape As Object

' loop through all shapes in "IMG" worksheet
For Each CurShape In Sheets("IMG").Shapes
    If CurShape.Name Like "Picture 1" Then ' if current shape's name = "Picture 1", then copy
        CurShape.Copy
        Exit For
    End If
Next CurShape

【讨论】：

谢谢。这很有帮助。但唯一的问题是定位不适合“With”功能。不知道为什么
你复制了我的整个代码并且定位不起作用？你有错误吗？还是没有重新定位？
不，我为我的代码图像复制了您的代码（这是一个很长的代码，并且还有其他可能影响这一点的东西）。它没有给我一个错误，但是当我打开 ppt 时，图像没有定位
@thePB 你能分享你剩下的代码吗？我使用了这段代码并且它有效。它将小图像放在幻灯片的顶部。你知道一英寸是 72 磅吗？
@thePB 我在您编辑的代码中看不到 Set myPic = pptSlide.Shapes.PasteSpecial(ppPasteMetafilePicture, msoFalse) 部分，您复制 Sheets("IMG").Shapes("Picture 1").Copy 后是否复制了这一行？