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
Related
I'm struggling with charts in an Access report. The default Y axis minimum is zero, I would like to change this dynamically as the report loads.
I have tried a number of options using variations on the code below but to no avail. Could someone point me in the direction where I can access and modify the Y axis minimum value. I have tried to use Chart.PrimaryValuesAxisMaximum but this has always resulted in a 'Doesn't support this property or method' Error
Using Office Professional Plus 2019. VB 7.1
Private Sub Report_Load()
Dim MyChart As Object
Dim MyAxis As ChartAxisCollection
Set MyChart = Me.Graph4
Debug.Print MyChart.Name 'This appears to show the chart is available
Set MyAxis = MyChart.ChartAxisCollection
For Each MyAxis In MyChart
Debug.Print MyAxis.Count
Next
End Sub
Any help would be very much appreciated.
Thank you
I can give example from my project which uses classic chart control, not Modern Charts. This procedure is called by a form button click and a report Detail section Format event.
Sub FormatVibGraph(strObject As String, strLabNum As String, booMetric As Boolean)
'format Vibratory graph form and report
Dim obj As Object
Dim gc As Object
Dim MinDD As Double
Dim MaxDD As Double
MinDD = Nz(DMin("Den", "GraphVibratory"), 0)
MaxDD = Nz(DMax("Den", "GraphVibratory"), 0)
If strObject Like "Lab*" Then
Set obj = Reports(strObject)
Else
Set obj = Forms(strObject).Controls("ctrVibratory").Form
End If
Set gc = obj("gphDensity")
gc.Activate
If MinDD > 0 Then
With gc
.Axes(xlValue).MinimumScale = MinDD
If booMetric = True Then
MaxDD = Int(MaxDD / 100) * 100 + 100
MinDD = MaxDD - 1000
.Axes(xlValue).MaximumScale = MaxDD
.Axes(xlValue).MinimumScale = MinDD
.Axes(xlValue).MajorUnit = 200
.Axes(xlValue).MinorUnit = 40
Else
MaxDD = Int(MaxDD / 5) * 5 + 5
MinDD = MaxDD - 50
.Axes(xlValue).MaximumScale = MaxDD
.Axes(xlValue).MinimumScale = MinDD
.Axes(xlValue).MajorUnit = 10
.Axes(xlValue).MinorUnit = 2
End If
.Axes(xlValue, xlPrimary).HasTitle = True
If booMetric = True Then
.Axes(xlValue, xlPrimary).AxisTitle.Text = "Max. Dry Density, Kg/cu.m"
End If
.Axes(xlCategory, xlPrimary).HasTitle = True
If booMetric = True Then
.Axes(xlCategory, xlPrimary).AxisTitle.Text = "Percent Passing 4.75 mm Sieve"
End If
End With
End If
End Sub
So your code might be simply:
Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer)
Dim MyChart As Object
Set MyChart = Me.Graph4
MyChart.Axes(xlValue).MinimumScale = something
End Sub
I want to change the same title of X-Y axis and format in many graphs at once using VBA.
I made code like below.
If I have 3 graphs, to change the second graph with the same X-Y axis titles and format, I copy and paste this code and change from ChartObjects(1) to ChartObjects(2), and also to change third graph, I also copy and paste this code again, and change as ChartObjects(3).
However, if I have 100 graphs, it seems impossible to copy and paste same codes 100 times, and change each ChartObjects.
Are there any methods to change X-Y axis titles in many graphs more easily?
Many thanks,
Sub axis()
Dim xytitle As chart
Set xytitle = Worksheets("graph").ChartObjects(1).chart
With xytitle.axes(xlCategory)
.HasTitle = True
.AxisTitle.Text = "Treatment"
.AxisTitle.Font.Size = 11
.AxisTitle.Font.Bold = False
End With
With xytitle.axes(xlValue)
.HasTitle = True
.AxisTitle.Text = "Grain weight"
.MaximumScale = 60
.MajorUnit = 10
.AxisTitle.Font.Size = 11
.AxisTitle.Font.Bold = False
End With
End Sub
I figured out the solution!! Thank you:)
Sub axis()
Dim xytitle As Chart
Dim i As Integer
For i = 1 To 4
Set xytitle = Worksheets("test").ChartObjects(i).Chart
With xytitle.Axes(xlCategory)
.HasTitle = True
.AxisTitle.Text = "Treatment"
.AxisTitle.Font.Size = 11
.AxisTitle.Font.Bold = False
End With
With xytitle.Axes(xlValue)
.HasTitle = True
.AxisTitle.Text = "Grain weight"
.MaximumScale = 60
.MajorUnit = 10
.AxisTitle.Font.Size = 11
.AxisTitle.Font.Bold = False
End With
Next
End Sub
I have six objects, all in a given fixed position, as depicted below
The text boxes all have the same size. I would like to automate the counterclockwise rotation of all text boxes, so that when I use the macro, it will rotate the text 60ยบ ccw (thus BETA becomes ALPHA, ALPHA becomes ZETA and so forth). However, I'm completely clueless on how to write it in VBA! I know that I can set the textbox using
Set myDocument = ActivePresentation.Slides(1)
myDocument.Shapes.AddTextbox(Type:=msoTextOrientationHorizontal, _
Left:=400, Top:=100, Width:=160, Height:=30).TextFrame _
.TextRange.Text = "ALPHA"
But, I'm clueless on how to rotate them. Another alternative would be to create these six TextBoxes and create a function that only changed the text variable, but my VBA knowledge is very elementary, and I wouldn't even know where to begin :\
Can anyone be so kind as to give me a small help?
If you mean to rotate their position and not their orientation it could look like this:
Option Explicit
Public Sub ExampleRotatePositions()
Dim myDocument As Slide
Set myDocument = ActivePresentation.Slides(1)
Dim TextBox(1 To 6) As Shape
'create the textboxes in your desired position.
Set TextBox(1) = myDocument.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, Left:=100, Top:=100, Width:=160, Height:=30)
TextBox(1).TextFrame.TextRange.Text = "ALPHA"
Set TextBox(2) = myDocument.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, Left:=200, Top:=100, Width:=160, Height:=30)
TextBox(2).TextFrame.TextRange.Text = "BETA"
Set TextBox(3) = myDocument.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, Left:=300, Top:=100, Width:=160, Height:=30)
TextBox(3).TextFrame.TextRange.Text = "GAMMA"
Set TextBox(4) = myDocument.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, Left:=400, Top:=100, Width:=160, Height:=30)
TextBox(4).TextFrame.TextRange.Text = "DELTA"
Set TextBox(5) = myDocument.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, Left:=500, Top:=100, Width:=160, Height:=30)
TextBox(5).TextFrame.TextRange.Text = "EPSILON"
Set TextBox(6) = myDocument.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, Left:=600, Top:=100, Width:=160, Height:=30)
TextBox(6).TextFrame.TextRange.Text = "ZETA"
MsgBox "Start rotating now"
'remember last position
Dim LastLeft As Single
LastLeft = TextBox(UBound(TextBox)).Left
Dim LastTop As Single
LastTop = TextBox(UBound(TextBox)).Top
'rotate position
Dim iTextBox As Long
For iTextBox = UBound(TextBox) - 1 To LBound(TextBox) Step -1
TextBox(iTextBox + 1).Left = TextBox(iTextBox).Left
TextBox(iTextBox + 1).Top = TextBox(iTextBox).Top
Next iTextBox
'move first to last position
TextBox(LBound(TextBox)).Left = LastLeft
TextBox(LBound(TextBox)).Top = LastTop
End Sub
Group them using the ShapeRange.Group method and then rotate the group:
Set myDocument = ActivePresentation.Slides(1)
With myDocument.Shapes
.AddShape(msoShapeCan, 50, 10, 100, 200).Name = "shpOne"
.AddShape(msoShapeCube, 150, 250, 100, 200).Name = "shpTwo"
With .Range(Array("shpOne", "shpTwo")).Group
.Fill.PresetTextured msoTextureBlueTissuePaper
.Rotation = 45
.ZOrder msoSendToBack
End With
End With
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.