線を引いて動かす ③ 動かすのを諦めて書き直す - Infomentのブログ～Excel VBA奮闘記～

ある理由から唐突に、Excelで線を引いて、それを動かしたくなった。
前回は線を引いて、それを滑らかに動かそうとして派手に失敗した。
infoment.hatenablog.com

今日は、その解決に取り組んでみよう。
f:id:Infoment:20200905080329p:plain

前回の失敗は、考えてみれば当然のことで。始点から幅と高さをする場合、
幅と高さを負の値で指定できなかったのだ。始点より終点が左にある場合、
幅がマイナス値となって、それは強制的に０になるため、まっすぐ立った
線がツイ～と走る結果となったわけだ。
f:id:Infoment:20200903233019g:plain

これを解決するためには、常に始点と終点の位置関係を確認する必要が
ありそうだが、とても複雑になりそう。

ということでこれについては諦めて、安直だが、書き直すことにしてみた。

Sub test()
    On Error Resume Next
    ActiveSheet.Shapes.SelectAll
    Selection.Delete

    ' 移動回数の設定。
    Dim MovingTimes As Long
        MovingTimes = 50

    ' 始点のx,y座標。
    Dim Sx() As Double: ReDim Sx(MovingTimes)
    Dim Sy() As Double: ReDim Sy(MovingTimes)
    ' 終点のx,y座標
    Dim Ex() As Double: ReDim Ex(MovingTimes)
    Dim Ey() As Double: ReDim Ey(MovingTimes)
    
        ' 初期値設定（てきとー）。
        Sx(0) = WorksheetFunction.RandBetween(0, 1000)
        Sy(0) = WorksheetFunction.RandBetween(0, 1000)
        Ex(0) = WorksheetFunction.RandBetween(0, 1000)
        Ey(0) = WorksheetFunction.RandBetween(0, 1000)
    
    ' 移動後の座標設定。
        Sx(MovingTimes) = WorksheetFunction.RandBetween(0, 1000)
        Sy(MovingTimes) = WorksheetFunction.RandBetween(0, 1000)
        Ex(MovingTimes) = WorksheetFunction.RandBetween(0, 1000)
        Ey(MovingTimes) = WorksheetFunction.RandBetween(0, 1000)
        
    ' 一回当たりの移動量（始点）
    Dim dSx As Double
        dSx = (Sx(MovingTimes) - Sx(0)) / MovingTimes
    Dim dSy As Double
        dSy = (Sy(MovingTimes) - Sy(0)) / MovingTimes

    ' 一回当たりの移動量（終点）
    Dim dEx As Double
        dEx = (Ex(MovingTimes) - Ex(0)) / MovingTimes
    Dim dEy As Double
        dEy = (Ey(MovingTimes) - Ey(0)) / MovingTimes

    ' 線を描画。強引にWithで、一行の長さを抑えてみた。
    Dim myLine() As Shape
    ReDim myLine(MovingTimes)
    
    Dim i As Long
        For i = 1 To MovingTimes - 1
            Sx(i) = Sx(i - 1) + dSx
            Sy(i) = Sy(i - 1) + dSy
            Ex(i) = Ex(i - 1) + dEx
            Ey(i) = Ey(i - 1) + dEy
        Next
    
    ' 設定した移動回数で変形。
        For i = 0 To MovingTimes
'            If i >= 1 Then myLine(i - 1).Delete
            With ActiveSheet.Shapes
                Set myLine(i) = .AddConnector(msoConnectorStraight, _
                                   Sx(i), Sy(i), _
                                   Ex(i), Ey(i))
            End With
            Application.Wait [Now() + "00:00:00.03"]
        Next
End Sub