Как вставить изображения из Excel в PowerPoint VBA без использования. Метод выбора

Question

Я пишу код, который создает PowerPoint из Excel VBA, используя данные из документа Excel. В этом документе у меня есть Лист под названием IMG, где есть серия изображений под названием «Изображение X», X - номер текущего изображения. Код, который у меня есть для копирования этих изображений и вставки их на их PowerPoint Slide, использует метод .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 

Answer 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 

Удачи! Надеюсь, поможет!

Answer 2

Используйте приведенный ниже код, чтобы скопировать изображение из листа Excel (без него) и вставить его в слайд 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 (более безопасный режим): Если вы хотите перебрать все Shapes в "IMG" листа, проверьте имя каждой формы, если это "Picture 1", и только затем скопируйте этот Shape в PowerPoint Slide, затем используйте также код ниже:

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