I am trying to mass-generate a series of PowerPoint presentations. My slide would contain two elements, both created and copied from Excel. I am using Office 2010.
The first element is a SmartArt graphic which is smoothly done. The second one is a few cells that I would like to copy as a Table object (instead of a linked image). After wasting a few hours with "Shapes", I found this, but I cannot manipulate its height and width after pasting.
PPApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
Then, when I tried to save the presentation using the following, I realised only the SmartArt is saved; the pasted table is not saved even though the saveAs command occured after the paste.
PPApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
PPPres.SaveAs saveName, ppSaveAsDefault
PPPres.Close
More bizarrely, I found that when I added a msgbox command for debugging above between paste and save, the table is saved correctly. However, I am trying to mass produce these files and cannot sit down to close each message box.
My questions:
1. How can I change the table's height/width/alignment after pasting?
2. How can I save my file with the table in it?
EDITED, my current code
Sub copyAllToPpt()
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim PPName, xlName As String
xlName = ActiveWorkbook.Name
Dim saveName As String
Workbooks(xlName).Activate
Dim y As Integer
y = ActiveCell.Row
saveName = ActiveSheet.Cells(y, "B").Value & "-" & ActiveSheet.Cells(y, "A").Value & " Stats"
Set PPApp = CreateObject("Powerpoint.Application")
PPApp.Visible = True
Set PPPres = PPApp.Presentations.Add
PPName = PPPres.Name
PPApp.ActiveWindow.ViewType = ppViewSlide
Set PPSlide = PPPres.Slides.Add(1, ppLayoutBlank)
createSmartArtGraphicThenCopy
PPSlide.Shapes.Paste.Select
PPApp.ActiveWindow.Selection.ShapeRange.Height = 288
PPApp.ActiveWindow.Selection.ShapeRange.Width = 641
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, msoTrue
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, msoTrue
PPApp.ActiveWindow.Selection.Unselect
'Macro is working as expected up to here
Workbooks(xlName).Activate
createTable
'Table is copied in subroutine
PPApp.Activate
PPApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
'Application.Wait (Now + TimeValue("0:00:05"))
'Tried the Wait() to no avail.
DoEvents: DoEvents: DoEvents
PPApp.ActivePresentation.SaveAs saveName, ppSaveAsDefault
PPApp.ActivePresentation.Close
End Sub
This works when I run it from within PPT; you'll need to adapt it by adding references to the PPT application object, etc:
Dim oSh As Object
Dim oSl As Object
Dim x As Long
x = 1 ' or whatever slide you want to work with
Set oSl = ActivePresentation.Slides(x)
CommandBars.ExecuteMso ("PasteSourceFormatting")
DoEvents: DoEvents: DoEvents
Set oSh = oSl.Shapes(oSl.Shapes.Count)
oSh.Left = 0
' etc
Without the DoEvents statements, it fails, in exactly the same way as your save problem fails. Unless you give PPT a few cycles to deal with the newly pasted shape, it thinks that it's not there.
Related
I need to copy chart data from hundreds of PPTX files, each having approx. 40 charts, into an Excel file. This code here runs, after some trial and error, stable, but takes about 2-3 minutes per file. I wonder if there is a faster way to extract the data from the PPTs?
Many thanks for any ideas...
Marco
Sub CopyPPTChartdataToXLS()
Dim ppApp, ppFile, ppSlide, ppShape As Object
Dim ppSlideNr, ppShapeNr As Byte
Dim wsDestination As Worksheet
Set wsDestination = ThisWorkbook.Sheets(1) 'this is the worksheet to insert the data
Set ppApp = CreateObject("PowerPoint.Application")
ppApp.Visible = True
Set ppFile = ppApp.Presentations.Open(Filename:="c:\dummyFile.pptx")
For ppSlideNr = 1 To ppFile.Slides.Count 'runs through all slides
Set ppSlide = ppFile.Slides(ppSlideNr)
For ppShapeNr = 1 To ppSlide.Shapes.Count 'runs through all shapes on slide
Set ppShape = ppSlide.Shapes(ppShapeNr)
With ppShape.Chart.ChartData.Workbook
wsDestination.Range("A2:J101").Value = .Sheets(1).Range("A1:J100").Value
.Close
End With
End If
Call DataProcessing 'sub will use the data for quality checks
Next ppShapeNr
Next ppSlideNr
Set ppSlide = Nothing
Set ppShape = Nothing
Set ppFile = Nothing
Set ppApp = Nothing
End Sub
Ive made a VBA macro that automatically creates a PowerPoint and one that creates a Worksheet named "Handlungsempfehlungen" with Text. The Worksheet "Handlungsempfehlungen" looks like this:
https://i.stack.imgur.com/nZEL8.png
It has about 40 columns (A-AO) and Text in each column from Row 1 to max. 34 (Number of rows filled with text varies each column). I now need to somehow loop through each row in each column and give each Cell.Value over to the existing (and currently opened) PowerPoint. Until now Ive used something like this to create textboxes in PowerPoint and fill them with Cell Values from Excel:
'New PPslide (copy slide 2 which is emtpy)
Set PPslide = PPapp.ActivePresentation.Slides(2).Duplicate.Item(1)
'Put new slide to end of PP
PPslide.MoveTo (PPpres.Slides.Count)
'Change title
PPslide.Shapes.Title.TextFrame.TextRange = "Slidetitle"
PPslide.Shapes(2).TextFrame.TextRange.Text = "Second title"
'Insert Textbox
Set PPtextbox = PPslide.Shapes.AddTextbox(msoTextOrientationHorizontal, Left:=40, Top:=133, Width:=875, Height:=30)
PPtextbox.TextFrame.TextRange.Text = ActiveWorkbook.Worksheets("Handlungsempfehlungen").Cells(1, 1).Value
But with 40 columns and about 30 rows per column each filled with text I would need to create about 1000 textboxes and hand them to my PowerPoint. How could I loop through this Worksheet and automatically have positions on the PowerPoint Slide set for each textbox? The slidetitle for each PowerPointslide is already saved in the Row 35 of each Column in the Worksheet (see screenshot), so I would give this over to PP inside the loop as well (for each column set slidetitle = currentColumn.Row 35 is kinda the idea)
My current Idea for all of this is I having 5 textboxes per slide with set positions, filling them with the values from row 1-5 of the first column and then create a new slide and do the same process for rows 6-10 and so on until the Cell.Value in the current column is empty, then jump one column to the right and create a new PPslide again and repeat the whole process until the whole Worksheet has been worked through. I think this seems relatively simple but I am still a beginner and have difficulties implementing this.
Would this be a good idea and how would I need to get there? Im quite bad at looping but Im happy for every answer! Thanks for your time & help!
PS: the declarations for the created PP and its Objects:
Public Shape As Object
Public PPshape As PowerPoint.Shape
Public PPapp As PowerPoint.Application
Public PPpres As PowerPoint.Presentation
Public PPslide As PowerPoint.Slide
Public PPtextbox As PowerPoint.Shape
Set PPapp = New PowerPoint.Application
PPapp.Visible = msoTrue
The following code covers two scenarios:
You have PowerPoint open with an active presentation that has a slide at the begining with a Title and 5 texboxes properly named
You have PowerPoint closed
You need to set a reference to PowerPoint object model like this:
Read code's comments and try to adjust it to fit your needs
Use the F8 key to step into the code line by line
You can also add a Stop statement so the code breaks and then use the F8 key
Public Sub TransferDataToPPT()
' Set basic error handling
On Error GoTo CleanFail
' Turn off stuff
Application.ScreenUpdating = False
Dim pptApp As PowerPoint.Application
Dim pptPresentation As PowerPoint.Presentation
Dim pptMainSlide As PowerPoint.Slide
Dim pptContentSlide As PowerPoint.Slide
Dim isNewPPTInstance As Boolean
' Open and get PowerPoint instance
Set pptApp = OpenGetPowerPoint(isNewPPTInstance)
' If it's a new instance add new presentation and main slide
If isNewPPTInstance Then
pptApp.Visible = msoTrue
Set pptPresentation = pptApp.Presentations.Add(msoTrue)
Set pptMainSlide = pptPresentation.Slides.Add(1, ppLayoutTitleOnly)
pptMainSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 150, 100, 20).Name = "Textbox1"
pptMainSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 200, 100, 20).Name = "Textbox2"
pptMainSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 250, 100, 20).Name = "Textbox3"
pptMainSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 300, 100, 20).Name = "Textbox4"
pptMainSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 350, 100, 20).Name = "Textbox5"
Else
Set pptPresentation = pptApp.ActivePresentation
Set pptMainSlide = pptPresentation.Slides(1)
End If
' Set a reference to the sheet holding the values
Dim contentSheet As Worksheet
Set contentSheet = ThisWorkbook.Worksheets("Sheet1")
' Set the Excel range to be evaluated
Dim contentRange As Range
Set contentRange = contentSheet.Range("A1:AO34")
' Start a cell counter
Dim cellCounter As Long
cellCounter = 1
' Loop through columns and cells
Dim contentColumn As Range
Dim contentCell As Range
For Each contentColumn In contentRange.Columns
For Each contentCell In contentColumn.Cells
' Skip after first blank cell
If contentCell.Value = vbNullString Then Exit For
' Add new slide every 5 cells and fill title
If cellCounter = 1 Then
Set pptContentSlide = pptPresentation.Slides(1).Duplicate()(1)
pptContentSlide.MoveTo pptPresentation.Slides.Count
pptContentSlide.Shapes.Title.TextFrame.TextRange = contentSheet.Cells(35, contentColumn.Column).Value
End If
' Add value to textbox
pptContentSlide.Shapes("Textbox" & cellCounter).TextFrame.TextRange = contentCell.Value
cellCounter = cellCounter + 1
' Reset counter
If cellCounter > 5 Then cellCounter = 1
Next contentCell
Next contentColumn
CleanExit:
' Turn on stuff again
Application.ScreenUpdating = True
If isNewPPTInstance Then
If Not pptApp Is Nothing Then
pptPresentation.SaveAs "C:\Temp\NewPPT.pptx"
pptApp.Quit
End If
End If
Set pptApp = Nothing
Exit Sub
CleanFail:
MsgBox "An error occurred:" & Err.Description
GoTo CleanExit
End Sub
Private Function OpenGetPowerPoint(ByRef isNewPPTInstance As Boolean) As PowerPoint.Application
Dim pptApp As PowerPoint.Application
On Error Resume Next
Set pptApp = GetObject(, "PowerPoint.Application")
If pptApp Is Nothing Then
'PPT wasn't running, start it from code:
Set pptApp = CreateObject("PowerPoint.Application")
isNewPPTInstance = True
End If
Set OpenGetPowerPoint = pptApp
End Function
Let me know if it works
I'm trying to copy all inline shapes from a word document to excel sheet.
The Word Document has multiple pages, with multiple tables with images in them.
The code I'm using is:
Sub imageExtract()
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim shpCurr As InlineShape
Dim i As Long
Set wrdApp = CreateObject("Word.Application")
Set wrdDoc = wrdApp.Documents.Open("C:\Temp\01.docx")
For Each shpCurr In wrdDoc.InlineShapes
shpCurr.Range.CopyAsPicture
Sheet10.Range("A" & i).PasteSpecial
i = i + 1
Next shpCurr
End Sub
Can someone explain to me why it is working for all the shapes in the first page of the Word document, and doesn't work for the shapes from another pages?
wrdDoc.InlineShapes.Count shows the real number of the shapes in the doc, so the loop is compleate
I've tried to cut and paste each shape to the first page before .CopyAsImage, with no sucsess.
I also tried to loop through each table and reference to the table's inline shapes ( "wrdDoc.tbl.InlineShapes"), with no sucsess.
If I manualy move a picture from (let's say) Page2 to Page1 and run the code again, this picture is copied.
If the problem is not the initial setting of the variable i, as I have mentioned in my comment above, then maybe you should try this code because not all shapes in a Word document are necessarily InlineShapes. The definition of InlineShapes in Word is they reside on their own paragraph. The other possibility for Shapes in a Word document are they have wrapping text and are anchored to some other place in the document. The significance here for InlineShapes and Floating Shapes is they each have to be referenced separately.
Of course you have mentioned that the InlineShapes count matches to what you expect but ... who knows ... maybe try this:
Sub imageExtract()
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim iShp As Word.InlineShape, shp As Word.Shape
Dim i As Long
Set wrdApp = CreateObject("Word.Application")
Set wrdDoc = wrdApp.Documents.Open("C:\Temp\01.docx")
If wrdDoc.Shapes.Count > 0 Then
For i = 1 To wrdDoc.Shapes.Count
Set shp = wrdDoc.Shapes(i)
shp.ConvertToInlineShape
Next
End If
If wrdDoc.InlineShapes.Count > 0 Then
For i = 1 To wrdDoc.InlineShapes.Count
Set iShp = wrdDoc.InlineShapes(i)
iShp.Range.CopyAsPicture
Sheet10.Range("A" & i).PasteSpecial
Next
End If
End Sub
UPDATE
After you sent me the files I was able to figure out that the problem is with Excel's PasteSpecial and if executed too many times an error 1004 PasteSpecial method of Range class failed because for some unknown reason something clears the clipboard and attempting to paste an empty clipboard generates the error.
I altered your code to use Word's Selection method to copy the images versus a Range method that was in your original code and that took care of the problem ... strange but it works. I also added some other code so that Word is properly closed out when the routine ends.
Sub imageExtract()
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim shpCurr As Word.InlineShape
Dim i As Long
On Error GoTo errHandler
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
Set wrdDoc = wrdApp.Documents.Open(ThisWorkbook.Path & "\01.docx")
i = 1
wrdDoc.Activate
Debug.Print wrdDoc.InlineShapes.Count
'On Error Resume Next
For Each shpCurr In wrdDoc.InlineShapes
shpCurr.Select
wrdApp.Selection.CopyAsPicture
Sheet10.Range("A" & i).PasteSpecial xlPasteAll
i = i + 1
Next
'the following is copying only one character which will clear the clipboard
'and prevent the message about wanting to save the last thing copied
wrdApp.Selection.EndKey wdStory
wrdApp.Selection.MoveStart wdCharacter, -1
wrdApp.Selection.Copy
wrdDoc.Close SaveChanges:=wdDoNotSaveChanges
Set wrdDoc = Nothing
wrdApp.Quit
Set wrdApp = Nothing
MsgBox "Complete"
Exit Sub
errHandler:
MsgBox Err.Number & Chr(32) & Err.Description, vbCritical
wrdDoc.Close SaveChanges:=wdDoNotSaveChanges
wrdApp.Quit
Set wrdApp = Nothing
End Sub
I have an excel file which composed of data and on a separate sheet, i create a graphs(bar, line, and doughnut). I used paste special from my created graphs in excel into my powerpoint so that it will be linked. Can someone tell me what will be the syntax to update those other slides?Thanks
This is my code and it is working only on the first slide of my presentation.
Sub Refresh(ParamArray var() As Variant)
Dim pApp As Object
Dim pPreso As Object
Dim pSlide As Object
Dim sPreso As String
sPreso = "/Users/USER/Desktop/company/Presentation1.pptx"
On Error Resume Next
Set pApp = GetObject(, "PowerPoint.Application")
If Err.Number <> 0 Then
Set pApp = CreateObject("PowerPoint.Application")
pApp.Visible = True
End If
On Error Resume Next
Set pPreso = pApp.Presentations(sPreso)
If Err.Number <> 0 Then
Set pPreso = pApp.Presentations.Open(Filename:=sPreso)
End If
Dim varSize As Integer
Dim i As Integer
varSize = UBound(var) - LBound(var) + 1
For i = 0 To (varSize - 1)
pPreso.Slides(1).Shapes(var(i)).LinkFormat.Update
Next i
End Sub
When I close the application for both excel and ppt, and then reopen it again, when I try to edit on my excel file,only the first slide in the ppt is automatically updated, I want to update all the slides in my powerpoint presentation.
I think You should run through all slides, maybe like this:
Dim sld
For Each sld In pPreso.Slides
For i = 0 To (varSize - 1)
sld.Shapes(Var(i)).LinkFormat.Update
Next i
Next sld
background
I am running code (from PowerPoint) that:
Loops through every slide in a presentation.
Checks each shape to determine if it is a chart.
If it is a chart, activate the underlying Excel worksheet, and then change the links in this underlying file to a new source.
I note that the links to excel do not exist at the overall PPT level [viaInfo], they are deliberately linked to each chart so that the presentation can be edited without access to the source excel file.
The code works - broadly.
There is an ongoing error (code running fine now) that I think goes to network and memory stability (fails after around 15 charts), and I am looking to turn off screenupdating as per Turn off screenupdating for Powerpoint.
question
All the charts I access are linked to other workbooks. Yet when the Excel workbook is exposed to PowerPoint the Linksources are not shown in the Locals window even though the code processes each link (image below shows the link exists)
I flipped the automation to access the PowerPoint pack from Excel, same result. No Linksources.
Why would the full object model not also be available in the Locals window when automating PowerPoint with Excel?
Is this a localised glitch I have stumbled over, or is it a broader issue?
The picture below shows the code itearying over the links (ppl variable, but the xlWB variable has no Linksources).
code
Sub FastUpdate()
Dim sld As Slide
Dim shp As Shape
Dim pptchrt As Chart
Dim pptChrtData As ChartData
Dim xlWB As Excel.Workbook
Dim lngStart As Long
Dim strNew As String
Dim strMsg As String
Dim ppl As Variant
On Error GoTo cleanup
'set start position manually
'lngStart = 34
If lngStart = 0 Then lngStart = 1
'call custom function for user to pick file
'strNew = Getfile
strNew = "S:\Corporate Model\05 RSM submissions\05 May 2016\02 Checked RSMs\VFAT\Australia\Australia - Valuation and Financial Analysis template.xlsx"
For Each sld In ActivePresentation.Slides
If sld.SlideIndex >= lngStart Then
For Each shp In sld.Shapes
If shp.HasChart Then
Set pptchart = shp.Chart
Set pptChrtData = pptchart.ChartData
'open underlying excel file - doesn't just activate chart
pptChrtData.Activate
'
Set xlWB = pptChrtData.Workbook
'loop through all links
For Each ppl In xlWB.LinkSources
strMsg = strMsg & SlideNumber & " " & pptchart.Name & vbNewLine
xlWB.ChangeLink ppl, strNew
Next
xlWB.Close True
Set xlWB = Nothing
End If
Next shp
End If
Next sld
cleanup:
Set xlWB = Nothing
If Err.Number <> 0 Then MsgBox Err.Description, vbCritical
If Len(strMsg) > 0 Then MsgBox strMsg, vbOKOnly, "Completed"
End Sub
Locals and Watch windows show properties of objects. List of properties of Workbook object can be found here.
LinkSources is a method with optional Type parameter.
If you want to debug LinkSources you can add it to Watch window:
or save return value to local variant variable to see it in Locals window.