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 :-)
Related
Is there a way in VBA to select all the slides in active ppt doc that use a given custom layout?
CustomLayout.Name=”1_separator”
CustomLayout.Index=”1”
So far, I have played with this idea:
For Each CustomLayout In ActivePresentation.SlideMaster.CustomLayouts
If CustomLayout.Name = "1_Separator" Then
ActivePresentation.Slides.Range.Select
Exit For
End If
Next
End Sub
However, it selects all the slides in the ppt (not only the ones with ”1_separator”), so it is not what I need.
My overall aim is to create an automated Table of Contents in ppt, for that I would like to choose particular slides with macro.
Alternatively, I could put a shape or specific text box on the slides, based on which I am going to create a Table of Contents.But I don’t know the code for selecting slides with a given shape or text, either.
I will be grateful for any help on this.
Sub SelectSlidesWithGivenCustomLayout()
Dim slidesToSelect(999)
Dim currentSlide As Slide
Dim counter As Integer
counter = 0
For Each currentSlide In ActivePresentation.Slides
If currentSlide.CustomLayout.Name = "1_Separator" Then
slidesToSelect(counter) = currentSlide.SlideIndex
counter = counter + 1
End If
Next
ActivePresentation.Slides.Range(slidesToSelect).Select
End Sub
I would like to set font type (calibri)of text( where ever there is an alphabet in presentation, it should be "calibri") in every slide by running the single macro using VBA. The problem is, it is unable to change the font present in 'chart', 'flow chart diagram' where it has boxes like rectangle, round cornered rectangles etc.How to manipulate that text as well? Please help!
As shown in the image the font of climate in rectangle is not changing.Different font type in rectangle
The solution to this problem is pretty tedious as there are so many different types of shapes and textranges to account for. I can't post my entire solution as I don't own the intellectual property, but this should get you on the right track:
Sub MakeFontsThemeFonts()
Dim oSld As Slide
Dim oShp As Shape
Dim oShp2 As Shape
Dim oTxtRange As TextRange
' Set majorFont and minorFont to Calibri
ActivePresentation.SlideMaster.Theme.ThemeFontScheme.majorFont.Item(1) = "Calibri"
ActivePresentation.SlideMaster.Theme.ThemeFontScheme.minorFont.Item(1) = "Calibri"
For Each oSld in ActivePresentation.Slides
For Each oShp in oSld.Shapes
If oShp.HasChart Then
' Call your chart handler
ElseIf oShp.HasTable Then
' Call your table handler
ElseIf oShp.HasSmartArt Then
' Call your SmartArt handler
ElseIf oShp.HasTextFrame Then
If oShp.HasText Then
Set oTxtRange = oShp.TextFrame.TextRange
Call RefontTextRange (oTxtRange)
End If
ElseIf oShp.Type = msoGroup Then
For Each oShp2 in oShp.GroupItems
If oShp2.Type = ... Then
' And so on, you wind up having to check for
' everything that's grouped all over again
End If
Next
End If
Next
Next
End Sub
Sub RefontTextRange (oTxtRange As TextRange)
With oTxtRange.Font
' Sets the textrange to the body font. If you want to make some stuff the heading font and some stuff the body font, you need to do more checking before sending here
.Name = "+mn-lt"
End With
End Sub
So that's the start of the solution, but this will get maddening for a few reasons. For tables, you'll have to parse the TextRange of every cell individually and pass those TextRanges on to your Refont sub. For charts, you may have to check for every imaginable chart element before setting your TextRange and refonting (my case was more complex than just setting the font to be the theme font, and I didn't have success trying to format the ChartArea all at once).
Are you having the issue with "floating" shapes inside of a chart? When you say "flow chart," is that an embedded Visio diagram or native SmartArt? There are many ways to skin this cat, but the solution will require you to identify every possible type of text container that can be accessed using VBA.
Here's one more tip that might help you get at those floating shapes within charts:
oShp.Chart.Shapes(1).TextFrame.TextRange.Font.Name = "+mn-lt"
But of course first you need to make sure you've got a chart, that it's got shapes in it, that those shapes have a textframe...
If you leverage the features already built in to PowerPoint, you won't need any code at all. The font theme is built to handle these situations. Format all text with font choices that include the (body) or (headings) tag in the name. Then when you switch the font theme from Arial to Calibri, all text, including charts and SmartArt, will be updated.
For a presentation that is already formatted with local formatting instead of using a font theme, unzipping the file to XML and using a good text editor's Find and Replace functions, you can quickly replace all instances of a font without programming.
Find 'typeface="Arial"'
Replace 'typeface="Calibri"'
Then rezip the files and restore the file ending.
It seems you only need to change the master slides (including notesmaster, slidemaster), instead of working on each slide. Here are my codes
Sub ChangeFont()
' https://stackoverflow.com/a/57212464/2292993
' affect SmartArt font
ActivePresentation.SlideMaster.Theme.ThemeFontScheme.majorFont.Item(1) = "Garamond"
ActivePresentation.SlideMaster.Theme.ThemeFontScheme.minorFont.Item(1) = "Garamond"
For i = 1 To Application.ActivePresentation.NotesMaster.Shapes.Count
With Application.ActivePresentation.NotesMaster.Shapes(i).TextFrame.TextRange.Font
.Name = "Garamond"
If Application.ActivePresentation.NotesMaster.Shapes(i).Name Like "Notes*" Then
.Bold = msoFalse
.Size = 16
End If
End With
Next i
' http://skp.mvps.org/2007/ppt003.htm
' Each design contained a slide master and possibly a title master. Several designs could be stored within a presentation.
' The slide master can contain several custom layouts which can be fully customized.
For Each oDesign In ActivePresentation.Designs
' slide master
Set sm = oDesign.SlideMaster
For j = 1 To sm.Shapes.Count
If sm.Shapes(j).HasTextFrame Then
With sm.Shapes(j).TextFrame.TextRange.Font
.Name = "Garamond"
End With
End If
Next j
' custom layouts
lngLayoutCount = oDesign.SlideMaster.CustomLayouts.Count
For I = 1 To lngLayoutCount
Set oCL = oDesign.SlideMaster.CustomLayouts(I)
For j = 1 To oCL.Shapes.Count
If oCL.Shapes(j).HasTextFrame Then
With oCL.Shapes(j).TextFrame.TextRange.Font
.Name = "Garamond"
End With
End If
Next j
Next I
Next
End Sub
I am very new with Powerpoint VBA and would like to know if there is a short way to transfer one text range from PowerPoint A to another text range located in Powerpoint B in a specific sequence.
Page a1 = b1
Page a2 = b2
Page a3 = b3
The template is changing and I need to adapt 5 powerpoints of 100 slides so I tought it would be easier with this solution.
Thank you in advance for your help.
PRECISION : I don't want to copy and paste the text range but to copy the text inside the range to put it inside the new range. Please find below the code I already have but It doesnt' Paste it inside my new range.
Sub copier_texte() 'je veux copier le contenu de la forme, et non pas la forme en entier
Dim nb_slide As Integer
nb_slide = ActivePresentation.Slides.Count
With ActivePresentation
.Slides(1).Shapes(2).TextFrame.TextRange.Copy 'je sélectionne uniquement le contenu de la forme
For i = 2 To .Slides.Count
.Slides(i).Select
ActiveWindow.View.Paste
Next i
End With
End Sub
Short Answer:
Is there're a short way to transfer one text range from PowerPoint A to another text range located in Powerpoint B?
I think that there's no short way to do it, but let's try something first!
Long Answer:
Note: This solution based not on your desired behaviour (since it's unclear for me and there're many and more "what if" cases), but on similar problem, so I think that it's legit. Anyway it's a good fundament to start of.
Input:
I dont know how exactly your presentations looks like, so I made a reference one (Presentation A) and a "broken" one (Presentation B). Let's take a look on them:
Presentation A (5 slides: 1x"Title slide" with 2 triangle shapes, 3x"Title and Content" slides, 1x"Section Header" slide):
Presentation B (5 slides: 1x"Title slide" missing triangle shapes, 3x"Title and Content" slides with empty/without shapes(placeholders), 1x"Blank" slide (wrong layout)):
Both presentations are in the same folder:
Desired behaviour:
Some sort of synchronisation, if we miss a shape - then create one and put desired text to it, if there's one - put desired text only (based on Presentations A's shape). There're some "what if" cases in logic:
"What if" the number of slides in each presentation isn't equal? In which order compare slides then? (In our case the number is equal, so in code we drop that part and compare slides pair by pair).
"What if" the compared slides have a different layout? (In our case difference in blank layout, so we can easily handle it, but what we should do in general?)
...and many other cases not considered in this solution
Logic:
Logic is plain and simple. The entry point to our routine is in the Presentation A, since it's an our reference file. From that point we acquire a reference to Presentation B (when opening it), and start iteration in two loops (thru each pair of slides and thru reference shapes).
If we found a "broken" (or not so, there's no check for that) shape by a reference one - we put text and some options in it or create a new one shape (or placeholder) otherwise.
Option Explicit
Sub Synch()
'define presentations
Dim ReferencePresentation As Presentation
Dim TargetPresentation As Presentation
'define reference objects
Dim ReferenceSlide As Slide
Dim ReferenceSlides As Slides
Dim ReferenceShape As Shape
'define target objects
Dim TargetSlide As Slide
Dim TargetSlides As Slides
Dim TargetShape As Shape
'define other variables
Dim i As Long
'Setting-up presentations and slide collections
Set ReferencePresentation = ActivePresentation
With ReferencePresentation
Set TargetPresentation = Presentations.Open(FileName:=.Path & "/Presentation B.pptm", _
WithWindow:=msoFalse)
Set ReferenceSlides = .Slides
End With
Set TargetSlides = TargetPresentation.Slides
'Check slide count
If ReferenceSlides.Count <> TargetSlides.Count Then
'What's a desired behaviour for this case?
'We can add slides to target presentation but it adds complexity
Debug.Print "ERROR!" & vbTab & "Reference And Target slides counts are not equal!"
Else
'"mainloop" for slides
For i = 1 To ReferenceSlides.Count
Set ReferenceSlide = ReferenceSlides(i)
Set TargetSlide = TargetSlides(i)
'Check slide layout
If ReferenceSlide.Layout <> TargetSlide.Layout Then
'What's a desired behaviourfor this case?
'We can change layout for target presentation but it adds complexity
'But let's try to change a layout too, since we have an easy case in our example!
Debug.Print "WARNING!" & vbTab & "Reference And Target slides layouts are not same!"
TargetSlide.Layout = ReferenceSlide.Layout
End If
'"innerloop" for shapes (for placeholders actually)
With ReferenceSlide
For Each ReferenceShape In .Shapes
Set TargetShape = AcquireShape(ReferenceShape, TargetSlide, True)
If TargetShape Is Nothing Then
Debug.Print "WARNING!" & vbTab & "There's no shape like " & ReferenceShape.Name
ElseIf TargetShape.HasTextFrame Then
With TargetShape.TextFrame.TextRange
'paste text
.Text = ReferenceShape.TextFrame.TextRange.Text
'and options
.Font.Size = ReferenceShape.TextFrame.TextRange.Font.Size
.Font.Name = ReferenceShape.TextFrame.TextRange.Font.Name
.Font.Color.RGB = ReferenceShape.TextFrame.TextRange.Font.Color.RGB
'...
End With
End If
Next
End With
Next
End If
'Save and close target presentation
Call TargetPresentation.Save
Call TargetPresentation.Close
End Sub
Function AcquireShape(ByRef ReferenceShape As Shape, ByRef TargetSlide As Slide, _
Optional ByVal CreateIfNotExists As Boolean) As Shape
Dim TargetShape As Shape
With ReferenceShape
'seek for existed shape
For Each TargetShape In TargetSlide.Shapes
If TargetShape.Width = .Width And TargetShape.Height = .Height And _
TargetShape.Top = .Top And TargetShape.Left = .Left And _
TargetShape.AutoShapeType = .AutoShapeType Then
Set AcquireShape = TargetShape
Exit Function
End If
Next
'create new
If CreateIfNotExists Then
If .Type = msoPlaceholder Then
Set AcquireShape = TargetSlide.Shapes.AddPlaceholder(.PlaceholderFormat.Type, .Left, .Top, .Width, .Height)
Else
Set AcquireShape = TargetSlide.Shapes.AddShape(.AutoShapeType, .Left, .Top, .Width, .Height)
End If
End If
End With
End Function
Output:
I know that it's hard to find any difference by a screenshot (it's can be even photoshoped, anyway there're a few difference for that purpose), but for a full answer, here it is:
Conclusion:
As you see, it isn't a hard task to achieve something similar to your desire, but complexity of solution depends on inputs and on "what if" cases, hence there's no short way to overcome this task in general (in my humble opinion). Cheers!
Your question has a number of different interpretations, below is my attempt to answer what I believe the question is. There are a number of stage to this solution.
1. Ensure we save the VBA we write
Firstly, we have to assume a master presentation, that is one that will hold the values to be copied into all others. This will need to be saved as a macro enabled presentation (pptm) to allow us to save our VBA. This is done via File > Save-As and while selecting the save location choose PowerPoint Macro-Enabled Presentation in the Save as type box.
2. Enable Windows scripting runtime
Within the pptm 'master' presentation that we now have, open the VBA IDE (Alt+F11). In the menu bar select Tools > References... and tick Microsoft Scripting Runtime from the list that is presented. Click OK to close the references dialog box with your tick remembered. This is needed for some error handling in the code, it checks to see if the presentation exists before trying to open it.
3. Insert the provided code
Right-click on VBAProject in the upper right area (the Project explorer) and select Insert > Module.
In the main editing area paste the below (I have added commenting to describe what is happening): -
Option Explicit
Public Sub Update()
Dim AryPresentations(4) As String
Dim LngPID As Long
Dim FSO As New FileSystemObject
Dim PP_Src As Presentation
Dim PP_Dest As Presentation
Dim Sld_Src As Slide
Dim Sld_Dest As Slide
Dim Shp_Src As Shape
Dim Shp_Dest As Shape
Dim LngFilesMissing As Long
Dim BlnWasOpen As Boolean
'If there is an error, this will handle it and stop the process
On Error GoTo ErrorHandle
'Increase the size of AryPresentations and and the paths as shown in the example below
AryPresentations(0) = "C:\Users\garye\Desktop\PP2.pptx"
AryPresentations(1) = "C:\Users\garye\Desktop\PP3.pptx"
AryPresentations(2) = "C:\Users\garye\Desktop\PP4.pptx"
AryPresentations(3) = "C:\Users\garye\Desktop\PP5.pptx"
AryPresentations(4) = "C:\Users\garye\Desktop\PP6.pptx"
'PP_Src is this, our 'master' presentation
Set PP_Src = ActivePresentation
'This loops through each item in AryPresentations
For LngPID = 0 To UBound(AryPresentations, 1)
'We rememeber if you had it open already as if you did, then we won't close it when we are done
BlnWasOpen = False
'Check all currently open presentations to see if one if the presentation we are due to update
For Each PP_Dest In PowerPoint.Presentations
If Trim(UCase(PP_Dest.FullName)) = Trim(UCase(AryPresentations(LngPID))) Then Exit For
Next
'If it was not already open, check it exists and if it does, then open in
If PP_Dest Is Nothing Then
If FSO.FileExists(AryPresentations(LngPID)) Then
Set PP_Dest = PowerPoint.Presentations.Open(AryPresentations(LngPID))
End If
Else
BlnWasOpen = True
End If
If PP_Dest Is Nothing Then
Debug.Print "File note found"
LngFilesMissing = LngFilesMissing + 1
Else
'The below connects to the slide (Sld_Src) you want to pick up from, the shape (Shp_Src) you want to pick up from and then
'places it in the slide (Sld_Dest) you want it to go to into the shape (Shp_Dest) you want it to go in to
Set Sld_Src = PP_Src.Slides(1)
Set Sld_Dest = PP_Dest.Slides(1)
Set Shp_Src = Sld_Src.Shapes(1)
Set Shp_Dest = Sld_Dest.Shapes(1)
Shp_Dest.TextFrame.TextRange.Text = Shp_Src.TextFrame.TextRange.Text
Set Shp_Dest = Nothing
Set Shp_Src = Nothing
Set Sld_Dest = Nothing
Set Sld_Src = Nothing
'Repeat the above for each piece of text to copy
'Finally save the changes
PP_Dest.Save
'Close the presentation if it was not already open
If Not BlnWasOpen Then PP_Dest.Close
End If
Next
MsgBox "Process complete. Number of missing files: " & LngFilesMissing, vbOKOnly + vbInformation, "Complete"
Exit Sub
ErrorHandle:
MsgBox "There was an error: - " & vbNewLine & vbNewLine & Err.Number & ": " & Err.Description, vbOKOnly + vbExclamation, "Error"
Err.Clear
End Sub
4. Customise code
You'll want to add the paths and location of the changes in and then it should run.
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
(disclaimer: i'm not a VBA programmer by occupation)
Attached to buttons in the Ribbon I have code to toggle the company logo in a Word Document.
One button for the logo type A, a second button for logo type B and a third for no logo (logo is preprintend on paper)
First I remove the logo with removeLogo and then i add it the requested logo with setLogoAt.
The first button click is fine (e.g. for Logo Type A), a logo is added to the header of the document. When i click an other button (e.g for Logo Type B) Word crashes (probably on removing the current logo)
What is wrong with my code (or less probably: with Word?)
Sub setLogoAt(left As Integer, path As String)
Dim logoShape As Shape
Dim anchorLocation As Range
Dim headerShapes As Shapes
Set logoShape = ActiveDocument. 'linebreks for readability
.Sections(1)
.Headers(wdHeaderFooterPrimary)
.Shapes
.AddPicture(FileName:=path, LinkToFile:=False,
SaveWithDocument:=True, left:=0,
Top:=0, Width:=100, Height:=80)
logoShape.name = "CompanyLogo"
logoShape.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
logoShape.RelativeVerticalPosition = wdRelativeVerticalPositionPage
logoShape.Top = CentimetersToPoints(0.1)
logoShape.left = CentimetersToPoints(left)
End Sub
Sub removeLogo()
Dim headerShapes As Shapes
Set headerShapes = ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Shapes
Dim shapeToDelete As Shape
If (headerShapes.Count > 0) Then
If Not IsNull(headerShapes("CompanyLogo")) Then
Set shapeToDelete = headerShapes("CompanyLogo")
End If
End If
If Not (shapeToDelete Is Nothing) Then
shapeToDelete.Delete
End If
End Sub
edit
I steped trough my code. All is fine until I reach the line shapteToDelete.Delete in removeLogo. Here Word crashes hard, even while debugging. I'm using Word 2007 (and that is a requirement)
edit2
I cleared all macros, all normals.dot, all autoloading templates, then created a new document with the two routines above and this test method:
Sub test()
setLogoAt 5, "C:\path\to\logo.jpg"
removeLogo
setLogoAt 6, "C:\path\to\logo.jpg"
End Sub
When I run test it crashes in removeLogo at shapeToDelete.Delete.
Edit 3
I 'solved' the problem by first making the headers/footers view the active view in Word, then deleting the Shape and then returning to normal view. Very strange. It works but as a programmer I'm not happy.
Another potential solution is to try and select the shape first and then delete the selection:
shapeToDelete.Select
Selection.Delete
You would probably want to switch off screen updating if this works, else you'll get flickering as Word moves around the document.
I've experienced this problem before and normally with an automation error: "The object invoked has disconnected from its clients". I haven't yet found a solution.
However a good workaround is to hide the shape rather than delete it.
So:
shapeToDelete.Visible = False
This works:
I only have 2 boxes to hide so this isn't generic
Private Sub btnPrint_Click()
Dim hdrShapes As Shapes
Dim S As Shape
Dim aTohide(2) As String
Dim iNdx, i As Integer
iNdx = 0
' Hide buttons and print
Set hdrShapes = ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Shapes
' GET BUTTON NAMES (ACTUALLY TEXT BOXES
For Each S In hdrShapes
If S.Type = msoTextBox Then
aTohide(iNdx) = S.Name
iNdx = iNdx + 1
End If
Next
' now hide , use the arrays as the for each statement crashes
For i = 0 To 1
hdrShapes(aTohide(i)).Visible = msoFalse
Next
' print it
With ActiveDocument
.PrintOut
End With
' and unhide the buttons
For i = 0 To 1
hdrShapes(aTohide(i)).Visible = msoTrue
Next
Set hdrShapes = Nothing
End Sub