I have an Excel file that contains a column with images that correspond to distinct unique IDs. Basically, through VBA, I want to loop through each image and save it with its name being the unique ID.
I realize you cannot save an image in Excel itself, so I found this VBA code online (found below) that copies the image into PowerPoint and saves it there, but it is not working for me. I am working with Excel 2016, 64 bit.
Any suggestions?
Sub SaveImages()
'the location to save all the images
Const destFolder = "C:\Desktop\Images"
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("data")
Dim ppt As Object, ps As Variant, slide As Variant
Set ppt = CreateObject("PowerPoint.application")
Set ps = ppt.presentations.Add
Set slide = ps.slides.Add(1, 1)
Dim shp As Shape, shpName
For Each shp In ws.Shapes
shpName = destFolder & shp.TopLeftCell.Offset(0, 1) & ".png"
shp.Copy
With slide
.Shapes.Paste
'This is the point where the code breaks, when I try to save
.Shapes.SaveAs Filename:=destFolder & shpName
.Shapes(.Shapes.Count).Delete
End With
Next shp
With ps
.Saved = True
.Close
End With
ppt.Quit
Set ppt = Nothing
End Sub
Related
I have a PowerPoint slide library and numerous presentations. I want to use a macro (VBA) to find a particular slide by SlideID (or some other marker, tag) in all open presentations, delete that slide, then insert in the same location an updated slide from my Slide Library.
This step works:
ActivePresentation.Slides.FindBySlideID(1296).Delete
where do I go from there to InsertFromFile a specific slide with its own SlideID?
Thanks.
The following macro will first retrieve the slide index for the specified slide ID from the specified presentation, and then insert the slide into the active presentation.
Option Explicit
Sub InsertSlideFromFileBySlideID()
Dim sourcePresentation As Presentation
Dim sourceFile As String
Dim sourceSlideID As Long
Dim sourceSlideIndex As Long
sourceFile = "c:\users\domenic\desktop\sample.pptx" 'change the path and filename accordingly
sourceSlideID = 256 'change the ID accordingly
Set sourcePresentation = Application.Presentations.Open(FileName:=sourceFile, ReadOnly:=msoTrue)
sourceSlideIndex = sourcePresentation.Slides.FindBySlideID(sourceSlideID).slideIndex
sourcePresentation.Close
'Insert the slide from the source file that has the specified slide index number at the end of the active presentation
With ActivePresentation
.Slides.InsertFromFile FileName:=sourceFile, Index:=.Slides.Count, SlideStart:=sourceSlideIndex, SlideEnd:=sourceSlideIndex
End With
End Sub
EDIT
The following macro will copy multiple slides, by SlideID, from the specified open presentation to the active presentation.
Option Explicit
Sub CopySlidesBySlideID()
Dim sourcePresentation As Presentation
On Error Resume Next
Set sourcePresentation = Application.Presentations("sample.pptx") 'change the name accordingly
If sourcePresentation Is Nothing Then
MsgBox "Source presentation not found!", vbExclamation
Exit Sub
End If
On Error GoTo 0
Dim vSlideIDs As Variant
vSlideIDs = Array(256, 260, 258) 'change the slide IDs accordingly
Dim i As Long
For i = LBound(vSlideIDs) To UBound(vSlideIDs)
sourcePresentation.Slides.FindBySlideID(vSlideIDs(i)).Copy
ActivePresentation.Slides.Paste
Next i
End Sub
This is my first real attempt to create something in VBA, so be gentle please.
This is what I need my program to do:
Run from PPT and open an Excel file
Start at slide 1 and find a box that contains the words "iq_", if it
has those words then it will have numbers after it like so "iq_43"
or "iq_43, iq_56, iq_72".
find those words and numbers in the opened Excel file. Needs to
recognize that ", " means there is another entry.
Copy column containing words from ppt ie. "iq_43"
Paste a Table into ppt with those values
Do this for every slide
I'm having issues with my function at the bottom. This is where the program should be shifting to work in the opened excel file. The idea there is to go through the headers of each column and search for values that I have stored in "iq_Array". Once values are found, then copy rows below it into another array called "tble" (which will eventually be pasted onto the powerpoint slide as a table).
The code currently stops at
rng = Worksheets("Sheet1").Cells(1, i).Value
I'm not sure what I'm doing wrong here. Once fixed, will this is be able to be copied into an array?
Another part I believe I'm having trouble with is how to return the function values. I currently have
xlFindText(iq_Array, xlWB) = tble()
At the bottom of my function in order to call it as such in my main code. Is this the proper way to do it?
Public Sub averageScoreRelay()
'Create variables
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim pptSlide As Slide
Dim fileName As String
Dim Shpe As Shape
Dim pptText As String
Dim strArray As String
Dim pptPres As Object
Dim PowerPointApp As Object
Dim iq_Array
' Create new excel instance and open relevant workbook
Set xlApp = New Excel.Application
xlApp.Visible = True 'Make Excel visible
Set xlWB = xlApp.Workbooks.Open("C:\Users\pinlop\Desktop\Gate\Macro\averageScores\pptxlpratice\dummyavgscore.xlsx", True, False) 'Open relevant workbook
If xlWB Is Nothing Then ' may not need this if statement. check later.
MsgBox ("Error retrieving Average Score Report, Check file path")
Exit Sub
End If
'Is PowerPoint already opened?
'Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'Make PPT visible
Set pptPres = PowerPoint.ActivePresentation
Set pptSlide = Application.ActiveWindow.View.Slide 'Set pptSlide = pptPres.Slides _
(PowerPointApp.ActiveWindow.Selection.SlideRange.SlideIndex) (different way of saying the same thing?)
'Loop through each pptSlide and check for IQ text box, grab avgScore values and create pptTable
For Each pptSlide In pptPres.Slides
'searches through shapes in the slide
For Each Shpe In pptSlide.Shapes
'Identify if there is text frame
If Shpe.HasTextFrame Then
'Identify if there's text in text frame
If Shpe.TextFrame.HasText Then
pptText = Shpe.TextFrame.TextRange
If InStr(1, pptText, "iq_") > 0 Then 'Identify if within text there is "iq_" All IQ's have to be formatted like this "iq_42, iq_43" for now
iq_Array = Split(pptText, ", ") 'Use function below to Set iq_Array to an array of all iq_'s in the text box
xlFindText(iq_Array, xlWB).Copy
pptSlide.Shapes.PasteSpecial DataType:=ppPasteHTML, Link:=msoFalse ' Paste the Array
End If
End If
End If
Next Shpe
Next pptSlide
End Sub
Function xlFindText(iq_Array, xlWB) 'This function works in excel and saves the column values into xlFindText(iq_Array, xlWB) to be pasted as a table into ppt
'SetsxlTextID = to the array of iq_'s
Dim i As Integer
Dim k As Integer
Dim activeWB As Excel.Workbook
Dim size As String
Dim rng As Range
Dim tble As Range
'for loop to go through values stored in array
size = UBound(iq_Array) - LBound(iq_Array)
For i = 0 To size 'loops through array values
For k = 1 To 200 'loops through cloumns
rng = Worksheets("Sheet1").Cells(1, i).Value
If rng = iq_Array(i) Then 'matches column value to iq_Array
Columns(k).Select
tble(i) = Selection.Copy 'saves a copy of the range into tble() array
End If
Next k
Next i
xlFindText(iq_Array, xlWB) = tble()
End Function
There are several problems with your code, I'll go from start to end, but it may well be I'm missing some.
(1)
Set pptSlide = Application.ActiveWindow.View.Slide
is pointless because directly afterwards you overwrite pptSlide with:
For Each pptSlide In pptPres.Slides
xlFindText
(2)
rng = Worksheets("Sheet1").Cells(1, i).Value
If you work with a different Office program than the one where the code runs in (here Excel from PPT), you always must fully qualify your objects. Don't use shortcuts like ActiveSheet without specifying the parent object (Excel application).
So this should be:
xlWB.Worksheets("Sheet1").Cells(1, i).Value
The same applies to Columns(k).
(3)
rng is a Range object. This doesn't go together with a cell value.
Either
Set rng = xlWB.Worksheets("Sheet1").Cells(1, i)
or
Dim varValue As Variant
varValue = xlWB.Worksheets("Sheet1").Cells(1, i).Value
(4)
tble(i) = Selection.Copy
This is not how Range.Copy works, please check the Excel Online Help.
You will have to change the logic of xlFindText - either return a column number from this function and do the Copy + Paste in the main function, or do both in xlFindText (then pass pptSlide as parameter).
I am interning with a large firm that stores a lot of its source data in the form of PowerPoints. These PowerPpoints serve well when communicating across departments and between suppliers but, as you may guess, lack any robust analysis. Because of this, I have decided to database these Powerpoints into Access.
There is no direct way of doing this, that I know of. Due to strict IT policies, I am limited to VBA as my coding platform. I have spent the last week coding up a macro to solve my problem. Again, since there is no direct conversion of PowerPoint to Access, I have had to solve this problem rather inefficiently as there are a few caveats. I will list my steps and caveats below.
The powerpoint information I want to database is formatted as a table instead of text. I have been unable to find a Macro that converts PPT tables directly to Excel or CSV files. Because of this, I will convert all PPT files (roughly 3000) to PDFs.
From these generated PDF's I can use Adobe to convert them to Excel or CSV files.
Using multiple online resources and a bit of my own experience, I have coded up a VBA script that will automatically format a folder of CSV files into a format that Access will store correctly. See Code 1.
(The "Personal.xlsb!Module1.FormatAccess" is a macro created mostly with "Record Macro." I omitted this code due to its length and redundancy.)
After formatting the CSVs, I will then automate them all to Access.
Following the Access automation, I will need to embed each PPT file to its respective Access entry
Again, this is not an efficient process. Because I am limited to Microsoft only applications, I have chosen this route. I thought about leaving the information as Excel files, but the idea is to make this data accessible and searchable by any department, hence why I chose Access to database them.
Now that I have explained to you where I am coming from and what I am doing, I ask: what recommendations do you have for me? I feel my round-about way is a good solution and practical, but I wonder if there is a better solution.
Code 1
Sub LoopCSVFile()
Dim fso As Object 'Scritping.FileSystemObject
Dim fldr As Object 'Scripting.Folder
Dim file As Object 'Scripting.File
Dim wb As Workbook
Set fso = CreateObject("Scripting.FileSystemObject")
Set fldr = fso.GetFolder("C:\Users\HMM105289\Documents\Powerpoint Parsing\Test Folder\Test Save Folder")
For Each file In fldr.Files
Set wb = Workbooks.Open(file.Path)
Application.Run "Personal.xlsb!Module1.FormatAccess"
wb.Close SaveChanges = True
Next
Set file = Nothing
Set fldr = Nothing
Set fso = Nothing
End Sub
Edit 1
Having played around with some of Tim's suggestions, I have come up with this code to run a check on each PPT slide. The idea is to have it run his "ExtractTable" macro inside. As it stands, I am unable to get it to execute.
Sub PPTableXtraction()
Dim oSlide As Slide
Dim oSlides As Slides
Dim oPPT As Object: Set oPPT = ActivePresentation
Dim oShapes As Shape
Dim oTable As Object
For Each oSlide In oPPT.Slides
For Each oShapes In oSlide.Shapes
If oShapes.HasTable Then
Application.Run "VBAProject.xlsb!Module3.ExtractTableContent"
End If
Next
Next
End Sub
Edit 2
I was able to build on Tim's code to create a code that loops each PowerPoint file and extracts the information into Excel. The code doesn't break into the debugger but for whatever reason it is not performing any functions. Would anyone have any idea why?
Sub Tester()
Dim ppts As PowerPoint.Application
Dim FolderPath As String
Dim FileName As String
FolderPath = "FolderPath"
FileName = Dir(FolderPath & "*.ppt*")
Do While FileName <> ""
Set ppts = New PowerPoint.Application
ppts.Visible = True
ppts.Presentations.Open FileName:=FolderPath & FileName
A = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 5
B = "B" & A
X = "A" & A
Range(X).Value = "New"
Dim ppt As Object, tbl As Object
Dim slide As Object, pres As Object, shp
Dim rngDest As Range
Set ppt = GetObject(, "Powerpoint.Application")
Set pres = ppt.ActivePresentation
Set rngDest = Sheets("Data").Range(B) '
For Each slide In pres.Slides
For Each shp In slide.Shapes
If shp.HasTable Then
ExtractTableContent shp.Table, rngDest
Set rngDest = rngDest.Offset(shp.Table.Rows.Count + 3, 0)
End If
Next
Next
ppts.ActivePresentation.Close
FileName = Dir
Loop
End Sub
Sub ExtractTableContent(oTable As Object, rng As Range)
Dim r, c, offR As Long, offC As Long
For Each r In oTable.Rows '<< Loop over each row in the PPT table
offC = 0 '<< reset the column offset
For Each c In r.Cells '<< Loop over each cell in the row
'Copy the cell's text content to Excel, using the offsets
' offR and offC to select where it gets placed relative
' to the starting point (rng)
rng.Offset(offR, offC).Value = c.Shape.TextFrame.TextRange.Text
offC = offC + 1 '<< increment the column offset
Next c
offR = offR + 1 '<< increment the row offset
Next r
End Sub
Sub N()
Range("A3").Value = "New"
End Sub
Here's an example of extracting a table from PPT to Excel.
Looping over the slides and tables (modified from your posted code)
Sub Tester()
Dim ppt As Object, tbl As Object
Dim slide As Object, pres As Object, shp
Dim rngDest As Range
Set ppt = GetObject(, "Powerpoint.Application")
Set pres = ppt.ActivePresentation
Set rngDest = Sheets("Data").Range("a1") '<< where to start placing ppt data
For Each slide In pres.Slides
For Each shp In slide.Shapes
If shp.HasTable Then
ExtractTableContent shp.Table, rngDest
Set rngDest = rngDest.Offset(shp.Table.Rows.Count + 3, 0)
End If
Next
Next
End Sub
The sub to extract each table's data:
Sub ExtractTableContent(oTable As Object, rng As Range)
Dim r, c, offR As Long, offC As Long
For Each r In oTable.Rows '<< Loop over each row in the PPT table
offC = 0 '<< reset the column offset
For Each c In r.Cells '<< Loop over each cell in the row
'Copy the cell's text content to Excel, using the offsets
' offR and offC to select where it gets placed relative
' to the starting point (rng)
rng.Offset(offR, offC).Value = c.Shape.TextFrame.TextRange.Text
offC = offC + 1 '<< increment the column offset
Next c
offR = offR + 1 '<< increment the row offset
Next r
End Sub
In case anyone skims this and wants the solution used
It is out of the box ready, with the exception of setting your file path.
Sub Tester()
Dim rng As Range
Set rng = Range("A1") 'This code is necessary to prevent a constant loop of the formatting for each extraction. It adds a "1" into "A1"
rng.Value = 1
Dim ppts As PowerPoint.Application
Dim FolderPath As String
Dim FileName As String
FolderPath = "FolderPath" 'Define your Folder Path
FileName = Dir(FolderPath & "*.ppt*") 'Locate .PPT files
Do While FileName <> ""
Set ppts = New PowerPoint.Application 'Left this in after finding another fix. Opens new instance each time
ppts.Visible = True
ppts.Presentations.Open FileName:=FolderPath & FileName
'The code below sets 3 variables to help in formatting Tim's extraction code.
'It searches for the last cell entry and then adds 5 rows before copying more information.
A = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 5
B = "B" & A
X = "A" & A
Range(X).Value = "New"
'Beginning of Tim's code
Dim ppt As Object, tbl As Object
Dim slide As Object, pres As Object, shp
Dim rngDest As Range
Set ppt = GetObject(, "Powerpoint.Application")
Set pres = ppt.ActivePresentation
Set rngDest = Sheets("Data").Range(B) 'Moved it over one column for formatting
For Each slide In pres.Slides
For Each shp In slide.Shapes
If shp.HasTable Then
ExtractTableContent shp.Table, rngDest
Set rngDest = rngDest.Offset(shp.Table.Rows.Count + 3, 0)
End If
Next
Next
ppts.ActivePresentation.Close 'Close PPT and loop for next one
FileName = Dir
Loop
End Sub
'More of Tim's code
Sub ExtractTableContent(oTable As Object, rng As Range)
Dim r, c, offR As Long, offC As Long
For Each r In oTable.Rows '<< Loop over each row in the PPT table
offC = 0 '<< reset the column offset
For Each c In r.Cells '<< Loop over each cell in the row
'Copy the cell's text content to Excel, using the offsets
' offR and offC to select where it gets placed relative
' to the starting point (rng)
rng.Offset(offR, offC).Value = c.Shape.TextFrame.TextRange.Text
offC = offC + 1 '<< increment the column offset
Next c
offR = offR + 1 '<< increment the row offset
Next r
End Sub
Sub N()
Range("A3").Value = "New" 'Simply adds "New" next to each new file opened. Helps for deliniation between files
End Sub
I am trying to paste an msoChart object with embedded data from the clipboard into PowerPoint 2010 using VBA. (chart created in Excel 2010).
The only examples that I can find involve either linking the Chart to an Excel file or creating a msoEmbeddedOLEObject.
If I manually paste in PowerPoint 2010 I get a paste option to "Embed Workbook". However it is not available within manual "Paste Special".
So it would seem that something in addition to pasting the chart is needed. But I am unsure what that is or how to go about it.
What I have tried is
Sub PasteExample()
Dim Sld As Slide
Dim Shp As ShapeRange
Set Sld = ActiveWindow.View.Slide
'# This pastes clipboard content as a linked chart
Set Shp = Sld.Shapes.Paste
End Sub
Sub PasteExample2()
Dim Sld As Slide
Dim Shp As ShapeRange
Set Sld = ActiveWindow.View.Slide
'# This option does not work, object is still linked
'Set Shp = Sld.Shapes.PasteSpecial(DataType:=ppPasteDefault, Link:=msoFalse)
'# This option does not work, object is still linked
'Set Shp = Sld.Shapes.PasteSpecial(DataType:=ppPasteShape, Link:=msoFalse)
'# I'm not after OLEObjects
'Set Shp = Sld.Shapes.PasteSpecial(DataType:=ppPasteOLEObject, Link:=msoFalse)
End Sub
Many thanks if you can shed some light.
We don't see what you are copying and how, plz join code if problem not solved
Here are the members of PpPasteDataType that you can use with PasteSpecial in PowerPoint :
Usually, I use that code as a base, it should help you :
Sub Export_to_Ppt()
'
Dim Ppt As PowerPoint.Application, _
Pres As PowerPoint.Presentation
Set Ppt = CreateObject("PowerPoint.Application")
Set Pres = Ppt.Presentations.Open("I:\Template DTC.potx")
Ppt.Visible = True
Sheets("Graph1").ActiveChart.ChartArea.Copy
Pres.Slides.Add Index:=Pres.Slides.Count + 1, Layout:=ppLayoutTitleOnly
'Pres.Slides(Pres.Slides.Count).Shapes.Paste
Pres.Slides(Pres.Slides.Count).Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile, Link:=False
Pres.Slides(Pres.Slides.Count).Shapes.Title.TextFrame.TextRange.Text = "Chart Title"
Pres.SaveAs _
Filename:="I:\TestNaz.ppt", _
FileFormat:=ppSaveAsOpenXMLPresentation
Set Ppt = Nothing
Set Pres = Nothing
End Sub
I tried to reproduce your example with PowerPoint 2013. I wasn't able to reproduce the behaviour that you describe.
Pre-Condition: I copied an Excel 2013 chart to the Clipboard (just the chart, not the whole worksheet or anything else).
Invoking either Sld.Shapes.Paste or Sld.Shapes.PasteSpecial(DataType:=ppPasteDefault,Link:=msoFalse) will insert an msoChart into Powerpoint:
Set shp = Sld.Shapes.Paste
MsgBox shp.Type ' returns 3 that is msoChart
Set shp = Sld.Shapes.PasteSpecial(DataType:=ppPasteDefault, Link:=msoFalse)
MsgBox shp.Type 'returns 3 that is msoChart
Those charts are properly formatted in the current PowerPoint style and I can right-click them to edit the data.
Especially, they are embedded, not linked.
For comparison I also tried:
Set shp = Sld.Shapes.PasteSpecial(DataType:=ppPasteOLEObject, Link:=msoFalse)
MsgBox shp.Type ' returns 7 that is msoEmbeddedOLEObject
Set shp = Sld.Shapes.PasteSpecial(DataType:=ppPasteOLEObject, Link:=msoTrue)
MsgBox shp.Type ' returns 10 that is msoLinkedOLEObject
Set shp = Sld.Shapes.PasteSpecial(DataType:=ppPasteDefault, Link:=msoTrue)
MsgBox shp.Type 'returns 10 that is msoLinkedOLEObject
When I right-click those in Powerpoint, then there is are menu entries to manipulate the “Worksheed Object” respectively the “Linked Worksheed Object”.
So either I misunderstand what you mean by "linked", or there is a bug in PP 2010, or you are having something different in your clipboard.
I did come upon a solution on another form.
Once the chart is in the clipboard.
Execute the following line in PowerPoint 2010
Application.CommandBars.ExecuteMso "PasteExcelChartDestinationTheme"
It gave me just what I was after.
I have a powerpoint presentation with an excel workbook embedded in one of the slides. I also have a userform that I want the user to input information into, I want to take this information and then edit the excel sheet with the relevant information.
I don't know how to access the excel sheet within powerpoint though so I can change the values of the cells.
Sub a()
Dim oSl As PowerPoint.Slide
Dim oSh As PowerPoint.Shape
Set oSl = ActivePresentation.Slides(1)
Set oSh = oSl.Shapes(1)
With oSh.OLEFormat.Object.Sheets(1)
.Range("A1").Value = .Range("A1").Value + 1
.Range("A2").Value = .Range("A2").Value - 1
End With
Set oSl = Nothing
Set oSh = Nothing
End Sub
Inspired in this code