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

时间：2017-02-01 20:18:32

标签： excel vba excel-vba powerpoint powerpoint-vba

我正在编写一个代码，使用Excel文档中的数据从Excel VBA创建PowerPoint。在本文档中，我有一张名为IMG的Sheet，其中有一系列名为“Picture 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

2 个答案:

答案 0 :(得分：0)

善于避免＆＃34;选择＆＃34;物体。我真正选择的唯一一次是当我故意将用户引导到标签/单元格时。

那怎么样：

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
祝你好运！希望它有所帮助！

答案 1 :(得分：0)

使用以下代码从Excel工作表中复制图像（不Select），然后将其粘贴到PowerPoint幻灯片中。

注意：我假设您设置PowerPoint演示文稿的部分，并且设置pptSlide适用于您，唯一剩下的就是复制＆gt;＆gt;粘贴图像。

代码 

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

额外（更安全的模式）：如果您要遍历“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
相关问题
最新问题