Dim newPowerPoint As PowerPoint.Application
Dim activeSlide As PowerPoint.Slide
Dim cht As Excel.ChartObject
On Error Resume Next
Set newPowerPoint = GetObject(, "PowerPoint.Application")
On Error GoTo 0
If newPowerPoint Is Nothing Then
Set newPowerPoint = New PowerPoint.Application
End If
If newPowerPoint.Presentations.Count = 0 Then
newPowerPoint.Presentations.Add
End If
newPowerPoint.Visible = True
For Each cht In ActiveSheet.ChartObjects
newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText
newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)
cht.Select
ActiveChart.ChartArea.Copy
activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select
activeSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 15
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 125
activeSlide.Shapes(2).Width = 200
activeSlide.Shapes(2).Left = 505
If InStr(activeSlide.Shapes(1).TextFrame.TextRange.Text, "US") Then
activeSlide.Shapes(2).TextFrame.TextRange.Text = Range("J7").Value & vbNewLine
activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J8").Value & vbNewLine)
ElseIf InStr(activeSlide.Shapes(1).TextFrame.TextRange.Text, "Renewable") Then
activeSlide.Shapes(2).TextFrame.TextRange.Text = Range("J27").Value & vbNewLine
activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J28").Value & vbNewLine)
activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J29").Value & vbNewLine)
End If
activeSlide.Shapes(2).TextFrame.TextRange.Font.Size = 16
Next
AppActivate ("PowerPoint")
Set activeSlide = Nothing
Set newPowerPoint = Nothing
it my code on windown but when i run it on macos. newPowerPoint.ActivePresentation.Slides.Add has stuck on 2-3 minutes in here, sometime activeSlide.Shapes.PasteSpecial Compile error: Method or data member not found. on excel on macos haven't PasteSpecical, so I change it to myslide.Shapes.Paste.Select but it wrong and stuck overtime somebody can help me how to convert excel to powerpoint from excel pls. thanks to read...!
Related
In a PowerPoint Presentation there are two sections. The idea is to
1.Add a new slide to each section.
2.Move the slide to the end of that section.
The code that I have so far works with the slide in the first section, but not with the second section. With the second new slide it gets moved to the end of the first section...
Any help how to find a solution for this is much appreciated!
Sub AddSlidesAtEndOfSection()
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Slide
Dim sldCount As Integer
Dim SecNum As Integer
'Create an Instance of PowerPoint
On Error Resume Next
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
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
If PowerPointApp.Presentations.Count = 0 Then
Set myPresentation = PowerPointApp.Presentations.Add
With myPresentation
.PageSetup.SlideWidth = 8.5 * 72
.PageSetup.SlideHeight = 11 * 72
.SectionProperties.AddSection 1, "section one"
.SectionProperties.AddSection 2, "section two"
End With
Else
Set myPresentation = PowerPointApp.ActivePresentation
End If
'--------> Add Slide at end of each section <-------------
For SecNum = 1 To 2
sldCount = myPresentation.SectionProperties.SlidesCount(SecNum) 'add slide
Set mySlide = myPresentation.Slides.Add(sldCount + 1, ppLayoutBlank)
mySlide.MoveToSectionStart (SecNum)
With myPresentation.SectionProperties
SlideCount = .SlidesCount(SecNum)
FirstSecSlide = .FirstSlide(SecNum)
mySlide.MoveTo toPos:=FirstSecSlide + SlideCount - 1
End With
Next
End Sub
I was using the below code just fine on all the version of excel
- Basically I created a excel sheet with ppt look and export the sheet range to PPT.
Excel VBA to Export to PPT works fine in all versions till office 365 32bit
Its not working in 365 64 bit, Windows 10 OS
Tried the following
Checked reference - with 14,15,16 object library - works fine..
Not working on 64bit - Excel 365
Error given - "PowerPoint Not found"
Sub ExcelRangeToPPT_new_now()
'prepareppt
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.IgnoreRemoteRequests = True
Dim rng As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
'Sheets("S19").Select
'Copy Range from Excel
Set rng = ThisWorkbook.ActiveSheet.Range("A1:q36")
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
Sheets("template").Select
Set rng = ThisWorkbook.ActiveSheet.Range("A1:q36")
instfile = "Noattach"
If ActFileName = False Then
'PowerPointApp.Activate
'PowerPointApp.Presentations.Add
'Set PP_File = PowerPointApp.ActivePresentation
Else
PowerPointApp.Activate
Set myPresentation = PowerPointApp.Presentations.Open(ActFileName)
End If
Set myPresentation = PowerPointApp.Presentations.Add
Set PP_File = PowerPointApp.ActivePresentation
adddd:
DoEvents
Set rng = ThisWorkbook.ActiveSheet.Range("A1:q36")
PowerPointApp.Visible = True
'Create a New Presentation
rrr:
err.Clear
Set mySlide = PP_File.Slides.Add(1, 12) '11 = ppLayoutTitleOnly
PP_File.Slides (PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
With PP_File.PageSetup
.SlideSize = ppSlideSizeCustom
.SlideWidth = 720
.SlideHeight = 528
.FirstSlideNumber = 1
.SlideOrientation = msoOrientationHorizontal
.NotesOrientation = msoOrientationVertical
End With
rng.Copy
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
'Set position:
myShape.Left = 0
myShape.Top = 0
myShape.LockAspectRatio = msoFalse
myShape.HEIGHT = 528
myShape.WIDTH = 718
If instfile <> "Noattach" Then
Dim objPPTShape As Object
Set objPPTShape = PP_File.Slides(1).Shapes.AddOLEObject(Left:=100, Top:=100, WIDTH:=700, HEIGHT:=300, _
filename:=instfile, DisplayAsIcon:=True) 'OR Use , Filename:="E:\Documents and Settings\User\My Documents\abc.xlsm" instead of ClassName but not both
With objPPTShape
.Left = 475
.Top = 350
End With
Set objPPTShape = Nothing
End If
PowerPointApp.Visible = True
PowerPointApp.Activate
Application.CutCopyMode = False
PowerPointApp.PageSetup.SlideOrientation = msoOrientationHorizontal
sht = sht - 1
If sht = 1 Then Sheets("template").Select: GoTo ttre
instfile = "Noattach"
If sht = 2 Then Sheets("S2").Select: GoTo adddd
ttre:
Sheets("main").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.IgnoreRemoteRequests = False
MsgBox "PPT Created Sucessfully.. Kindly review it before saving it.. "
Exit Sub
err:
Debug.Print "Error No.: " & err.Number & vbNewLine & vbNewLine & "Description: " & err.Description, vbCritical, "Error"
If err.Number = -2147467259 Then
MsgBox "Error Occured - Check if the Files to be embedded or the destination PPT is in the same folder as that of the Excel file..."
End If
If err.Number = 462 Then
Set PP_File = PowerPointApp.Presentations.Add
GoTo rrr
End If
If err.Number = 16 Then
MsgBox "Check if the Excel Files to be embedded is in the same folder.."
End
End If
End Sub
I have a similar issue with Excel and the On Error Resume Next code. Although I use it sparingly (I prefer to experience all the errors and handle them appropriately) it can be useful in some limited situations. I have found ways to rethink some code, in your for example you show this:
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")
I would recode this piece as follows:
bPPOpen = GetObject(class:="PowerPoint.Application")
If bPPOpen Then
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
Else bPPOpen = False Then
Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
Endif
Using this technique you never have to attempt to SET the object unless you know it's available. Further, since you are not using a raised error you don't have to deal with some of the error 'clean up'.
Answer: TL;DR: pasting a chart with embedded data takes a long time so you have to install a delay to prevent vba from moving on before the paste operation completes.
Question:I'm trying to paste an excel chart with embedded data into a powerpoint presentation. The only thing I am getting hung up on is referring to and positioning the chart in ppt once it has been pasted.
Dim newPowerPoint As PowerPoint.Application
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveChart.ChartArea.Copy
newPowerPoint.CommandBars.ExecuteMso ("PasteExcelChartDestinationTheme")
Since I need to paste multiple charts into single slides, repositioning them is necessary. I try to do that with this piece of code:
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 0
but am always met with the error: "Method 'ShapeRange' of object 'Selection' failed".
What's particularly odd is that running the code from start to finish results in this error, but stepping through the code using the F8 key does not.
I have tried every way I can think of to move this chart around but I am totally stuck. Does anyone know how I can do this? Also, please keep in mind that is necessary that the chart have data in it (I can't paste the chart as a picture and I would strongly prefer that the data not be linked).
Thanks,
Steve
edit new modified code with multiple chart objects. I needed to add an if conditional:
If activeSlide.Shapes.Count = 1 Then
GoTo NextiLoop
End If
for additional chart objects because the delay pasting chart 2 makes the loop name chart 1 "pptcht2" since chart2 did not exist yet.
Sub CreatePPT()
Dim newPowerPoint As PowerPoint.Application
Dim activeSlide As PowerPoint.Slide
Dim cht1 As Excel.ChartObject
Dim Data As Excel.Worksheet
Dim pptcht1 As PowerPoint.Shape
Dim iLoopLimit As Long
Application.ScreenUpdating = False
'Look for existing instance
On Error Resume Next
Set newPowerPoint = GetObject(, "PowerPoint.Application")
On Error GoTo 0
'Let's create a new PowerPoint
If newPowerPoint Is Nothing Then
Set newPowerPoint = New PowerPoint.Application
End If
'Make a presentation in PowerPoint
If newPowerPoint.Presentations.Count = 0 Then
newPowerPoint.Presentations.Add
End If
'Show the PowerPoint
newPowerPoint.Visible = True
Application.ScreenUpdating = False
'Add a new slide where we will paste the chart
newPowerPoint.ActivePresentation.Slides.Add _
newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText
newPowerPoint.ActiveWindow.View.GotoSlide _
newPowerPoint.ActivePresentation.Slides.Count
Set activeSlide = newPowerPoint.ActivePresentation.Slides _
(newPowerPoint.ActivePresentation.Slides.Count)
activeSlide.Shapes(1).Delete
activeSlide.Shapes(1).Delete
'ActiveSheet.ChartObjects("Chart 1").Activate
Set Data = ActiveSheet
Set cht1 = Data.ChartObjects("Share0110")
Set cht2 = Data.ChartObjects("SOW0110")
Set cht3 = Data.ChartObjects("PROP0110")
cht1.Copy
newPowerPoint.CommandBars.ExecuteMso "PasteExcelChartDestinationTheme"
DoEvents
On Error Resume Next
Do
DoEvents
Set pptcht1 = activeSlide.Shapes(activeSlide.Shapes.Count)
If Not pptcht1 Is Nothing Then Exit Do
iLoopLimit = iLoopLimit + 1
If iLoopLimit > 100 Then Exit Do
Loop
On Error GoTo 0
Debug.Print "iLoopLimit = " & iLoopLimit
With pptcht1
.Left = 25
.Top = 150
End With
iLoopLimit = 0
'ActiveSheet.ChartObjects("Chart 2").Activate
'Set Data = ActiveSheet
cht2.Copy
newPowerPoint.CommandBars.ExecuteMso "PasteExcelChartDestinationTheme"
DoEvents
On Error Resume Next
Do
DoEvents
If activeSlide.Shapes.Count = 1 Then
GoTo NextiLoop
End If
Set pptcht2 = activeSlide.Shapes(activeSlide.Shapes.Count)
If Not pptcht2 Is Nothing Then Exit Do
NextiLoop:
iLoopLimit = iLoopLimit + 1
If iLoopLimit > 100 Then Exit Do
Loop
On Error GoTo 0
Debug.Print "iLoopLimit = " & iLoopLimit
With pptcht2
.Left = 275
.Top = 150
End With
iLoopLimit = 0
AppActivate ("Microsoft PowerPoint")
Set activeSlide = Nothing
Set newPowerPoint = Nothing
End Sub
edit: OLD not working code:
Sub CreatePPT()
Dim newPowerPoint As PowerPoint.Application
Dim activeSlide As PowerPoint.Slide
Dim cht As Excel.ChartObject
Application.ScreenUpdating = False
'Look for existing instance
On Error Resume Next
Set newPowerPoint = GetObject(, "PowerPoint.Application")
On Error GoTo 0
'Let's create a new PowerPoint
If newPowerPoint Is Nothing Then
Set newPowerPoint = New PowerPoint.Application
End If
'Make a presentation in PowerPoint
If newPowerPoint.Presentations.Count = 0 Then
newPowerPoint.Presentations.Add
End If
'Show the PowerPoint
newPowerPoint.Visible = True
Application.ScreenUpdating = False
'Add a new slide where we will paste the chart
newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText
newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)
activeSlide.Shapes(1).Delete
activeSlide.Shapes(1).Delete
'ActiveSheet.ChartObjects("Chart 1").Activate
Set Data = ActiveSheet
Set cht1 = Data.ChartObjects("Chart 1")
cht1.Copy
newPowerPoint.CommandBars.ExecuteMso ("PasteExcelChartDestinationTheme")
Set pptcht1 = newPowerPoint.ActiveWindow.Selection
With pptcht1
.Left = 0
End With
AppActivate ("Microsoft PowerPoint")
Set activeSlide = Nothing
Set newPowerPoint = Nothing
End Sub
Do yourself a favor and enter this as the first line of the code module:
Option Explicit
This will force you to declare all variables. You have a lot of undeclared variables, including a couple that are almost the same as the few you did declare. Then go to VBA's Tools menu > Options, and check the Require Variable Declaration on the first tab of the dialog, which will put Option Explicit at the top of every new module.
Declare the shape as a PowerPoint.Shape, then find it using this, since any newly added shape is the last one on the slide:
Set pptcht1 = activeSlide.Shapes(activeSlide.Shapes.Count)
The following line first of all does not need the parentheses, despite the poorly written Microsoft Help article. Second, it takes a long time to run. Excel is already trying to move the shape long before the shape has been created. DoEvents is supposed to help with this by making Excel wait until everything else happening on the computer is finished, but the line is still too slow.
newPowerPoint.CommandBars.ExecuteMso ("PasteExcelChartDestinationTheme")
So I cobbled together a little loop that tries to set the variable to the shape, and keeps looping until the shape is finished being created.
On Error Resume Next
Do
DoEvents
Set pptcht1 = activeSlide.Shapes(activeSlide.Shapes.Count)
If Not pptcht1 Is Nothing Then Exit Do
iLoopLimit = iLoopLimit + 1
If iLoopLimit > 100 Then Exit Do
Loop
On Error GoTo 0
In a small number of tests, I found that the loop would have to run 20 to 60 times. I also crashed PowerPoint a few times. Weird.
I'm sure there are better ways to paste the copied chart and keep the slide's color theme, but off the top of my head I don't know one.
This is unreliable, since the application caption changes with different versions of Office (and again the parentheses are not needed):
AppActivate ("Microsoft PowerPoint")
Use this instead:
AppActivate newPowerPoint.Caption
So your whole code becomes:
` Sub CreatePPT()
Dim newPowerPoint As PowerPoint.Application
Dim activeSlide As PowerPoint.Slide
Dim cht1 As Excel.ChartObject
Dim Data As Excel.Worksheet
Dim pptcht1 As PowerPoint.Shape
Dim iLoopLimit As Long
Application.ScreenUpdating = False
'Look for existing instance
On Error Resume Next
Set newPowerPoint = GetObject(, "PowerPoint.Application")
On Error GoTo 0
'Let's create a new PowerPoint
If newPowerPoint Is Nothing Then
Set newPowerPoint = New PowerPoint.Application
End If
'Make a presentation in PowerPoint
If newPowerPoint.Presentations.Count = 0 Then
newPowerPoint.Presentations.Add
End If
'Show the PowerPoint
newPowerPoint.Visible = True
Application.ScreenUpdating = False
'Add a new slide where we will paste the chart
newPowerPoint.ActivePresentation.Slides.Add _
newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText
newPowerPoint.ActiveWindow.View.GotoSlide _
newPowerPoint.ActivePresentation.Slides.Count
Set activeSlide = newPowerPoint.ActivePresentation.Slides _
(newPowerPoint.ActivePresentation.Slides.Count)
activeSlide.Shapes(1).Delete
activeSlide.Shapes(1).Delete
'ActiveSheet.ChartObjects("Chart 1").Activate
Set Data = ActiveSheet
Set cht1 = Data.ChartObjects("Chart 1")
cht1.Copy
newPowerPoint.CommandBars.ExecuteMso "PasteExcelChartDestinationTheme"
DoEvents
On Error Resume Next
Do
DoEvents
Set pptcht1 = activeSlide.Shapes(activeSlide.Shapes.Count)
If Not pptcht1 Is Nothing Then Exit Do
iLoopLimit = iLoopLimit + 1
If iLoopLimit > 100 Then Exit Do
Loop
On Error GoTo 0
Debug.Print "iLoopLimit = " & iLoopLimit
With pptcht1
.Left = 0
End With
AppActivate newPowerPoint.Caption
Set activeSlide = Nothing
Set newPowerPoint = Nothing
End Sub`
I'm trying to make a PP slideshow from an Excel spreadsheet. I have this VBA module:
Sub CreatePowerPointQuestions()
Dim newPowerPoint As PowerPoint.Application
Dim activeSlide As PowerPoint.Slide
Dim Question As String
Dim Options As String
Dim Answer As String
Dim limit As Integer
limit = 3
On Error Resume Next
Set newPowerPoint = GetObject(, "PowerPoint.Application")
On Error GoTo 0
If newPowerPoint Is Nothing Then
Set newPowerPoint = New PowerPoint.Application
End If
'Make a presentation in PowerPoint
If newPowerPoint.Presentations.Count = 0 Then
newPowerPoint.Presentations.Add
End If
'Show the PowerPoint
newPowerPoint.Visible = True
'Select worksheet and cells activate
Worksheets("Sheet1").Activate
'Loop through each question
For i = 1 To limit
'Add a new slide where we will paste the Question and Options:
newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, 3
newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)
'Set the variables to the cells
Question = ActiveSheet.Cells(i, 1).Value
Options = ActiveSheet.Cells(i, 2).Value
Answer = ActiveSheet.Cells(i, 3).Value
activeSlide.Shapes(1).TextFrame.TextRange.Text = Question
activeSlide.Shapes(2).TextFrame.TextRange.Text = Options
activeSlide.Shapes(3).TextFrame.TextRange.Text = Answer
Next
Set activeSlide = Nothing
Set newPowerPoint = Nothing
End Sub
The problem is that it creates slides with a title and two entries side by side with a bullet. I want the slide to be three lines, without the bullets. Is there a way to do this? I don't know how to do the layouts
There is a list of layouts that you can use at https://msdn.microsoft.com/en-us/library/office/ff745137.aspx
However, only two of them match your criteria
ppLayoutObjectOverText, and
ppLayoutTextOverObject
Try this after your Set activeslide line:
activeSlide.layout = ppLayoutObjectOverText
I'm currently working on a macro in excel for mac 2011. The goal of the macro is to copy charts and range in power point slide. However, whenever I try to set the position using the .Left property, it reset the value of said property to zero. I don't why i does that. Maybe it's because I'm using a mac edition. But I can't seem to find someone with the same issue as me. Could you help me to correct to code I'm using if there's an error or at least try to find a workaround? I appreciate any help from you guys.
Here my code :
Option Explicit
Sub Presentation()
Application.ScreenUpdating = False
'Variable
Dim i As Integer
Dim tot As Integer
Dim newPowerPoint As PowerPoint.Application
Dim activeSlide As PowerPoint.slide
Dim cht As Excel.ChartObject
Dim tbl As Range
Dim sChart As Chart
tot = InputBox("Saisir le nombre de slide voulu : ", "Nombre de Slides")
i = 1
On Error Resume Next
Set newPowerPoint = GetObject(, "PowerPoint.Application")
On Error GoTo 0
'Create a power point
If newPowerPoint Is Nothing Then
Set newPowerPoint = New PowerPoint.Application
End If
'Create presentation
If newPowerPoint.Presentations.Count = 0 Then
newPowerPoint.Presentations.Add
End If
'Show presentation
newPowerPoint.Visible = True
'Loops through each worksheet named 1 , 2 ...
While i <= tot
'Activate the i worksheet
Worksheets(CStr(i)).Activate
'Add a slide
newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutTitleOnly
newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)
'Get title
activeSlide.Shapes(1).TextFrame.TextRange.Text = Range("A1").Value
'Ajust title position
activeSlide.Shapes(1).Left = 0
activeSlide.Shapes(1).Top = 0
'Loops through each charts in the sheet
For Each cht In ActiveSheet.ChartObjects
cht.Select
'Copie/Colle le graphique
ActiveChart.ChartArea.Copy
activeSlide.Shapes.Paste.Select
'Ajust the chart's position to bottom right
With newPowerPoint.ActiveWindow.Selection.ShapeRange
.Align msoAlignRights, msoTrue
.Align msoAlignBottoms, msoTrue
End With
Next
'Copy / Paste the range
Set tbl = ActiveSheet.Range("B1").CurrentRegion
tbl.Offset(1, 0).Resize(tbl.Rows.Count - 1, tbl.Columns.Count).Select
Selection.Copy
With activeSlide.Shapes.Paste
'HERE'S THE PROBLEM
.Width = 300 'The value of width is now set to 0 instead of 300
.Height = 300 'The value of height is now set to 0 instead of 300
.Left = 720 'The value of left is now set to 0 instead of 720
.Top = 888 'The value of top is now set to 0 instead of 888
End With
i = i + 1
Wend
Application.ScreenUpdating = True
AppActivate ("Microsoft PowerPoint")
Set activeSlide = Nothing
Set newPowerPoint = Nothing
End Sub
Please help me, I can't seem to find any solution and please excuse me if I'm not clear enough because I am french and english isn't my natural language.
Thanks in advance
Try this:
'paste
activeSlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
Set activeSlideShapeRange = activeSlide.Shapes(activeSlide.Shapes.Count)
'position:
activeSlide.Left = 234
activeSlide.Top = 186
'empty clipboard
Application.CutCopyMode = False
HTH