I'm generating a largish presentation to run during a game showing players what stages they should have reached (the game isn't important). Each slide has a hollow circle/donut sweeping out an overall time while pictures appear showing the stage players should have reached. (The slides are being macro-generated as there are many variations, differing only slightly, including in timing details.)
When there are no sound effects, the macro works perfectly. When a sound effect is added to any .effect, the entire animation sequence is changed significantly and incorrectly. Timings that are assigned to start "With Previous" become "After Previous", durations are changed, the fade effect is lost. I've tried changing the sequence of the effect attribute assignments, adding a dummy shape and assigning the sound to that, no success.
Copying and running this simplified version demonstrates what happens - the same sub is used to generate two single-slide presentations on the desktop which should be the same other than sound effects, but are not.
Const CycleTime = 10
' CycleTime = Seconds for which the circular sweep should run;
' A shape appears for the first half then fades to be replaced by a second shape.
Dim fn$
Public Sub MakeTestPresentations()
fn$ = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "Test#" & Format(Now(), "hhmmss")
Call MakeASlide(UsingSound:=False)
Call MakeASlide(UsingSound:=True)
Exit Sub
End Sub
Sub MakeASlide(ByVal UsingSound As Boolean)
Dim sldThis As Slide, swp As Shape, shp1 As Shape, shp2 As Shape
' New blank presentation
Set pptSource = Presentations.Add
' Add a blank slide
Set sldThis = pptSource.Slides.Add(Index:=1, Layout:=ppLayoutBlank)
' Add a donut which will be the overall timer, set to sweep in CycleTime seconds
Set swp = sldThis.Shapes.AddShape(msoShapeDonut, 525, 83, 369, 369)
swp.Fill.ForeColor.RGB = RGB(0, 0, 128)
sldThis.TimeLine.MainSequence.AddEffect(Shape:=swp, effectId:=msoAnimEffectWheel, Trigger:=msoAnimTriggerWithPrevious).Timing.Duration = CycleTime
' Add a shape which should appear for the first half of the cycle, fading in & out
Set shp1 = sldThis.Shapes.AddShape(msoShapeCloud, 83, 83, 369, 369)
shp1.Fill.ForeColor.RGB = RGB(0, 255, 0)
With sldThis.TimeLine.MainSequence.AddEffect(Shape:=shp1, effectId:=msoAnimEffectFade, Trigger:=msoAnimTriggerWithPrevious)
.Timing.TriggerDelayTime = 0
.Timing.Duration = CycleTime / 2
If UsingSound Then .EffectInformation.SoundEffect.Name = "Laser"
End With
With sldThis.TimeLine.MainSequence.AddEffect(Shape:=shp1, effectId:=msoAnimEffectFade, Trigger:=msoAnimTriggerWithPrevious)
.Timing.TriggerDelayTime = CycleTime / 2
.Exit = True
End With
' Add a shape which should appear for the second half of the cycle, fading in & out
Set shp2 = sldThis.Shapes.AddShape(msoShape16pointStar, 83, 83, 369, 369)
shp2.Fill.ForeColor.RGB = RGB(255, 0, 0)
With sldThis.TimeLine.MainSequence.AddEffect(Shape:=shp2, effectId:=msoAnimEffectFade, Trigger:=msoAnimTriggerWithPrevious)
.Timing.TriggerDelayTime = CycleTime / 2
.Timing.Duration = CycleTime / 2
If UsingSound Then .EffectInformation.SoundEffect.Name = "Drum Roll"
End With
With sldThis.TimeLine.MainSequence.AddEffect(Shape:=shp2, effectId:=msoAnimEffectFade, Trigger:=msoAnimTriggerWithPrevious)
.Timing.TriggerDelayTime = CycleTime
.Exit = True
End With
' Save the presentation
pptSource.SaveCopyAs fn$ & IIf(UsingSound, " (WITH Sound)", " (NO Sound)"), ppSaveAsDefault
pptSource.Close
Exit Sub
End Sub
I have a simple sub for adding background music:
Sub insert_rnd_back(Track As String)
Dim oSlide As Slide
Dim oShp As Shape
Dim oEffect As Effect
Set oSlide = ActivePresentation.Slides(1)
Set oShp = oSlide.Shapes.AddMediaObject2(Track, True, False, 10, 610)
With oShp.AnimationSettings.PlaySettings
.PlayOnEntry = msoTrue
.PauseAnimation = msoFalse
.StopAfterSlides = ActivePresentation.Slides.Count
.LoopUntilStopped = msoTrue
.HideWhileNotPlaying = msoTrue
.RewindMovie = msoTrue
End With
oShp.MediaFormat.Volume = 0.5
End Sub
And I am adding sounds to individual shapes with this:
Dim oShp As Shape
Dim oEffect As Effect
Set oShp = ActivePresentation.Slides(sld).Shapes.AddMediaObject2( _
aud & sityvebi(sld) & ".wav", True, False, 100, 610)
Set oEffect = ActivePresentation.Slides(sld).TimeLine.MainSequence.AddEffect( _
oShp, msoAnimEffectMediaPlay, , msoAnimTriggerAfterPrevious)
oShp.MediaFormat.Volume = 1
I want to give glow/shrink animation to a text in PowerPoint using VBA.
I can not configure it to give size 110% (it takes default size 150%) & also want a smooth end to 2 sec.
I tried the scale property but did not get my result.
Set osld = ActivePresentation.Slides(1)
Set dshp = osld.Shapes("LeftText")
osld.TimeLine.MainSequence.AddEffect dshp, msoAnimEffectGrowShrink, , msoAnimTriggerWithPrevious
For C = 1 To osld.TimeLine.MainSequence.Count
Set oeff = osld.TimeLine.MainSequence(C)
oeff.Timing.TriggerType = msoAnimTriggerWithPrevious
oeff.Timing.TriggerDelayTime = 2
'oeff.Behaviors.Add(msoAnimTypeScale).ScaleEffect.ByY = 110
'oeff.Behaviors.Add(msoAnimTypeScale).ScaleEffect.ByX = 110
Next C
Give this a try:
Sub GlowAnimationOptions()
Dim effGrowShrink As Effect
Set osld = ActivePresentation.Slides(1)
Set dshp = osld.Shapes("LeftText")
Set effGrowShrink = osld.TimeLine.MainSequence.AddEffect(Shape:=dshp, EffectID:=msoAnimEffectGrowShrink, Trigger:=msoAnimTriggerWithPrevious)
With effGrowShrink
With .EffectParameters
.Size = 120
End With
With .Timing
.SmoothEnd = msoTrue
.Duration = 4
End With
End With
End Sub
I'm dealing with an issue where my VBA code somehow chooses not to include the whole chart when copying to a powerpoint slide. I have the following code:
This code creates my Doughnut chart from 2 numbers.
Function CreateTwoValuesPie(ByVal X As Long, ByVal Y As Long) As Chart
'Returnerer
Set CreateTwoValuesPie = charts.Add
CreateTwoValuesPie.ChartType = XlChartType.xlDoughnut
With CreateTwoValuesPie.SeriesCollection.NewSeries
.Values = Array(X, Y)
End With
With CreateTwoValuesPie
.ChartArea.Format.Fill.Visible = msoFalse
.ChartArea.Format.Line.Visible = msoFalse
.Legend.Delete
.ChartGroups(1).DoughnutHoleSize = 70
With .SeriesCollection(1)
.Points(1).Format.Fill.ForeColor.RGB = RGB(255, 158, 77) 'Score Orange
.Points(2).Format.Fill.ForeColor.RGB = RGB(175, 171, 170) '10 - Score Grå
.Format.Line.ForeColor.RGB = RGB(255, 255, 255)
End With
End With
End Function
This code store the different object and numbers:
Set oPPTApp = CreateObject("PowerPoint.Application")
Set oPPTFile = oPPTApp.Presentations.Open(PP)
Set oPPTShape10 = oPPTFile.Slides(1)
d11 = Format(Dashboard.EAScore1.Caption, "Standard")
Set ch1 = CreateTwoValuesPie(d11, 10 - d11)
ch1.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
With oPPTShape10.Shapes.Paste
.Top = 127
.Width = 177
.Left = 393
End With
The code works fine and creates the correct chart from the number (d11, 10-d11) but when I copy the figure and insert it into my powerpoint slide oPPTShape10 it only copy part of the chart.
This can be seen in the image below:
The correct should've look like the one in the image below:
It worked some days ago and I haven't changed anything since then? Does anyone know how I can make it show the whole figure instead of only the topleft corner of it?
I'm trying to make text in the data label of the chart with shadow effect (that shadow effect which you have at top of the PowerPoint menu), but I'm unable to make it work, dataLabels.shadow or dataLabels.font.shadow makes the frame shadowed, not the text.
I was googling a lot, I have found out this could be possible via TextFormat or TextFormat2 property, unfortunately I'm not able to access it for the text in the data label anyhow. My current code, lines after comment does not work:
For Each Shape In Slide.Shapes
If Shape.HasChart Then
Dim i As Integer
Dim v As Variant
Set pts = Shape.Chart.SeriesCollection(1).Points
For Each s In Shape.Chart.SeriesCollection
v = s.Values
If s.Name <> "XXX_XXX" Then
If v(pts.Count) >= 0.05 Then
s.Select
s.Points(pts.Count).Select
s.Points(pts.Count).ApplyDataLabels
s.DataLabels.Font.Color = s.Border.Color
s.DataLabels.Font.Size = 20
s.DataLabels.Font.Name = "Calibri"
's.DataLabels.Shadow = True
's.DataLabels.Font.Shadow = msoTrue
's.Points(pts.Count).DataLabel.Font.Shadow = msoTrue
's.Points(pts.Count).DataLabel(pts.Count).TextFrame.TextRange.Font.Shadow = msoTrue
End If
End If
Next s
End If
Next Shape
If someone will have problems with simillar case I have found the answer :)
The shadow (ribbon like shadow) for data label text/value is done via TextRange2 property, but I was missing Format. Like this :
Dim tr As TextRange2
Set tr = s.DataLabels(pts.Count).Format.TextFrame2.TextRange
With tr.Font.Shadow
.OffsetX = 10
.OffsetY = 10
.Size = 1
.Blur = 4
.Transparency = 0.5
.Visible = True
End With
I am using a small VBA program to apply some text in the background. I am able to apply watermark but if I use any image in the presentation then the watermark goes behind that image. Is there any way to keep the watermark always in front.
I am using this code to apply watermark :
Dim cntDesigns As Integer
cntDesigns = ActivePresentation.Designs.Count
For iter = 1 To cntDesigns
Dim curDesign As Design
Set curDesign = ActivePresentation.Designs.Item(iter)
' EnumerateMasters
Dim masterCount As Integer
masterCount = 1
Dim masters(100) As Master
Set masters(masterCount) = curDesign.SlideMaster
Dim cntLayouts As Integer
cntLayouts = curDesign.SlideMaster.CustomLayouts.Count
For Layout = 1 To cntLayouts
Dim curLayout As CustomLayout
Set curLayout = curDesign.SlideMaster.CustomLayouts(Layout)
If curLayout.DisplayMasterShapes = msoFalse Then
masterCount = masterCount + 1
Set masters(masterCount) = curLayout
End If
Next Layout
For masterIter = 1 To masterCount
Dim shape As shape
Set shape = masters(masterIter).Shapes.AddTextbox(msoTextOrientationHorizontal, 0#, 0#, 100#, 100#)
shape.TextEffect.Text = "Watermark"
shape.Height = 100
shape.Width = 100
shape.TextFrame2.WordWrap = msoTrue
shape.TextFrame2.WarpFormat = msoWarpFormat1
shape.Left = 100
shape.Top = 200
Next masterIter
Next iter
No, anything you put on top of something will cover it up. There's no "Keep this shape on top" command.
You can, however, trap one or more events that are likely to happen often (selection change, for example) and let that event trigger code that looks at each shape on the slide(s) and moves your watermark shape to front if it's not already there.