オートシェイプを指定座標まで動かす - Infomentのブログ～Excel VBA奮闘記～

一昨日は、オートシェイプを速度を変えて動かしてみた。
infoment.hatenablog.com
しかし実際にやりたいのは、始点と終点を指定して、その間を動かすこと。
今日は、これに挑戦する。
f:id:Infoment:20181202161252p:plain
斜めに動かそうとすると、何かと煩雑だ。そこで横方向にどれだけか動かして、それに応じて縦も動かすことにする。そのために、昨日は一次関数のクラスモジュールを準備した。
infoment.hatenablog.com
さて、最初に沢山動いて、最後にじわっと目的地に到着するには、どうすれば良いか。今回は試みで、一回当たりの移動距離を目的地までのA％に設定する、という方式をとってみた。
例）一回の移動距離75％で、100ｍ移動する場合。

１秒後：100mの75% ⇒ 75m　残り25m
２秒後：25mの75% ⇒ 75m + 18.75m = 93.75m　残り6.25m
３秒後：6.25mの75% ⇒ 93.75m + 4.6875m =98.4375m

いつまで経ってもゴールできないので、どこかの時点で100m地点に移動させる。

では、点x1からx2まで移動するとき、その75%の位置はどう表されるか。計算してみた。
f:id:Infoment:20181202164550p:plain

ちなみに、x1がx2より大きい場合はどうか。
f:id:Infoment:20181202164842p:plain

面白いことに、結果は同じになった（当たり前のこと？）。従って、右から左に動くのか、左から右に動くのかは、気にする必要が無いことになる。
以上を踏まえ、色々と調整したコードがこちら。

標準モジュール

Sub RandomMove()

    Dim myShape
    Set myShape = ActiveSheet.Shapes(1)
    
    Dim LFC As LinearFunctionClass
    Set LFC = New LinearFunctionClass
    
    ' 移動前の位置
    Dim x1 As Double: x1 = myShape.Left
    Dim y1 As Double: y1 = myShape.Top
    
    ' 移動後の位置を乱数で決定。
    ' 元の位置から-100 ～ 100の範囲とする。
    ' 200×200の範囲から飛び出さないようにする。
    Dim dx As Double: dx = Rnd * 200 - 100
    If x1 >= 200 Then dx = -50
    Dim dy As Double: dy = Rnd * 200 - 100
    If y1 >= 200 Then dy = -50
    
    ' 移動後の位置
    Dim x2 As Double: x2 = x1 + dx
    Dim y2 As Double: y2 = y1 + dy
    
    ' 始点と終点から、一次関数の式を求める。
    Dim myCoordinateSeq(1 To 2) As Variant
        myCoordinateSeq(1) = Array(x1, y1)
        myCoordinateSeq(2) = Array(x2, y2)
        
        LFC.CoordinateSeq = myCoordinateSeq
    
    ' 目的地に到達するまでの移動回数を設定。
    Dim iMax As Long
        iMax = 50
    
    ' 移動回数の一歩手前まで動かす。
    Dim x As Double
    Dim i As Long
        For i = 1 To iMax - 1
            x = (6 * x1 + x2) / 7
            myShape.Left = x
            myShape.Top = LFC.y(x)
            Application.Wait [now()+"0:00:00.01"]
            x1 = x
        Next
        
    ' 最後の一回で、目的地に到達。
        myShape.Left = x2
        myShape.Top = y2
        
End Sub

連続的に、50回ほど動かしてみる。

Sub MoveTest()
    ActiveSheet.Shapes(1).Top = 200
    ActiveSheet.Shapes(1).Left = 200
    Dim i As Long
    For i = 1 To 50
        Call RandomMove
    Next
End Sub

クラスモジュール（LinearFunctionClass）

一部を微修正したため、念のため載せておく。

Option Explicit
Public CoordinateSeq As Variant

Public Property Get dx() As Double
    dx = CoordinateSeq(2)(0) - CoordinateSeq(1)(0)
End Property

Public Property Get dy() As Double
    dy = CoordinateSeq(2)(1) - CoordinateSeq(1)(1)
End Property

Public Property Get Slope() As Double
    Slope = dy / dx
End Property

Public Property Get Intercept() As Double
    Intercept = CoordinateSeq(1)(1) - Slope * CoordinateSeq(1)(0)
End Property

Public Function y(x As Double) As Double
    y = Slope * x + Intercept
End Function