1) Run the following codes. (Run Macro1 for starting.)
2) Start Power Point slide show in order to see what the the following codes are doing.
3) Why Red Rectangles height dont fit Blue Rectangles height?
4) Please click this link in order to see my question
5) Please note that my computer is very old. So this problem may not available for your new computers.
Public RectangleHeight As Double
Public BreakHeight As Double
Public Sub Macro1()
'Test if PowerPoint settings are appropriate for testing the following macros
If ActivePresentation.PageSetup.SlideWidth <> 960 Then MsgBox "PowerPoint settings are not appropriate"
If ActivePresentation.PageSetup.SlideHeight <> 540 Then MsgBox "PowerPoint settings are not appropriate"
'Delete all slides
For i = ActivePresentation.Slides.Count To 1 Step -1
ActivePresentation.Slides(i).Delete
Next i
'Add a blank slide
ActivePresentation.Slides.Add index:=1, Layout:=ppLayoutBlank
ActivePresentation.Slides(1).FollowMasterBackground = False
'Declaration
RectangleHeight = 19.1
BreakHeight = 2
Call Macro2
End Sub
Public Sub Macro2()
'Add 20 Blue Rectangles
For i = 1 To 20
With ActivePresentation.Slides(1).Shapes.AddShape(Type:=msoShapeRectangle, Left:=100, Top:=0, Width:=400, Height:=19.1)
.Name = "BlueRectangle" & i
.Line.Visible = msoFalse
.Fill.ForeColor.RGB = vbBlue
.TextFrame2.TextRange.Text = i
.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignLeft
If i = 1 Then .Top = 120
If i = 2 Then .Top = ((RectangleHeight + BreakHeight) * 1) + 120
If i = 3 Then .Top = ((RectangleHeight + BreakHeight) * 2) + 120
If i = 4 Then .Top = ((RectangleHeight + BreakHeight) * 3) + 120
If i = 5 Then .Top = ((RectangleHeight + BreakHeight) * 4) + 120
If i = 6 Then .Top = ((RectangleHeight + BreakHeight) * 5) + 120
If i = 7 Then .Top = ((RectangleHeight + BreakHeight) * 6) + 120
If i = 8 Then .Top = ((RectangleHeight + BreakHeight) * 7) + 120
If i = 9 Then .Top = ((RectangleHeight + BreakHeight) * 8) + 120
If i = 10 Then .Top = ((RectangleHeight + BreakHeight) * 9) + 120
If i = 11 Then .Top = ((RectangleHeight + BreakHeight) * 10) + 120
If i = 12 Then .Top = ((RectangleHeight + BreakHeight) * 11) + 120
If i = 13 Then .Top = ((RectangleHeight + BreakHeight) * 12) + 120
If i = 14 Then .Top = ((RectangleHeight + BreakHeight) * 13) + 120
If i = 15 Then .Top = ((RectangleHeight + BreakHeight) * 14) + 120
If i = 16 Then .Top = ((RectangleHeight + BreakHeight) * 15) + 120
If i = 17 Then .Top = ((RectangleHeight + BreakHeight) * 16) + 120
If i = 18 Then .Top = ((RectangleHeight + BreakHeight) * 17) + 120
If i = 19 Then .Top = ((RectangleHeight + BreakHeight) * 18) + 120
If i = 20 Then .Top = ((RectangleHeight + BreakHeight) * 19) + 120
End With
Next i
Call Macro3
End Sub
Public Sub Macro3()
'Add 20 Red Rectangles
For i = 1 To 20
With ActivePresentation.Slides(1).Shapes.AddShape(Type:=msoShapeRectangle, Left:=200, Top:=0, Width:=200, Height:=19.1)
.Name = "RedRectangle" & i
.Line.Visible = msoFalse
.Fill.ForeColor.RGB = vbRed
.TextFrame2.TextRange.Text = i
.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignLeft
If i = 1 Then .Top = 120
If i = 2 Then .Top = ((RectangleHeight + BreakHeight) * 1) + 120
If i = 3 Then .Top = ((RectangleHeight + BreakHeight) * 2) + 120
If i = 4 Then .Top = ((RectangleHeight + BreakHeight) * 3) + 120
If i = 5 Then .Top = ((RectangleHeight + BreakHeight) * 4) + 120
If i = 6 Then .Top = ((RectangleHeight + BreakHeight) * 5) + 120
If i = 7 Then .Top = ((RectangleHeight + BreakHeight) * 6) + 120
If i = 8 Then .Top = ((RectangleHeight + BreakHeight) * 7) + 120
If i = 9 Then .Top = ((RectangleHeight + BreakHeight) * 8) + 120
If i = 10 Then .Top = ((RectangleHeight + BreakHeight) * 9) + 120
If i = 11 Then .Top = ((RectangleHeight + BreakHeight) * 10) + 120
If i = 12 Then .Top = ((RectangleHeight + BreakHeight) * 11) + 120
If i = 13 Then .Top = ((RectangleHeight + BreakHeight) * 12) + 120
If i = 14 Then .Top = ((RectangleHeight + BreakHeight) * 13) + 120
If i = 15 Then .Top = ((RectangleHeight + BreakHeight) * 14) + 120
If i = 16 Then .Top = ((RectangleHeight + BreakHeight) * 15) + 120
If i = 17 Then .Top = ((RectangleHeight + BreakHeight) * 16) + 120
If i = 18 Then .Top = ((RectangleHeight + BreakHeight) * 17) + 120
If i = 19 Then .Top = ((RectangleHeight + BreakHeight) * 18) + 120
If i = 20 Then .Top = ((RectangleHeight + BreakHeight) * 19) + 120
End With
Next i
Call Macro4
End Sub
Public Sub Macro4()
'Add motion effect (motion animation) to 20 Red Rectangles.
Dim myDouble As Double
myDouble = (RectangleHeight + BreakHeight) / ActivePresentation.PageSetup.SlideHeight * 100
Debug.Print myDouble '3.90740740740741
For i = 1 To 20
With ActivePresentation.Slides(1).TimeLine.MainSequence.AddEffect(Shape:=ActivePresentation.Slides(1).Shapes("RedRectangle" & i), EffectId:=msoAnimEffectCustom)
With .Behaviors.Add(msoAnimTypeMotion)
.MotionEffect.FromX = 0
.MotionEffect.ToX = 0
.MotionEffect.FromY = 0
If i = 1 Then .MotionEffect.ToY = 3.90740740740741 'myDouble * 1
If i = 2 Then .MotionEffect.ToY = -3.90740740740741 'myDouble * -1
If i = 3 Then .MotionEffect.ToY = 11.7222222222222 'myDouble * 3
If i = 4 Then .MotionEffect.ToY = -3.90740740740741 'myDouble * -1
If i = 5 Then .MotionEffect.ToY = 11.7222222222222 'myDouble * 3
If i = 6 Then .MotionEffect.ToY = 11.7222222222222 'myDouble * 3
If i = 7 Then .MotionEffect.ToY = -11.7222222222222 'myDouble * -3
If i = 8 Then .MotionEffect.ToY = -11.7222222222222 'myDouble * -3
If i = 9 Then .MotionEffect.ToY = 7.81481481481481 'myDouble * 2
If i = 10 Then .MotionEffect.ToY = 19.537037037037 'myDouble * 5
If i = 11 Then .MotionEffect.ToY = 11.7222222222222 'myDouble * 3
If i = 12 Then .MotionEffect.ToY = -19.537037037037 'myDouble * -5
If i = 13 Then .MotionEffect.ToY = -3.90740740740741 'myDouble * -1
If i = 14 Then .MotionEffect.ToY = -3.90740740740741 'myDouble * -1
If i = 15 Then .MotionEffect.ToY = 11.7222222222222 'myDouble * 3
If i = 16 Then .MotionEffect.ToY = 11.7222222222222 'myDouble * 3
If i = 17 Then .MotionEffect.ToY = 11.7222222222222 'myDouble * 3
If i = 18 Then .MotionEffect.ToY = -3.90740740740741 'myDouble * -1
If i = 19 Then .MotionEffect.ToY = -11.7222222222222 'myDouble * -3
If i = 20 Then .MotionEffect.ToY = -39.0740740740741 'myDouble * -10
Debug.Print VarType(.MotionEffect.ToY) '4=vbSingle
Debug.Print .MotionEffect.ToY
'3,907408
'-3,907408
'11,72222
'-3,907408
'11,72222
'11,72222
'-11,72222
'-11,72222
'7,814815
'19,53704
'11,72222
'-19,53704
'-3,907408
'-3,907408
'11,72222
'11,72222
'11,72222
'-3,907408
'-11,72222
'-39,07407
End With
.Timing.Duration = 2
.Timing.TriggerDelayTime = 1
.Timing.TriggerType = msoAnimTriggerWithPrevious
End With
Next i
End Sub