I have developed a Powerpoint VBA function to which I pass a Shape and Slide object.
The function finds for a shape with text LOGO inside it, if it finds, it replaces that shape with the shape I passed to the function.
Function works perfectly on office 2013 but not on Office 2016.
Can anybody please suggest a work around for this?
Public Sub AddLogo_ONE(shLogo As Shape, oSlide As PowerPoint.Slide)
Dim sh As Shape
For Each sh In oSlide.Shapes
If sh.HasTextFrame Then
If UCase(sh.TextFrame2.TextRange.Text) = "LOGO" Then
oSlide.Select
DoEvents: DoEvents
shLogo.Copy
With oSlide.Shapes.Paste
.LockAspectRatio = msoFalse
.Left = sh.Left
.Top = sh.Top - ((.Height - sh.Height) / 2)
.AlternativeText = "LogoMacro"
sh.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
End With
Exit For
End If
End If
Next
End Sub
Below is the error message I get on Powerpoint 2016:
That's the dreaded machine dependent timing issue with VBA/Clipboard/WinOS. I have personally spent hours trying to devise a clever solution for this, even using WinAPIs to check and wait for a PowerPoint type of content to be available in the clipboard before proceeding with a Paste operation, all to no avail.
The only solution I have found that works is to slow VBA down with a delay. Nasty workaround as it's still machine dependent. This is the function I use:
Public Sub Delay(Seconds As Single, Optional DoAppEvents As Boolean)
Dim TimeNow As Long
TimeNow = Timer
Do While Timer < TimeNow + Seconds
If DoAppEvents = True Then DoEvents
Loop
End Sub
If you call this as follows (reduce the time from 1 second until it fails and then double it again!), it should solve your issue:
shLogo.Copy
Delay 1, True
With oSlide.Shapes.Paste
Related
I received a PowerPoint file with multiple slides which were supposed to be templates (designs - customlayouts) but instead were regular slides.
Transforming them into SlideMaster and custom layouts and replacing the titles and bodys (textboxes) with actual placeholders by hand was a pain.
So I came with this script to make the process faster.
If anybody has a better approach, it's welcome.
Had to look for a workaround to get the customlayout object.
Several things are missing, for example error handling.
To test it, copy a textbox into a slidemaster layout slide, select it and run the ReplaceWithPHTitle macro
Option Explicit
Public Sub ReplaceWithPHTitle()
ReplaceTexboxWithPlaceholder ppPlaceholderTitle
End Sub
Public Sub ReplaceWithPHBody()
ReplaceTexboxWithPlaceholder ppPlaceholderBody
End Sub
Private Sub ReplaceTexboxWithPlaceholder(ByVal placeholderType As PpPlaceholderType)
Dim targetLayout As CustomLayout
Dim activeShape As Shape
Dim newPlaceHolder As Shape
Set activeShape = ActiveWindow.Selection.ShapeRange(1)
Set targetLayout = activeShape.Parent
Set newPlaceHolder = targetLayout.Shapes.AddPlaceholder(Type:=placeholderType, Left:=activeShape.Left, Top:=activeShape.Top, Width:=activeShape.Width + 15, Height:=activeShape.Height)
With newPlaceHolder.TextFrame
.TextRange.Font.Name = activeShape.TextFrame.TextRange.Font.Name
.TextRange.Characters.Font.Color.RGB = activeShape.TextFrame.TextRange.Characters.Font.Color.RGB
.TextRange.Font.Size = activeShape.TextFrame.TextRange.Font.Size
.TextRange.Font.Bold = activeShape.TextFrame.TextRange.Font.Bold
.TextRange.ParagraphFormat.Bullet.Type = activeShape.TextFrame.TextRange.ParagraphFormat.Bullet.Type
.TextRange.ParagraphFormat.SpaceWithin = activeShape.TextFrame.TextRange.ParagraphFormat.SpaceWithin
.TextRange.ParagraphFormat.Alignment = activeShape.TextFrame.TextRange.ParagraphFormat.Alignment
.TextRange.ParagraphFormat.SpaceBefore = activeShape.TextFrame.TextRange.ParagraphFormat.SpaceBefore
.TextRange.ParagraphFormat.SpaceAfter = activeShape.TextFrame.TextRange.ParagraphFormat.SpaceAfter
.TextRange.ParagraphFormat.BaseLineAlignment = activeShape.TextFrame.TextRange.ParagraphFormat.BaseLineAlignment
.TextRange.Text = activeShape.TextFrame.TextRange.Text
End With
With newPlaceHolder.TextFrame2
.TextRange.Font.Spacing = activeShape.TextFrame2.TextRange.Font.Spacing
End With
newPlaceHolder.ZOrder msoSendToBack
newPlaceHolder.Select
End Sub
Any improvements are welcome too.
I'm just poking around in VBA with PowerPoint and know that what I want to do can be done. I just don't know the write calls/sytanx to use!
I want a macro that will run through all the slides in a presentation and move the video object to specific spot on the slide. The spot will be the same on all slides.
It would be very helpful if someone could show me how to do this! Or at least point me in the right direction. Thanks!
Here's what I found for doing something on every slide
Sub EveryTextBoxOnSlide()
' Performs some operation on every shape that contains text on every slide
' (doesn't affect charts, tables, etc)
Dim oSh As Shape
Dim oSl As Slide
On Error GoTo ErrorHandler
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
With oSh
If .HasTextFrame Then
If .TextFrame.HasText Then
' If font size is mixed, don't touch the font size
If .TextFrame.TextRange.Font.Size > 0 Then
.TextFrame.TextRange.Font.Size = .TextFrame.TextRange.Font.Size + 2
End If
End If
End If
End With
Next ' shape
Next ' slide
NormalExit:
Exit Sub
ErrorHandler:
Resume Next
End Sub
And this is something I found to move the object to desired location (here's where I don't know what to call the video object)
With ActiveWindow.Selection.ShapeRange
.Left = 640 'change the number for desired x position
.Top = 75 'change the number for desired y position
End With
End Sub
Sub ll()
End Sub
So basically, I want to run the last piece as a function of the first one instead of shapes with text. Does that make sense?
I've done some programming in the past, mainly with actionscript and Flash. I could probably write out some basic functions, just not sure how to run it in VBA without learning a whole new language. Which I don't want to do, since I'm an instructional designer and don't have the free time to learn it! :)
Here's a little function that'll return True if the shape you pass to it is a video, and a bit of example code to test it with:
Function IsVideo(oSh As Shape) As Boolean
If oSh.Type = msoMedia Then
If oSh.MediaType = ppMediaTypeMovie Then
IsVideo = True
Exit Function
End If
End If
' Things get a little trickier if the movie is in a placeholder
' Is it a placeholder? and is it a media object?
If oSh.Type = msoPlaceholder Then
If oSh.PlaceholderFormat.ContainedType = msoMedia Then
' it's a media object, but we don't know if it's
' a movie or sound or what, so we duplicate it
' then look at the duplicate (which is now a copy
' of the placeholder content but is not a placeholder itself)
With oSh.Duplicate
If .Type = msoMedia Then
If .MediaType = ppMediaTypeMovie Then
IsVideo = True
End If
End If
' and delete the duplicate
.Delete
End With
End If
End If
End Function
Sub thing()
Dim oSl As Slide
Dim oSh As Shape
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
If IsVideo(oSh) Then
oSh.Left = 0
End If
Next
Next
End Sub
Now you're getting somewhere!
I don't know what kind of shape holds your video, so this modification should help you identify it.
Sub EveryTextBoxOnSlide()
Dim oSh As Shape
Dim oSl As Slide
On Error GoTo ErrorHandler
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
With oSh
.Select
End With
Next
Next
NormalExit:
Exit Sub
ErrorHandler:
Resume Next
End Sub
While there is no need whatsoever to use the .Select in your final code, this is only here to help you identify which shape actually holds the video. Put a breakpoint (F9) on that line and run your code (F5), then debug through it with F8 to execute one line at a time and run through your loop looking at each shape until you see that your video has been selected.
Once your video has been selected look at the various properties (using the Immediate Window of the IDE) of oSh until you find the uniqueness that identifies this is your video. (There may be some property about the content type of the shape, or a link on where to find the contents that contains the text string ".avi", ".mpg", ".flv", etc - there will be some sort of identifier you can find.)
Once you've identified what makes the shape the holder of a video, replace
.Select
with
If {my video containing shape criteria is true} Then
With .Selection.ShapeRange
.Left = 640 'change the number for desired x position
.Top = 75 'change the number for desired y position
End With
End If
Changing the values (as commented) to whatever it is that you need.
Important Note: It is very good that your sample code has some error handling built in, but all this error handler is doing is sweeping any errors under the rug. This particular handler is the very long form version of On Error Resume Next which does have its uses, but in very, very limited situations.
As you get your code working, you'll actually want to put something useful in the ErrorHandler: section, but that's the topic for a whole new question.
Ok, here is how I modified the code supplied above to do this in my case:
Sub EveryTextBoxOnSlide() ' Performs some operation on every shape that contains text on every slide ' (doesn't affect charts, tables, etc) Dim oSh As Shape Dim oSl As Slide On Error GoTo ErrorHandler
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
With oSh
If .Type = msoMedia Then
If .MediaType = ppMediaTypeMovie Then
.PictureFormat.Crop.PictureHeight = 236
.PictureFormat.Crop.PictureWidth = 314.2115
.PictureFormat.Crop.PictureOffsetX = 8.737323
.PictureFormat.Crop.PictureOffsetY = 0
.PictureFormat.Crop.ShapeHeight = 236.3478
.PictureFormat.Crop.ShapeWidth = 163
.PictureFormat.Crop.ShapeLeft = 796.6956
.PictureFormat.Crop.ShapeTop = 0
End If
End If
End With
Next ' shape Next ' slide
NormalExit: Exit Sub
ErrorHandler: Resume Next
End Sub
Im new to Powerpoint VBA which is totally different from excel VBA. I can do it in excel but not powerpoint and need some help. I need to enter a score in the textbox. After that press a button, the shape will fill with color based on the score value. The higher the score, more shape will fill up. Below is my code:
Sub AddShape()
Dim counter As Integer
Dim TopValue As Integer
TopValue = 500
For counter = 1 To 5
Set myDocument = ActivePresentation.Slides(2)
With myDocument.Shapes.AddShape(Type:=msoShapeRectangle, Left:=144, _
Top:=TopValue, Width:=72, Height:=5)
.Name = "Rectangle" & counter
.Fill.Visible = msoFalse
.Line.DashStyle = msoLineSolid
End With
TopValue = TopValue - 50
Next counter
Dim tshape As Shape
Set tshape = ActiveWindow.Selection.SlideRange.Shapes.AddOLEObject(Left:=850, Top:=100,
Width:=90, Height:=40, ClassName:="Forms.TextBox.1", Link:=msoFalse)
End Sub
Private Sub CommandButton1_Click()
If CInt(TextBox1.Text) > 0 And CInt(TextBox1.Text) < 11 Then
ActivePresentation.Slides(2).Shapes("Rectangle1").Fill.ForeColor.RGB = RGB(255, 0, 0)
End If
End Sub
Private Sub TextBox1_Change()
Me.TextBox1.SpecialEffect = fmSpecialEffectFlat
End Sub
The code inside the Private Sub CommandButton1_Click doesn't seen to work... Please advise. I got prompt running error '424' object required. Specific code is appreciated as all the above code is direct copy from google search. I do not have much vba powerpoint knowledge.
Thank you very much.
You need to access OLE objects and their properties a bit differently from the way you work with regular shapes on slides.
Instead of TextBox1.Text, use
ActivePresentation.Slides(2).Shapes("TextBox1").OLEFormat.Object.Text
For all of you, people who make ppt slides with animations like:
Showing bullet points one by one
Showing images one by one or zooming a plot
Showing a border on an active element
Internal navigation / menu / link to another slide
Transitions between slides
Is there a tool that can convert the ppt to PDF and keep each animation in a separate slide, for example?
I know you can create animated slides with LaTeX Beamer that convert nicely to PDF, I have made some of those, but I also have some ppt files that I want to convert to PDF.
This is what I have tried so far:
Slideshare, however not only it doesn't support animations, but internal navigation doesn't work, and the fonts are all messed up.
PDFcreator, the quality is quite superior in comparison, but it doesn't support the animations neither. As Slideshare, it will just put one image over the other. Also, it doesn't support transparency (for example, a text box with a semitransparent bg over an image)
LaTeX Beamer, already mentioned, but I would prefer to avoid typing these ppts content and animations into LaTeX just so that the animations are displayed correctly in PDF.
I have searched SO and didn't find a satisfactory answer to deal with animations. What do you use?
I found a small plugin that splits your powerpoint slides whenever they have animations. So if you have 3 animations on 1 slide he will generate 3 slides with each animation step by step. Then export it in PDF :-)
It worked for me on powerpoint 2010. I would recommend you do a backup file of presentation before splitting. And don't forget to uncheck the "Split on click-triggered animations".
http://www.dia.uniroma3.it/~rimondin/downloads.php
I also found this (but the first solution was free and worked so :-))
http://www.verypdf.com/wordpress/201306/how-to-create-a-pdf-from-powerpoint-with-animations-36850.html
This blog post provides a VBA macro script that will split every slide that has animations (e.g. images or bullet points that appear one by one) into multiple slides, and then you can save as PDF and voila!
Importantly, since it's a VBA script it should work both for Windows and Mac. I've only tried it on OSX (yosemite) with powerpoint 2011, and it worked pretty well. The only issue I had was that slides with animated bullet points (that appear one by one) were split into multiple slides but every slide contained all the bullet points, so I had to delete some manually. Still, for everything else it worked perfectly and it's a small price to pay compared to doing it all manually, especially image animations. Of course you may/may not encounter the same issue on Windows or other versions of PP. In any case, for OSX it's the only working solution I've found so far.
Instructions for adding VBA macros to powerpoint can be found here.
Hope it works for you too!
This blog post provides a VBA macro script that will split every slide that has animations into multiple slides, without keeping the original slides in front of the expanded slides (as is the case in this answer).
The problem that remains with this macro and the other macro, is that the content of a text block with multiple animations is always shown as a whole (e.g. if each sentence of the same text block has a separate animation, all sentences will always be shown together).
VBA Code:
Private AnimVisibilityTag As String
Sub ExpandAnimations()
AnimVisibilityTag = "AnimationExpandVisibility"
Dim pres As Presentation
Dim Slidenum As Integer
Set pres = ActivePresentation
Slidenum = 1
Do While Slidenum <= pres.Slides.Count
Dim s As Slide
Dim animationCount As Integer
Set s = pres.Slides.Item(Slidenum)
If s.TimeLine.MainSequence.Count > 0 Then
Set s = pres.Slides.Item(Slidenum)
PrepareSlideForAnimationExpansion s
animationCount = expandAnimationsForSlide(pres, s)
Else
animationCount = 1
End If
Slidenum = Slidenum + animationCount
Loop
End Sub
Private Sub PrepareSlideForAnimationExpansion(s As Slide)
' Set visibility tags on all shapes
For Each oShape In s.Shapes
oShape.Tags.Add AnimVisibilityTag, "true"
Next oShape
' Find initial visibility of each shape
For animIdx = s.TimeLine.MainSequence.Count To 1 Step -1
Dim seq As Effect
Set seq = s.TimeLine.MainSequence.Item(animIdx)
On Error GoTo UnknownEffect
For behaviourIdx = seq.Behaviors.Count To 1 Step -1
Dim behavior As AnimationBehavior
Set behavior = seq.Behaviors.Item(behaviourIdx)
If behavior.Type = msoAnimTypeSet Then
If behavior.SetEffect.Property = msoAnimVisibility Then
If behavior.SetEffect.To <> 0 Then
seq.Shape.Tags.Delete AnimVisibilityTag
seq.Shape.Tags.Add AnimVisibilityTag, "false"
Else
seq.Shape.Tags.Delete AnimVisibilityTag
seq.Shape.Tags.Add AnimVisibilityTag, "true"
End If
End If
End If
Next behaviourIdx
NextSequence:
On Error GoTo 0
Next animIdx
Exit Sub
UnknownEffect:
MsgBox ("Encountered an error while calculating object visibility: " + Err.Description)
Resume NextSequence
End Sub
Private Function expandAnimationsForSlide(pres As Presentation, s As Slide) As Integer
Dim numSlides As Integer
numSlides = 1
' Play the animation back to determine visibility
Do While True
' Stop when animation is over or we hit a click trigger
If s.TimeLine.MainSequence.Count <= 0 Then Exit Do
Dim fx As Effect
Set fx = s.TimeLine.MainSequence.Item(1)
If fx.Timing.TriggerType = msoAnimTriggerOnPageClick Then Exit Do
' Play the animation
PlayAnimationEffect fx
fx.Delete
Loop
' Make a copy of the slide and recurse
If s.TimeLine.MainSequence.Count > 0 Then
s.TimeLine.MainSequence.Item(1).Timing.TriggerType = msoAnimTriggerWithPrevious
Dim nextSlide As Slide
Set nextSlide = s.Duplicate.Item(1)
numSlides = 1 + expandAnimationsForSlide(pres, nextSlide)
End If
' Apply visibility
rescan = True
While rescan
rescan = False
For n = 1 To s.Shapes.Count
If s.Shapes.Item(n).Tags.Item(AnimVisibilityTag) = "false" Then
s.Shapes.Item(n).Delete
rescan = True
Exit For
End If
Next n
Wend
' Clear all tags
For Each oShape In s.Shapes
oShape.Tags.Delete AnimVisibilityTag
Next oShape
' Remove animation (since they've been expanded now)
While s.TimeLine.MainSequence.Count > 0
s.TimeLine.MainSequence.Item(1).Delete
Wend
expandAnimationsForSlide = numSlides
End Function
Private Sub assignColor(ByRef varColor As ColorFormat, valueColor As ColorFormat)
If valueColor.Type = msoColorTypeScheme Then
varColor.SchemeColor = valueColor.SchemeColor
Else
varColor.RGB = valueColor.RGB
End If
End Sub
Private Sub PlayAnimationEffect(fx As Effect)
On Error GoTo UnknownEffect
For n = 1 To fx.Behaviors.Count
Dim behavior As AnimationBehavior
Set behavior = fx.Behaviors.Item(n)
Select Case behavior.Type
Case msoAnimTypeSet
' Appear or disappear
If behavior.SetEffect.Property = msoAnimVisibility Then
If behavior.SetEffect.To <> 0 Then
fx.Shape.Tags.Delete AnimVisibilityTag
fx.Shape.Tags.Add AnimVisibilityTag, "true"
Else
fx.Shape.Tags.Delete AnimVisibilityTag
fx.Shape.Tags.Add AnimVisibilityTag, "false"
End If
Else
' Log the problem
End If
Case msoAnimTypeColor
' Change color
If fx.Shape.HasTextFrame Then
Dim range As TextRange
Set range = fx.Shape.TextFrame.TextRange
assignColor range.Paragraphs(fx.Paragraph).Font.Color, behavior.ColorEffect.To
End If
Case Else
' Log the problem
End Select
Next n
Exit Sub
UnknownEffect:
MsgBox ("Encountered an error expanding animations: " + Err.Description)
Exit Sub
End Sub
For those of you using LibreOffice or OpenOffice,
there is a plugin available on github that does this very well :
ExpandAnimations
In my experience, all of the standard appear/disappear animations are nicely split. Object movement animations also work (you get a slide with start position and one with end position of the object). I haven't had the chance to test other animation types, but that should cover about all standard needs :-)
I have a macro that is supposed to make every shape on a page visible (I have other macros that make them invisible). Here is the code:
Dim Slide As Integer
Slide = SSW.View.CurrentShowPosition
If Slide = 1 Then
For Each shp In ActivePresentation.Slides(2).Shapes
shp.Visible = True
Next shp
End if
This macro takes forever to run. I suspect this is because it is redrawing the screen every time a shape is made visible.
This is not necessary, in fact the slide isn't even shown on the screen when this macro is run (it runs on Slide 1 but makes the shapes on Slide 2 visible). Is there any way to make this run faster? Disable the screen refresh or something?
I tried Shyam's solution from http://www.vbaexpress.com/forum/showthread.php?33671-Solved-PP2010-ScreenUpdating-False but it doesn't work. His only goes up to 2010 and I'm using 2013.
Your code doesn't work as shown. I changed it to this, which works pretty much instantly on a slide with 175 shapes:
' Put this at the top of every module; builds character, keeps you out of trouble
Option Explicit
Sub ThisWorks()
' Always dim ALL variables
Dim Slide As Long ' SlideIndex is a Long, not an Integer
Dim oSh As Shape
' Replaced your SSW with this:
Slide = SlideShowWindows(1).View.CurrentShowPosition
If Slide = 1 Then
For Each oSh In ActivePresentation.Slides(2).Shapes
' I was toggling them back and forth as a test
' oSh.Visible = Not oSh.Visible
oSh.Visible = True
Next
End If
' Delete this when it's no longer needed
MsgBox "Done"
End Sub