如何在不使用 .Select 方法的情况下将 Excel 中的图像粘贴到 PowerPoint VBA [英] How to paste images from Excel to PowerPoint VBA without using .Select method

问题描述

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

I am writing a code that creates a PowerPoint from Excel VBA, using data from the Excel document. In this document, i have a Sheet called IMG where there is a series of images named "Picture X", X being the number of the current picture. The code I have for copying these pictures and pasting them on their respective PowerPoint Slide uses the .Select method, which, according to what I have read around here, makes the code run slower, and can/must be avoidable. I want to know if it is possible to avoid using the ".Select" method and still be able to paste the images from the excel sheet.

我使用的代码是:

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

推荐答案

使用以下代码从 Excel 工作表中复制图像(无需选择)，并将其粘贴到 PowerPoint 幻灯片.

Use the code below to copy an Image from Excel worksheet (without Selecting it), and paste it to a PowerPoint Slide.

注意:我假设您设置 PowerPoint 演示文稿的部分和设置 pptSlide 对您有用，剩下的就是复制 >>粘贴图片.

Note: I assume the part you set-up your PowerPoint presentation, and setting pptSlide works for you, and the only thing left is Copy >> Paste the image.

代码

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，请检查每个形状的名称是否为Picture 1"，然后然后将此形状复制到 PowerPoint 幻灯片，然后也使用下面的代码:

Extra (the safer mode): If you want to loop through all Shapes in "IMG" worksheet, check each shape's name if it's "Picture 1", and only then copy this Shape to PowerPoint Slide, then use also the piece of code below:

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

这篇关于如何在不使用 .Select 方法的情况下将 Excel 中的图像粘贴到 PowerPoint VBA的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！