• If you would like to post, please check out the MrExcel Message Board FAQ and register here. If you forgot your password, you can reset your password.
  • Excel articles and downloadable files provided in the articles have not been reviewed by MrExcel Publishing. Please apply the provided methods / codes and open the files at your own risk. If you have any questions regarding an article, please use the Article Discussion section.
Worf

A ricocheting ball with VBA

Excel Version
  1. 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.
ric.png


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 ********************************************************
Author
Worf
Views
1,408
First release
Last update
Rating
0.00 star(s) 0 ratings

More Excel articles from Worf

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top