I am writing this VBA code in Excel which makes changes in a powerpoint file. Everything is working fine except the below.
When I call the FormatICTable function, I get a runtime error i.e."Type mismatch". It looks like to me that shape object which I am passing as the first argument is creating the problem. Any suggestions ?
Sub controlPPT()
Dim PPT As Object
Set PPT = CreateObject("PowerPoint.Application")
Dim pres As Presentation
With Application.FileDialog(1)
.AllowMultiSelect = False
.Show
.Filters.Clear
.Filters.Add "PPT files", "*.pptx"
.FilterIndex = 1
If .SelectedItems.Count > 0 Then
PPT.Presentations.Open .SelectedItems(1)
Dim sld As Slide
Set pres = PPT.ActivePresentation
For Each sld In pres.Slides
sld.Select
If sld.Shapes(1).TextFrame2.TextRange.Text = "Internal comparison" Then
Call FormatICTable(sld.Shapes(2), sld)
End If
Next
pres.Save
Set pres = Nothing
End If
End With
End Sub
Function FormatICTable(shp As Shape, sld As Slide)
'My code here
End Function
So, I got the answer myself
Shape object should be decalred as PowerPoint.Shape in function signature instead of using only Shape class.
Function FormatICTable(shp As PowerPoint.Shape, sld As Slide)
'My code here
End Function
Related
I'm trying to turn off gradient fill in all shapes in a PowerPoint document (including groups and sub groups).
The thing is I can't even get to cycle through the shapes correctly
Sub solid()
Set myDocument = ActivePresentation.Slides(1)
For Each sh In myDocument.Shapes
sh.Fill.solid
Next
End Sub
Thanks for your help.
Sub solid()
Dim mydocument As Presentation
Set mydocument = ActivePresentation
Dim sh As Shape
Dim sl As Slide
For Each sl In mydocument.Slides
For Each sh In sl.Shapes
If HasGradient(sh) = True Then
sh.Fill.solid
End If
Next
Next
End Sub
And also implement this function from TheSpreadSheetGuru to check whether the shape has a gradient value.
Function HasGradient(shp As Shape) As Boolean
'PURPOSE: Determine if a shape object contains a gradient format property
'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault
Dim GradientStopCount As Long
'Test for Gradient Stops
On Error Resume Next
GradientStopCount = shp.Fill.GradientStops.Count
On Error GoTo 0
'Results
If GradientStopCount <> 0 Then
HasGradient = True
Else
HasGradient = False
End If
End Function
I need some help regarding the Shapes Layout in Word Format. I have a word template that has some shapes in it, I want the result when the user tries to print the file or save it in PDF, it should not include the shape borders in it.
My Word File: Download Here
Desired File: Download Here
Actual File - While Editing The Document
While Printing CTRL+P (Desired Result)
I have found a script online that removes the shapes completely, I only want to remove the borders and retain the text/images inside the shape.
The script is as follows:
Sub PrintNoImagesOrShapesInDoc()
Dim objDoc As Document
Dim objInLineShape As InlineShape
Dim objShape As Shape
' Initialization
Set objDoc = ActiveDocument
' Find all images and shapes in the active document and then hide them to prevent from being
printed.
With objDoc
For Each objInLineShape In .InlineShapes
objInLineShape.Select
Selection.Font.Hidden = False
Next objInLineShape
Options.PrintDrawingObjects = False
End With
Dialogs(wdDialogFilePrint).Show
With objDoc
For Each objInLineShape In .InlineShapes
objInLineShape.Select
Selection.Font.Hidden = False
Next objInLineShape
End With
End Sub
Any Positive Help will be appreciated
Thanks,
For example, to save as a PDF:
Sub Demo()
Application.ScreenUpdating = False
Dim objUndo As UndoRecord, Shp As Shape
Set objUndo = Application.UndoRecord
With ActiveDocument
objUndo.StartCustomRecord ("RecordName")
For Each Shp In .Shapes
Shp.Line.Visible = False
Next
.SaveAs FileName:=Split(.FullName, ".doc")(0) & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
objUndo.EndCustomRecord
.Undo
End With
Application.ScreenUpdating = True
End Sub
I'm a new stackoverflow user so I'm not sure if I'm doing this right, but I'm trying to post a question on a previously given solution by Steve Rindsberg. I don't have enough reputation to comment, and there doesn't appear to be a way to message another user directly, so I'm posting a new question here.
I can't seem to get the code below to work. I'm using PowerPoint O365 Version 1901 and I have two type of shapes I'm trying to convert, msoChart and msoLinkedOLEObject (some Excel worksheets). I originally changed ppPasteEnhancedMetafile to ppPastePNG because I want PNG's, but it fails with either.
Here is the code:
Sub ConvertAllShapesToPic()
Dim oSl As Slide
Dim oSh As Shape
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
' modify the following depending on what you want to
' convert
Select Case oSh.Type
Case msoChart, msoEmbeddedOLEObject, msoLinkedOLEObject
ConvertShapeToPic oSh
Case msoPlaceholder
If oSh.PlaceholderFormat.ContainedType = msoEmbeddedOLEObject _
Or oSh.PlaceholderFormat.ContainedType = msoLinkedOLEObject _
Or oSh.PlaceholderFormat.ContainedType = msoChart _
Then
ConvertShapeToPic oSh
End If
Case Else
End Select
Next
Next
End Sub
Sub ConvertShapeToPic(ByRef oSh As Shape)
Dim oNewSh As Shape
Dim oSl As Slide
Set oSl = oSh.Parent
oSh.Copy
Set oNewSh = oSl.Shapes.PasteSpecial(ppPastePNG)(1)
With oNewSh
.Left = oSh.Left
.Top = oSh.Top
Do
.ZOrder (msoSendBackward)
Loop Until .ZOrderPosition < oSh.ZOrderPosition
End With
oSh.Delete
End Sub
I noticed if I run ConvertAllShapesToPic from an link/action in Slide Show mode, it doesn't complete and fails silently. If I add a Command Button (ActiveX control) and run it from there I get the following:
Run-time error '-2147188160 (80048240)':
Shapes (unknown member): Invalid request. The specified data type is unavailable.
It's failing on Set oNewSh = sld.Shapes.PasteSpecial(ppPastePNG)(1). After the error, if I go back to the slide and Ctrl-V I get the image, so I know it's working up to that point.
I've tried various solutions I found online for this such as adding DoEvents or ActiveWindow.Panes(1).Activate after the copy, but it doesn't seem to make a difference. Any suggestions?
Thanks
I found some other code to convert the charts and then I break links on the worksheets which automatically turns them in to images.
One thing I figured out was you must be out of slide show mode to break msoLinkedOLEObject links. I'm not 100% sure why... but this is the code that works for me:
Sub DoStuff()
Call LinkedGraphsToPictures
ActivePresentation.SlideShowWindow.View.Exit
Call BreakAllLinks
End Sub
Sub LinkedGraphsToPictures()
Dim shp As Shape
Dim sld As Slide
Dim pic As Shape
Dim shp_left As Double
Dim shp_top As Double
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.Type = msoChart Then
'Retrieve current positioning
shp_left = shp.Left
shp_top = shp.Top
'Copy/Paste as Picture
shp.Copy
DoEvents
sld.Shapes.PasteSpecial DataType:=ppPastePNG
Set pic = sld.Shapes(sld.Shapes.Count)
'Delete Linked Shape
shp.Delete
'Reposition newly pasted picture
pic.Left = shp_left
pic.Top = shp_top
End If
Next shp
Next sld
End Sub
Sub BreakAllLinks()
Dim shp As Shape
Dim sld As Slide
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.Type = msoLinkedOLEObject Then
shp.LinkFormat.BreakLink
End If
Next shp
Next sld
End Sub
I am currently using this code to update all links in my powerpoint presentation:
Sub UpdateLinks()
Dim ExcelFile
Dim exl As Object
Set exl = CreateObject("Excel.Application")
ExcelFile = "C:\Users\J\Documents\Reporting\Governance Physical Charts.xlsm"
Dim i As Integer
Dim k As Integer
'Go through every slide
For i = 1 To ActivePresentation.Slides.Count
With ActivePresentation.Slides(i)
'Go through every shape on every slide
For k = 1 To .Shapes.Count
On Error Resume Next
'Set the source to be the same as teh file chosen in the opening dialog box
.Shapes(k).LinkFormat.SourceFullName = ExcelFile
If .Shapes(k).LinkFormat.SourceFullName = ExcelFile Then
'If the change was successful then also set it to update automatically
.Shapes(k).LinkFormat.AutoUpdate = ppUpdateOptionAutomatic 'other option is ppUpdateOptionManual
End If
Next k
End With
Next i
End Sub
Instead of updating the link of every chart in the presentation, is it possible to have this code loop through only selected slides? Or if it's easier - is it possible to set a range? For example, only update charts on slides 15-30?
Thank you!
EDIT:
Resolution provided in comments - here is my revised code
Sub UpdateLinks()
Dim ExcelFile
Dim exl As Object
Set exl = CreateObject("Excel.Application")
Dim sld As Slide
ExcelFile = "C:\Users\J\Documents\Reporting\Governance Physical Charts.xlsm"
Dim i As Integer
Dim shp As Shape
For Each sld In ActivePresentation.Slides.Range(Array(11, 12, 13, 14, 15, 16, 17, 18))
For Each shp In sld.Shapes
On Error Resume Next
shp.LinkFormat.SourceFullName = ExcelFile
If shp.LinkFormat.SourceFullName = ExcelFile Then
shp.LinkFormat.AutoUpdate = ppUpdateOptionAutomatic 'other option is ppUpdateOptionManual
End If
Next shp
Next
End Sub
Yes you can compose custom ranges on Slides as well as on Shapes, using an Array as the index parameter. Try this:
Dim sld As Slide
For Each sld In ActivePresentation.Slides.Range(Array(1, 3, 5))
Debug.Print sld.Name
Next
Output:
Slide2
Slide4
Slide6
p.s. I had deleted a slide in the test presentation.
Since you also mentioned processing just selected slides, you can do that like so:
Sub SelectedSlides()
Dim osl As Slide
For Each osl In ActiveWindow.Selection.SlideRange
Debug.Print osl.SlideIndex
Next
End Sub
Note that this will give you the selected slides in REVERSE order of selection. That is, if you control-click slides 2,4,6, this will give you 6,4,2.
I would like this particular code to be run on multiple powerpoint files in a folder. But it would be even better if it would open the powerpoint file, run this code below, save it and then open the next one. Any suggestions are welcome! I have been through code on this website, but can't seem to adapt it to my code below (e.g. this one Loop through files in a folder using VBA?)
LOOPING ATTEMPT
flag
Sub LoopThroughFiles()
Dim MyObj As Object, MySource As Object, file As Variant
file = Dir("c:\testfolder\")
While (file <> "")
If InStr(file, "test") > 0 Then
MsgBox "found " & file
Exit Sub
End If
file = Dir
Wend
End Sub
Existing Code
Option Explicit
' Selects the shape that support text which is closest to the top of the slide
' Written by Jamie Garroch of YOUpresent Ltd (http://youpresent.co.uk)
Sub SelectHigestTextShape()
Dim oSld As Slide
Dim oShp As Shape, oShpTop As Shape
Dim sShpTop As Single
On Error Resume Next
Set oSld = ActiveWindow.View.Slide
If Err Then Exit Sub
On Error GoTo 0
' Set the top to the bottom of the slide
sShpTop = ActivePresentation.PageSetup.SlideHeight
' Check each shape on the slide is positioned above the stored position
' Shapes not supporting text and placeholders are ignored
For Each oShp In oSld.Shapes
If oShp.Top < sShpTop And oShp.HasTextFrame And Not oShp.Type = msoPlaceholder Then
sShpTop = oShp.Top
Set oShpTop = oShp
End If
Next
' Select the topmost shape
If Not oShpTop Is Nothing Then oShpTop.Select msoTrue
ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
' Clean up
Set oSld = Nothing
Set oShp = Nothing
Set oShpTop = Nothing
End Sub
That's my code sample for the SelectHigestTextShape sub but I'm not sure it'll work the way you want for multiple files. The reason is that it was designed to SELECT a textbox object within the ACTIVE PRESENTATION using the ACTIVE VIEW. None of this exists when you loop through files in a folder as you'd need to open each one in turn but even then, what would be the point of selecting a shape only to close the presentation afterwards? I guess we really need to know the end goal. In the type of batch processing you're attempting, it would not be a good idea to select anything at all as that requires the object's view to be active which is a debugging nightmare and slows everything down a lot. If you want to do something with a particular object, it's much better to use a reference to it without requiring an active view or even an active window (you could open each file invisibly, process it and then close it).
This example will loop through a folder, open each presentation it finds (without a window), loop through all shapes on all slides, output a count of slides and shapes to the immediate pane, and then close the file:
' Loop through all PowerPoint files in a specified folder
' Open each and then loop through each shape of each slide
' Output a count of slides and shapes in immediate pane before closing the file
' Modified by Jamie Garroch of YOUpresent Ltd (http://youpresent.co.uk)
Sub LoopThroughPPTFiles()
Dim oPres As Presentation, oSld As Slide, oShp As Shape
Dim SldCount As Long, ShpCount As Long
Dim MyFile As String
Const MyFolder = "c:\testfolder\"
On Error GoTo errorhandler
MyFile = Dir(MyFolder)
While (MyFile <> "")
If Right(MyFile, 5) Like ".ppt*" Then
Set oPres = Presentations.Open(FileName:=MyFolder & MyFile, ReadOnly:=msoTrue, Untitled:=msoFalse, WithWindow:=msoFalse)
For Each oSld In oPres.Slides
SldCount = SldCount + 1
For Each oShp In oSld.Shapes
ShpCount = ShpCount + 1
Next
Next
Debug.Print oPres.Name & " has " & SldCount & " slide(s) and " & ShpCount & " shapes."
SldCount = 0: ShpCount = 0
oPres.Close
End If
MyFile = Dir
Wend
' clean up
Set oPres = Nothing: Set oSld = Nothing: Set oShp = Nothing
Exit Sub
errorhandler:
If Not oPres Is Nothing Then oPres.Close: Set oPres = Nothing
End Sub
You could use this to then examine the shapes after the "For Each oShp In oSld.Shapes" line to find the one positioned highest on the slide and then process it (without selecting it).