【VBA】ベジェ曲線でExcelグラフを描く

前提

X座標は連続する整数値
Y座標はP0とP1だけ固定値

ベジェ曲線の式

共通

0 <= t <= 1

1次

px = (1 - t) * px0 + t * px1
py = (1 - t) * py0 + t * py1

2次

px = (1 - t) * (1 - t) * px0 + (1 - t) * t * px2 + t * t * px1
py = (1 - t) * (1 - t) * py0 + (1 - t) * t * py2 + t * t * py1

3次

px = (1 - t) * (1 - t) * (1 - t) * px0 + 3 * (1 - t) * (1 - t) * t * px3 + 3 * (1 - t) * t * t * px2 + t * t * t * px1
py = (1 - t) * (1 - t) * (1 - t) * py0 + 3 * (1 - t) * (1 - t) * t * py3 + 3 * (1 - t) * t * t * py2 + t * t * t * py1

4次

px = (1 - t) * (1 - t) * (1 - t) * (1 - t) * px0 + 4 * (1 - t) * (1 - t) * (1 - t) * t * px4 + 6 * (1 - t) * (1 - t) * t * t * px2 + 4 * (1 - t) * t * t * t * px3 + t * t * t * px1
py = (1 - t) * (1 - t) * (1 - t) * (1 - t) * py0 + 4 * (1 - t) * (1 - t) * (1 - t) * t * py4 + 6 * (1 - t) * (1 - t) * t * t * py2 + 4 * (1 - t) * t * t * t * py3 + t * t * t * py1

答え

[1]X座標は予めわかっているので、[t]をくくりだしてY座標を計算

    Sub Ans1()

        Dim px As Double, py As Double

        Dim px0 As Double, py0 As Double
        px0 = Cells(2, 5)
        py0 = Cells(2, 6)

        Dim px1 As Double, py1 As Double
        px1 = Cells(3, 5)
        py1 = Cells(3, 6)

        Dim px2 As Double, py2 As Double
        px2 = Cells(4, 5)
        py2 = Cells(4, 6)

        Dim t As Double
        Dim x As Double
        Dim step As Integer
        step = Abs(px0 - px1)
        x = 1 / Abs(px0 - px1)
        t = px0

        Dim i As Double

        For i = 0 To step
            Dim temp As Double
            temp = (2 * px2 - 2 * px0) * (2 * px2 - 2 * px0) - 4 * (px0 - i) * (px0 - 2 * px2 + px1)
            t = ((2 * px0 - 2 * px2) + Sqr(temp)) / (2 * (px0 - 2 * px2 + px1))

            py = (1 - t) * (1 - t) * py0 + 2 * (1 - t) * t * py2 + t * t * py1
            Cells(i + 1, 2) = py

            t = t + 1
        Next i

    End Sub

問題点

• 3次方程式以降がめんどくさい

[2]ステップ数を増やしてX座標が+1されたらセルに書き込む

Sub Ans2()

    Dim px As Double, py As Double

    Dim px0 As Double, py0 As Double
    px0 = Cells(2, 5)
    py0 = Cells(2, 6)

    Dim px1 As Double, py1 As Double
    px1 = Cells(3, 5)
    py1 = Cells(3, 6)

    Dim px2 As Double, py2 As Double
    px2 = Cells(4, 5)
    py2 = Cells(4, 6)

    Dim px3 As Double, py3 As Double
    px3 = Cells(5, 5)
    py3 = Cells(5, 6)

    Dim px4 As Double, py4 As Double
    px3 = Cells(6, 5)
    py3 = Cells(6, 6)

    Dim t As Double
    Dim x As Double
    Dim step As Integer
    t = 0

    Dim i As Integer
    i = px0

    Dim equation As Integer
    equation = Cells(1, 4)

    Do While i <= px1

        Select Case equation
            Case 1
                px = (1 - t) * px0 + t * px1
                py = (1 - t) * py0 + t * py1
            Case 2
                px = (1 - t) * (1 - t) * px0 + 2 * (1 - t) * t * px2 + t * t * px1
                py = (1 - t) * (1 - t) * py0 + 2 * (1 - t) * t * py2 + t * t * py1
            Case 3
                px = (1 - t) * (1 - t) * (1 - t) * px0 + 3 * (1 - t) * (1 - t) * t * px3 + 3 * (1 - t) * t * t * px2 + t * t * t * px1
                py = (1 - t) * (1 - t) * (1 - t) * py0 + 3 * (1 - t) * (1 - t) * t * py3 + 3 * (1 - t) * t * t * py2 + t * t * t * py1
            Case 4
                px = (1 - t) * (1 - t) * (1 - t) * (1 - t) * px0 + 4 * (1 - t) * (1 - t) * (1 - t) * t * px4 + 6 * (1 - t) * (1 - t) * t * t * px2 + 4 * (1 - t) * t * t * t * px3 + t * t * t * px1
                py = (1 - t) * (1 - t) * (1 - t) * (1 - t) * py0 + 4 * (1 - t) * (1 - t) * (1 - t) * t * py4 + 6 * (1 - t) * (1 - t) * t * t * py2 + 4 * (1 - t) * t * t * t * py3 + t * t * t * py1
        End Select

        If i <= px Then

            Cells(i + 1, 2) = py
            Cells(i + 1, 3) = px

            i = i + 1
        End If

        t = t + 0.000001
    Loop

End Sub

問題点

• ステップ数が多い