- Excel Version
- 2016
Using trigonometry, it is possible to calculate the path an object will follow when hitting the inside walls of a closed rectangular area. Here are the relevant points of the code:
- The input variables are the starting position and angle, between 1 and 89 degrees. The values are hardcoded but this is easily modifiable.
- Basically, the code finds the point where two lines intersect, the object path and one of the four reference lines that form the rectangle.
- A chart is produced, visually representing the solution. The number of steps can be altered at the main loop.
- Also, an existing PowerPoint presentation is opened and an animation corresponding to the Excel chart is added. Excel data is converted because the chart’s origin is the lower left corner while the slide’s origin is the upper left corner.
VBA Code:
Dim x!(1 To 3), y!(1 To 3), deg, rad!, tg!, res(), rig As Boolean, _
down As Boolean, tp, bt, lf, rg, fx, fy
Const maxx = 20, maxy = 10
Sub Main()
ReDim tp(1 To 4), bt(1 To 4), lf(1 To 4), rg(1 To 4), res(1 To 2)
Dim i%, keep(1 To 2), s As Series, co As Shape, ns%
tp(1) = 0: tp(2) = maxy: tp(3) = maxx: tp(4) = maxy ' top line
bt(1) = 0: bt(2) = 0: bt(3) = maxx: bt(4) = 0 ' bottom line
lf(1) = 0: lf(2) = 0: lf(3) = 0: lf(4) = maxy ' left line
rg(1) = maxx: rg(2) = 0: rg(3) = maxx: rg(4) = maxy ' right line
rig = True
ns = 23
ReDim fx(1 To ns), fy(1 To ns)
down = False
x(1) = 16: y(1) = 3 ' starting point
res(1) = x(1): res(2) = y(1)
x(2) = x(1) + maxx
y(2) = y(1): x(3) = x(2)
deg = 20 ' degrees
rad = deg * 3.14159 / 180 ' radians
tg = Tan(rad)
y(3) = tg * (x(2) - x(1)) + y(2)
fx(1) = x(1): fy(1) = y(1)
For i = 2 To ns ' number of steps
If rig And down Then
keep(1) = res(1): keep(2) = res(2)
Walk rg, False, False
If res(1) = 0 And res(2) = 0 Then
res(1) = keep(1): res(2) = keep(2)
Walk bt, False, False
down = Not down
Else
rig = Not rig
End If
ElseIf rig And Not down Then ' going right and up
keep(1) = res(1): keep(2) = res(2)
Walk tp, False, True
If res(1) = 0 And res(2) = 0 Then
res(1) = keep(1): res(2) = keep(2)
Walk rg, False, True
rig = Not rig
Else
down = Not down
End If
ElseIf Not rig And down Then ' left and down
keep(1) = res(1): keep(2) = res(2)
Walk bt, True, False
If res(1) = 0 And res(2) = 0 Then ' no valid intersection
res(1) = keep(1): res(2) = keep(2)
Walk lf, True, False
rig = Not rig
Else
down = Not down
End If
ElseIf Not rig And Not down Then ' going left and up
keep(1) = res(1): keep(2) = res(2)
Walk lf, True, True
If res(1) = 0 And res(2) = 0 Then
res(1) = keep(1): res(2) = keep(2)
Walk tp, True, True
down = Not down
Else
rig = Not rig
End If
End If
fx(i) = res(1): fy(i) = res(2)
Next
Set co = ActiveSheet.Shapes.AddChart2(240, xlXYScatterLines)
Set s = co.Chart.SeriesCollection.NewSeries
s.Values = fy
s.XValues = fx
With co.Chart
.ChartTitle.Text = "Start is " & fx(1) & "," & fy(1) & " - " & _
WorksheetFunction.Unichar(952) & "=" & deg
If .SeriesCollection.Count > 1 Then .SeriesCollection(1).Delete
.Axes(xlValue).MaximumScale = maxy
.Axes(xlCategory).MaximumScale = maxx
.Axes(xlCategory).MinimumScale = 0
.Axes(xlValue).MinimumScale = 0
End With
PPoint
End Sub
Sub Walk(con, left As Boolean, up As Boolean)
Dim hor
If left Then hor = -maxx
If Not left Then hor = maxx
x(1) = res(1): y(1) = res(2)
x(2) = x(1) + hor
y(2) = y(1): x(3) = x(2)
y(3) = tg * (x(2) - x(1)) + y(2) ' it is a triangle
If Not up And Not left Then y(3) = 2 * y(1) - y(3) ' correct quadrant
If up And left Then y(3) = 2 * y(1) - y(3)
res = inter(x(1), y(1), x(3), y(3), con)
End Sub
Function inter(x1!, y1!, x2!, y2!, con) ' intersection between two lines
Dim tp, den, ua!, ub!, x3!, y3!, x4!, y4!
x3 = con(1): y3 = con(2): x4 = con(3): y4 = con(4)
ReDim tp(1 To 2)
If ((x1 = x2 And y1 = y2) Or (x3 = x4 And y3 = y4)) Then
tp(1) = 0
tp(2) = 0
inter = tp
Exit Function
End If
den = ((y4 - y3) * (x2 - x1) - (x4 - x3) * (y2 - y1))
If den = 0 Then
tp(1) = 0
tp(2) = 0
inter = tp
Exit Function
End If
ua = ((x4 - x3) * (y1 - y3) - (y4 - y3) * (x1 - x3)) / den
ub = ((x2 - x1) * (y1 - y3) - (y2 - y1) * (x1 - x3)) / den
If ua < 0 Or ua > 1 Or ub < 0 Or ub > 1 Then
tp(1) = 0
tp(2) = 0
inter = tp
Exit Function
End If
tp(1) = x1 + ua * (x2 - x1)
tp(2) = y1 + ua * (y2 - y1)
inter = tp
End Function
Sub PPoint()
Dim w%, h%, s As PowerPoint.Shape, ef As Effect, _
am As AnimationBehavior, sl As Slide, i%, ppapp As Object, pres As Presentation
On Error Resume Next
Set ppapp = GetObject(, "powerpoint.application")
If Err.Number <> 0 Then Set ppapp = CreateObject("powerpoint.application")
Err.Clear
On Error GoTo 0
ppapp.Visible = True
Set pres = ppapp.presentations.Open("c:\test\pantone.pptm") ' your path here
w = pres.PageSetup.SlideWidth / 21
h = pres.PageSetup.SlideHeight / 21
Set sl = pres.Slides(3)
For i = LBound(fx) To UBound(fx)
If Abs(fx(i)) < 0.000001 Then fx(i) = 0
If Abs(fy(i)) < 0.000001 Then fy(i) = 0
fx(i) = Round(fx(i) * 95 / maxx, 0) ' PowerPoint origin is the upper left corner
fy(i) = Round((maxy - fy(i)) * 95 / maxy, 0)
Next
Set s = sl.Shapes.AddShape(msoShapeMoon, 10, 10, w, h)
For i = LBound(fx) To UBound(fx) - 1
Set ef = sl.TimeLine.MainSequence.AddEffect(Shape:=s, EffectId:=0, _
Trigger:=msoAnimTriggerAfterPrevious)
Set am = ef.Behaviors.Add(msoAnimTypeMotion)
With am.MotionEffect
.FromX = fx(i)
.FromY = fy(i)
.ToX = fx(i + 1)
.ToY = fy(i + 1)
End With
Next
End Sub
Rem ********************************************************
