Hello I am try to copy an image from excel into powerpoint. My code already copy and pastes into excel but I am having an issue with the code that would automate the resizing. With this current code I get object required Runtime error 424. Any help would be appreciated. MY abbreviated code is below.
Sub CopyDataToPPT()
'Const ppLayoutBlank = 12
Dim objWorkSheet As Worksheet
Dim objRange As Range
Dim objPPT As PowerPoint.Application
Dim objPresentation As Presentation
Dim shapePPTOne As Object
Dim intLocation As Integer
Dim intHeight As Integer
Dim inLayout As Integer
Dim strRange As String
Dim boolOK As Boolean
Set objPPT = CreateObject("PowerPoint.Application")
Set objPresentation = objPPT.Presentations.Add
'First 1 Xor 2 charts
If Sheets("Summary Table").Cells(15, 4) <> "Not Found" Then
strRange = "B4:N24"
intHeight = 380
Else
strRange = "B4:N13"
intHeight = 190
End If
Set objslide = objPresentation.Slides.Add(1, inLayout)
objPresentation.Slides(1).Layout = ppLayoutTitleOnly
objPresentation.Slides(1).Shapes.Title.TextFrame.TextRange.Text = Sheets("Summary Table").Cells(2, 5) & " - " & Sheets("Summary Table").Cells(4, 2)
Set objRange = Sheets("Summary Table").Range(strRange)
objRange.Copy
DoEvents
Set shapePPTOne = objslide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile, Link:=msoFalse)
shapePPTOne.Height = intHeight
shapePPTOne.Left = 50
shapePPTOne.Top = 100
Application.CutCopyMode = False
Next intLocation
This (a simplified version of your code) works fine for me:
Sub CopyDataToPPT()
Dim objslide
Dim objRange As Range
Dim objPPT As PowerPoint.Application
Dim objPresentation As Presentation
Dim shapePPTOne As Object
Set objPPT = CreateObject("PowerPoint.Application")
Set objPresentation = objPPT.Presentations.Add
Set objslide = objPresentation.Slides.Add(1, ppLayoutTitleOnly) 'you had inLayout???
objslide.Shapes.Title.TextFrame.TextRange.Text = "blah blah"
Sheets("Sheet1").Range("C6:G22").Copy
DoEvents
Set shapePPTOne = objslide.Shapes.PasteSpecial( _
DataType:=ppPasteEnhancedMetafile, Link:=msoFalse)
With shapePPTOne
.Height = 200
.Left = 50
.Top = 100
End With
Application.CutCopyMode = False
End Sub
Related
The code runs without fault on a clear blank PowerPoint slide, but when i try Ind add multiple images from excel to PPT onto the same slide it loses its set positioning and formatting and goes to full scale on image 2,3 etc. and unable to identify the course.
Please find the code below which is used to run the script
enter code here
'app
' pre
' slide
' shapes
' text frame
' text
Sub ExporttoPPT()
```
Dim ppt_app As New PowerPoint.Application
Dim pre As PowerPoint.Presentation
Dim slde As PowerPoint.Slide
Dim shp As PowerPoint.Shape
Dim wb As Workbook
Dim rng As Range
Dim vSheet$
Dim vRange$
Dim vWidth As Double
Dim vHeight As Double
Dim vTop As Double
Dim vLeft As Double
Dim vSlide_No As Long
Dim expRng As Range
Dim adminSh As Worksheet
Dim cofigRng As Range
Dim xlfile$
Dim pptfile$
Application.DisplayAlerts = False
Set adminSh = ThisWorkbook.Sheets("Admin")
Set cofigRng = adminSh.Range("Rng_sheets")
xlfile = adminSh.[excelPth]
pptfile = adminSh.[pptPth]
Application.DisplayAlerts = False
Set wb = Workbooks.Open(xlfile, False, True)
Application.DisplayAlerts = False
Set pre = ppt_app.Presentations.Open(pptfile)
For Each rng In cofigRng
'----------------- set VARIABLES
With adminSh
vSheet$ = .Cells(rng.Row, 4).Value
vRange$ = .Cells(rng.Row, 5).Value
vWidth = .Cells(rng.Row, 6).Value
vHeight = .Cells(rng.Row, 7).Value
vTop = .Cells(rng.Row, 8).Value
vLeft = .Cells(rng.Row, 9).Value
vSlide_No = .Cells(rng.Row, 10).Value
End With
'----------------- EXPORT TO PPT
wb.Activate
Sheets(vSheet$).Activate
Set expRng = Sheets(vSheet$).Range(vRange$)
expRng.Copy
' Stop
pre.Application.Activate
Set slde = pre.Slides(vSlide_No)
'Application.ActiveWindow.Panes(vSlide_No).Activate
slde.Select
slde.Shapes.PasteSpecial ppPasteBitmap 'ppPasteSecial' ppPasteBitmap
Set shp = slde.Shapes(1)
With shp
.Top = vTop
.Left = vLeft
.Width = vWidth
.Height = vHeight
End With
Set shp = Nothing
Set slde = Nothing
Set expRng = Nothing
Application.CutCopyMode = False
Set expRng = Nothing
Next rng
'pre.Save
'pre.Close
Set pre = Nothing
Set ppt_app = Nothing
wb.Close False
Set wb = Nothing
Application.DisplayAlerts = True
End Sub``
Your problem is that you use always the very first shape when you set the position properties: You write Set shp = slde.Shapes(1).
One solution is to use the last shape instead (new created shapes are put at the end of the collection):
slde.Shapes.PasteSpecial ppPasteBitmap
Set shp = slde.Shapes(slde.shapes.count)
Or you use the return value of PasteSpecial. However, the return value is a ShapeRange (a group of shapes). As in your case the group contains only one shape, you can use
Set shp = slde.Shapes.PasteSpecial(ppPasteBitmap)(1)
I found some code on how to copy and paste a tablet from Excel to PPT, but I keep running into the error 9 'out of range'. It's my first time working with VBA, so I'm not too sure how to fix it.
Here is the code:
Sub ExporttoPPT()
Dim ppt_app As New PowerPoint.Application
Dim pre As PowerPoint.Presentation
Dim slde As PowerPoint.slide
Dim shp As PowerPoint.shape
Dim wb As Workbook
Dim rng As Range
Dim chrt As ChartObject
Dim vSheet$
Dim vRange$
Dim vChart$
Dim vWidth As Double
Dim vHeight As Double
Dim vTop As Double
Dim vLeft As Double
Dim vSlide_No As Long
Dim ShpCount As Integer
Dim expRng As Range
Dim expChart As ChartObjects
Dim adminSh As Worksheet
Dim configRng As Range
Dim configChart As Range
Dim xlfile$
Dim pptfile$
Application.DisplayAlerts = False
Set adminSh = ThisWorkbook.Sheets("Admin")
Set configRng = adminSh.Range("Rng_Sheets")
Set configChart = adminSh.Range("Chart_Sheets")
xlfile = adminSh.[excelPth]
pptfile = adminSh.[pptPth]
Set wb = Workbooks.Open(xlfile)
Set pre = ppt_app.Presentations.Open(pptfile, msoFalse)
For Each rng In configRng
With adminSh
vSheet$ = .Cells(rng.Row, 6).Value
vRange$ = .Cells(rng.Row, 7).Value
vWidth = .Cells(rng.Row, 8).Value
vHeight = .Cells(rng.Row, 9).Value
vTop = .Cells(rng.Row, 10).Value
vLeft = .Cells(rng.Row, 11).Value
vSlide_No = .Cells(rng.Row, 12).Value
End With
wb.Activate
Sheets(vSheet$).Activate
Set expRng = Sheets(vSheet$).Range(vRange$)
expRng.Copy
Set slde = pre.Slides(vSlide_No)
slde.Shapes.PasteSpecial DataType:=ppPasteOLEObject, Link:=msoTrue
ShpCount = slde.Shapes.Count
Set shp = slde.Shapes(ShpCount)
With shp
.Top = vTop
.Left = vLeft
.Width = vWidth
.Height = vHeight
End With
Set shp = Nothing
Set slde = Nothing
Set expRng = Nothing
Application.CutCopyMode = False
Set expRng = Nothing
Next rng
pre.Save
pre.Close
Set pre = Nothing
Set ppt_app = Nothing
wb.Close False
Set wb = Nothing
Application.DisplayAlerts = True
End Sub
The VBA debugger says it is to do with the following line:
Sheets(vSheet$).Activate
Any help would be highly appreciated!!!
Thank you!
Oliver
wb.Activate
Sheets(vSheet$).Activate
Set expRng = Sheets(vSheet$).Range(vRange$)
expRng.Copy
Set slde = pre.Slides(vSlide_No)
slde.Shapes.PasteSpecial DataType:=ppPasteOLEObject, Link:=msoTrue
May not fix your problem but here's a refactored version combining your two loops into one. Missing any error checking such as ensuring worksheets/chartobjects etc actually exist before trying to access them.
'Declare a Type to hold the various configuration details for a copy/paste/move/size step
'All config is stored in one table with columns as indicated below
Type Settings
Type As String 'need one new column in your table for this
Sheet As String 'source worksheet
Source As String 'range address or chartobject name
Width As Double 'settings for sizing/location...
Height As Double
Top As Double
Left As Double
Slide As Long 'destination slide index
End Type
Sub ExporttoPPT()
Dim ppt_app As New PowerPoint.Application
Dim pres As PowerPoint.Presentation, ws As Worksheet
Dim config As Settings, wb As Workbook, adminSh As Workbook, configRng As Range, rw As Range
Application.DisplayAlerts = False
Set adminSh = ThisWorkbook.Sheets("Admin")
Set rw = adminSh.Range("SettingsRow1") '<< first row of settings in the config table
Set wb = Workbooks.Open(adminSh.[excelPth])
Set pres = ppt_app.Presentations.Open(adminSh.[pptPth], msoFalse)
Do While Application.CountA(rw) > 0 'loop each row in the config table while not blank
config = GetSettings(rw) 'get the configuration from this row
Set ws = wb.Sheets(config.Sheet)
With pres.Slides(config.Slide) 'destination slide
Select Case config.Type 'what kind of thing are we copying?
Case "Range"
ws.Range(config.Source).Copy
.Shapes.PasteSpecial DataType:=ppPasteOLEObject, Link:=msoTrue
Case "Chart"
ws.ChartObjects(config.Source).Copy 'or eg CopyPicture
.Shapes.PasteSpecial DataType:=ppPasteOLEObject, Link:=msoTrue
End Select
With .Shapes(.Shapes.Count) 'position and size the pasted shape
.Top = config.Top
.Left = config.Left
.Width = config.Width
.Height = config.Height
End With
End With
Set rw = rw.Offset(1, 0)
Loop
'clean up
pres.Save
pres.Close
ppt_app.Quit
wb.Close False
Application.DisplayAlerts = True
End Sub
'populate and return a `Settings` variable from a row
Function GetSettings(rw As Range) As Settings
Dim rv As Settings
rv.Type = rw.Cells(1).Value
rv.Sheet = rw.Cells(2).Value
rv.Source = rw.Cells(3).Value
rv.Width = rw.Cells(4).Value
rv.Height = rw.Cells(5).Value
rv.Top = rw.Cells(6).Value
rv.Left = rw.Cells(7).Value
rv.Slide = rw.Cells(8).Value
GetSettings = rv
End Function
I am working on a VBA script which copies some ranges from an Excel document to a PowerPoint document. I am able to do that successfully without any errors. However, after copying the range, when I resize and realign the shapes, I am not able to do so. What might I be missing?
I have defined the ranges of the Excel, slide numbers and the main Excel sheet in a separate file. So as of now, I am taking all the values from that separate file.
Option Explicit
Sub ExportToPPT()
Dim ppt_app As New PowerPoint.Application
Dim pre As PowerPoint.Presentation
Dim slide As PowerPoint.slide
Dim shp As PowerPoint.Shape
Dim wb As Workbook
Dim rng As Range
Dim vSheet$
Dim vRange$
Dim vWidth As Double
Dim vHeight As Double
Dim vTop As Double
Dim vLeft As Double
Dim expRng As Range
Dim vslidenum As Long
Dim Adminsh As Worksheet
Dim configRng As Range
Dim xlfile$
Dim pptfile$
Application.DisplayAlerts = False
Set Adminsh = ThisWorkbook.Sheets("Admin")
' "RangeLoop" is the loop range where we are defining the sheets
Set configRng = Adminsh.Range("RangeLoop")
xlfile = Adminsh.[ExcelPath]
pptfile = Adminsh.[PPTPath]
Set wb = Workbooks.Open(xlfile)
Set pre = ppt_app.Presentations.Open(pptfile)
wb.Activate
For Each rng In configRng
' Pick values from the Excel sheet --------------------------------
With Adminsh
vSheet$ = .Cells(rng.Row, 2).Value
vRange$ = .Cells(rng.Row, 3).Value
vWidth = .Cells(rng.Row, 4).Value
vHeight = .Cells(rng.Row, 5).Value
vTop = .Cells(rng.Row, 6).Value
vLeft = .Cells(rng.Row, 7).Value
vslidenum = .Cells(rng.Row, 8).Value
End With
wb.Activate
Sheets(vSheet$).Activate
Set expRng = Sheets(vSheet$).Range(vRange$)
expRng.Copy
' Paste values in PowerPoint-----------------------------------------------
Set slide = pre.Slides(vslidenum)
'ppt_app.Activate
slide.Shapes.PasteSpecial ppPasteBitmap
'ppt_app.ActiveWindow.View.PasteSpecial ppPasteOLEObject, msoFalse
'slide.Shapes.PasteSpecial DataType:=ppPasteBitmap, Link:=msoFalse
Set shp = slide.Shapes(1)
With shp
.Top = vTop
.Left = vLeft
.Width = vWidth
.Height = vHeight
End With
Application.CutCopyMode = False
Set shp = Nothing
Set slide = Nothing
' The line below is showing an error (compile error)
'Application.CutCopyMode = False
'Application.CutCopyMode = False
'aPPLICATION.CU
Set expRng = Nothing
Next rng
pre.Save
'pre.Close
Set pre = Nothing
Set ppt_app = Nothing
Set expRng = Nothing
wb.Close False
Set wb = Nothing
Application.DisplayAlerts = True
End Sub
I think you're probably referencing the wrong shape using the constant index 1.
Set shp = slide.Shapes(1)
The shape you inserted will probably be at the end of the list.
Try doing this instead:
Set shp = slide.Shapes(slide.Shapes.Count)
Instead of pasting and then assigning the shape, you can do that in one go...
Here is an example
Set shp = slide.Shapes.PasteSpecial(ppPasteBitmap)
With shp
'~~> Do what you want
End With
I am using Office 365 on a Windows 10 64-bit pc.
I have a Word document with a table into which I want to copy elements from an Excel document. The elements are a) text from its cell, b) a hyperlink from its cell and c) images from a list of images.
The first two tasks are performed successfully by the following sub:
Sub ImportFromExcel()
Dim RowNo As Long, RowTarget As Long
Dim RowFirst As Long, RowLast As Long
Dim strContent As String, strLink As String, strDisplay As String
Dim xlAppl As New Excel.Application
Dim xlBook As New Excel.Workbook
Dim xlSheet As New Excel.Worksheet
Dim ExcelFileName As String
Dim tbl As Word.Table
On Error GoTo Finish
ExcelFileName = "C:\MyPath\MyExcelDoc.xlsm"
Set xlAppl = CreateObject("Excel.Application")
xlAppl.Application.Visible = False
xlAppl.Workbooks.Open ExcelFileName
Set xlBook = xlAppl.ActiveWorkbook
Set xlSheet = xlBook.Worksheets("Titan")
Set tbl = ActiveDocument.Tables(1)
RowFirst = 6: RowLast = 19
For RowNo = RowFirst To RowLast
RowTarget = RowNo - RowFirst + 1
strContent = xlSheet.Cells(RowNo, 5).Value
tbl.Cell(RowTarget, 1).Range.Text = strContent
strDisplay = xlSheet.Cells(RowNo, 3).Value
tbl.Cell(RowTarget, 3).Range.Text = strContent
strLink = xlSheet.Cells(RowNo, 3).Hyperlinks(1).Address
InsertHyperlinkInTable tbl, RowTarget, 3, strLink, strDisplay
' CopyImageFromExcelToWord xlSheet, RowTarget, tbl
Next RowNo
Finish:
xlAppl.ActiveWorkbook.Close False ' Word will not freeze at this point
xlAppl.Quit
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlAppl = Nothing
End Sub
I copy the hyperlink by reading its address and caption and then recreating it in Word.
Also from Word I can select a give image by way of its index using the first two active lines of the following sub:
Sub CopyImageFromExcelToWord(xlSheet As Excel.Worksheet, imgNo As Long, tbl As Word.Table)
Dim strId As String
' Syntax at https://learn.microsoft.com/en-us/office/vba/api/excel.worksheet.select
strId = "Picture " & CStr(2 * imgNo)
xlSheet.Shapes.Range(Array(strId)).Select
' Missing link !
With tbl.Cell(1, 4)
.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
.VerticalAlignment = wdCellAlignVerticalCenter
.Select
End With
Selection.PasteAndFormat (wdFormatOriginalFormatting)
End Sub
An image residing in the clipboard can be inserted into Word using the last six lines.
But I have not found out how to copy the image I selected in the Excel document to the clipboard with a Word macro.
Can this be done somehow?
Can the copying of the hyperlink be performed in a smarter way?
Try
Sub CopyImageFromExcelToWord(xlSheet As Excel.Worksheet, imgNo As Long, tbl As Word.Table)
Dim strId As String
' Syntax at https://learn.microsoft.com/en-us/office/vba/api/excel.worksheet.select
strId = "Picture " & CStr(2 * imgNo)
xlSheet.Shapes.Range(Array(strId)).Item(1).Copy
With tbl.Cell(1, 4)
.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
.VerticalAlignment = wdCellAlignVerticalCenter
.Range.PasteAndFormat wdFormatOriginalFormatting
End With
End Sub
I am trying to prepare a presentation from Excel. As of now VBA code is preparing "n number of "presentations as per no of times Loop runs. I want Code to generate just 1 presentation with all slides combined. Fist Macro "Addnumber" is run, which run Macro "ExcelRangeToPowerPoint". Its Macro "ExcelRangeToPowerPoint"which need to add slides for every loop of Macro "Addnumber"
Please Support
Sub AddNumber()
Dim Ws As Worksheet
Dim rngSel As Range
Dim rng As Range
Dim Num As Double
Dim i As Long
Dim j As Long
Dim lAreas As Long
Dim lRows As Long
Dim lCols As Long
Dim Arr() As Variant
Set rngSel = Worksheets("Sheet1").Range("A5:A30")
Do Until Range("A30") = Range("A3")
Num = 26
For Each rng In rngSel.Areas
If rng.Count = 1 Then
rng = rng + Num
Else
lRows = rng.Rows.Count
lCols = rng.Columns.Count
Arr = rng
For i = 1 To lRows
For j = 1 To lCols
Arr(i, j) = Arr(i, j) + Num
Next j
Next i
rng.Value = Arr
End If
Call ExcelRangeToPowerPoint
Next rng
Loop
End Sub
Sub ExcelRangeToPowerPoint()
'PURPOSE: Copy/Paste An Excel Range Into a New PowerPoint Presentation
Dim rng As Range
Dim rng2 As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
Dim mySize As PageSetup
Dim Addtitle As Shape
Dim DateT As String
'Copy Range from Excel
Set rng = Worksheets("Sheet1").Range("E2:M30")
Set rng2 = Worksheets("Sheet1").Range("F2")
Set rng3 = Worksheets("Sheet1").Range("B3")
'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then open PowerPoint
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
'Optimize Code
Application.ScreenUpdating = False
'Create a New Presentation
Set myPresentation = PowerPointApp.Presentations.Add
'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(1, 11)
'11 = ppLayoutTitleOnly
'Change Theme and Layout
mySlide.ApplyTheme "C:\Users\davinder.sond\AppData\Roaming\Microsoft\Templates\Document Themes\DefaultTheme.thmx"
myPresentation.PageSetup.SlideSize = 3
myPresentation.Slides(1).Shapes.Title.TextFrame.TextRange.Text = rng2
myPresentation.Slides(1).Shapes.Title.Left = 59
myPresentation.Slides(1).Shapes.Title.Top = 10
myPresentation.Slides(1).Shapes.Title.Height = 30
myPresentation.Slides(1).Shapes.Title.Width = 673
With myPresentation.Slides(1).Shapes.Title
With .TextFrame.TextRange.Font
.Size = 24
.Name = "Arial"
.Bold = True
.Color.RGB = RGB(255, 255, 255)
End With
End With
'Copy Excel Range
rng.Copy
'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
'Set position:
myShape.LockAspectRatio = 0
myShape.Left = 12
myShape.Top = 55
myShape.Height = 475
myShape.Width = 756
'Make PowerPoint Visible and Active
PowerPointApp.Visible = True
PowerPointApp.Activate
DateT = Format("h:mm:ss")
'Clear The Clipboard
Application.CutCopyMode = False
myPresentation.SaveAs "C:\Project Control CCJV\ExperimentsPunch\" & rng3 & ".pptm"
PowerPointApp.Quit
End Sub
You are creating a new presentation everytime you call Set myPresentation = PowerPointApp.Presentations.Add within ExcelRangeToPowerPoint().
You can either try to open/close the Presentation outside of ExcelRangeToPowerPoint() and add a parameter to the function like ExcelRangeToPowerPoint(myPresentationObject) then you can simple add the slides there
or
you call the function AddNumber() within ExcelRangeToPowerPoint() of coarse the you need to loop there...
e.g.
Sub ExcelRangeToPowerPoint()
' some preparative code
'Create a New Presentation
Set myPresentation = PowerPointApp.Presentations.Add
'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(1, 11)
For Each rng in rngSel.Areas
'Filling the presentation one slide at a time
AddSlide(rng)
Next
'Clear The Clipboard
Application.CutCopyMode = False
myPresentation.SaveAs "C:\Project Control CCJV\ExperimentsPunch\" & rng3 &
".pptm"
PowerPointApp.Quit
'some more code
End Sub