easydrawhermit.bas

本过程是用光滑的曲线(三次参数样条曲线)连接离散点 参数PicHdc表示在上面进行处理的窗体的设备环境句柄 参数PicHwnd表示在上面进行处理的窗体的窗口句柄 参数X(),Y

求张力样条插值函数vb代码


VBScript code

--------------------------------------------------------------------------------

Public Sub EasyDrawHermit(Pic As Object, X() As Double, Y() As Double, _

                          Color As Long, Optional Mode As Integer = 0)

''''''''''''''''''''''''''''''''''''''''''''''

'本过程是用光滑的曲线(三次参数样条曲线)连接离散点

'参数PicHdc表示在上面进行处理的窗体的设备环境句柄

'参数PicHwnd表示在上面进行处理的窗体的窗口句柄

'参数X(),Y()表示各离散点的坐标

'参数Color表示曲线颜色

'参数Mode表示三次参数样条曲线的约束条件：

'    其中0为自由端，1为抛物端(没有考虑夹持端)

'

''''''''''''''''''''''''''''''''''''''''''''''

    If LBound(X) = LBound(Y) And UBound(X) = UBound(Y) Then

        '输入的数据符合要求，空操作

    Else

        MsgBox "您输入的离散点不合要求！", vbOKOnly, "错误提示"

        Exit Sub '退出过程

    End If

    

    Dim L As Long '下标

    Dim U As Long '上标

    L = LBound(X)

    U = UBound(X)

    

    If L = U Then '只有一个点

        Pic.PSet (X(L), Y(L)), Color '打点

        Exit Sub '绘线过程结束

    End If

    

    If L + 1 = U Then '只有两个点

        '直接连线

        Pic.Line (X(L), Y(L))-(X(U), Y(U)), Color

        Exit Sub '绘线过程结束

    End If

    

    Dim i As Long '用于控制循环

    Dim dx() As Double 'X系数

    Dim dy() As Double 'Y系数

    Dim Rx() As Double 'X导数向量

    Dim Ry() As Double 'Y导数向量

    ReDim dx(L To U)

    ReDim dy(L To U)

    If Mode = 0 Then                      '

        dx(L) = 3 * (X(L + 1) - X(L))     '

        dy(L) = 3 * (Y(L + 1) - Y(L))     '

        dx(U) = 3 * (X(U) - X(U - 1))     '

        dy(U) = 3 * (Y(U) - Y(U - 1))     '

    Else                                  '不同约束条件下三次参数样条曲线方程组

        dx(L) = 2 * (X(L + 1) - X(L))     '右端的常数向量

        dy(L) = 2 * (Y(L + 1) - Y(L))     '

        dx(U) = 2 * (X(U) - X(U - 1))     '

        dy(U) = 2 * (Y(U) - Y(U - 1))     '

    End If                                '

    For i = L + 1 To U - 1                '

        dx(i) = 3 * (X(i + 1) - X(i - 1)) '

        dy(i) = 3 * (Y(i + 1) - Y(i - 1)) '

    Next                                  '

    

    Rx = ChaseArithmetic(dx, Mode) '追赶法求解

    Ry = ChaseArithmetic(dy, Mode) '注意得到的数组上下标与输入参数数组一致

    

    Dim P() As Vector   '

    Dim R() As Vector   '

    ReDim P(L To U)     '

    ReDim R(L To U)     '

    For i = L To U      '构造相应的向量

        P(i).X = X(i)   '

        P(i).Y = Y(i)   '

        R(i).X = Rx(i)  '

        R(i).Y = Ry(i)  '

    Next i              '

    

    '画曲线

    For i = L To U - 1

        EasyHermit Pic, P(i), P(i + 1), R(i), R(i + 1), Color, 100

    Next i

End Sub



Public Function ChaseArithmetic(Coef() As Double, Mode As Integer) As Double()

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'本过程是用追赶法求解各种约束条件下的三次参数样条曲线方程组的解

'参数Coef()表示方程组右端的常数向量d(AX=d)

'参数Mode表示三次参数样条曲线的约束条件：0为自由端，1为抛物端(没有考虑夹持端)

'

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    Dim i As Long '用于控制循环

    Dim N As Long '矩阵阶数

    N = UBound(Coef) - LBound(Coef) + 1

    Dim d() As Double

    ReDim d(1 To N)

    For i = 1 To N

        d(i) = Coef(LBound(Coef) + i - 1)

    Next i

    

    

    Dim A() As Double

    Dim B() As Double

    Dim c() As Double

    ReDim A(2 To N)     '下对角线

    ReDim B(1 To N)     '主对角线

    ReDim c(1 To N - 1) '上对角线

    

    For i = 2 To N       '

        A(i) = 1         '

        c(i - 1) = 1     '

    Next                 '

    If Mode = 0 Then     '不同约束条件下三次参数样条曲线方程组

        B(1) = 2         '三对角线矩阵元素的值

        B(N) = 2         '

    Else                 '

        B(1) = 1         '

        B(N) = 1         '

    End If               '

    For i = 2 To N - 1   '

        B(i) = 4         '

    Next                 '

    

    Dim L() As Double

    Dim U() As Double

    ReDim L(2 To N) '分解得L矩阵下对角线。A=LU

    ReDim U(1 To N) '分解得U矩阵主对角线

    U(1) = B(1)

    For i = 2 To N                    '

        L(i) = A(i) / U(i - 1)        'L和U矩阵上元素的值

        U(i) = B(i) - L(i) * c(i - 1) '

        If U(i) = 0 Then

            MsgBox "追赶法中出现零作除数，已进行调整", vbOKOnly, "警告"

            U(i) = 0.000000000001 '人为用一个非常小的值代替0值

        End If

    Next i                            '

    

    Dim Y() As Double                 '

    ReDim Y(1 To N)                   '

    Y(1) = d(1)                       'LY=d

    For i = 2 To N                    '求解出临时的Y向量

        Y(i) = d(i) - L(i) * Y(i - 1) '

    Next i                            '

    Dim X() As Double                          '

    ReDim X(1 To N)                            '

    X(N) = Y(N) / U(N)                         'UX=Y

    For i = N - 1 To 1 Step -1                 '求得方程组最终解

        X(i) = (Y(i) - c(i) * X(i + 1)) / U(i) '

    Next i                                     '

    

    Dim temp() As Double

    ReDim temp(LBound(Coef) To UBound(Coef))

    For i = 1 To N            '注意返回的数组的上、下标与参数数组一致

        temp(LBound(Coef) + i - 1) = X(i)  '

    Next i                    '

    ChaseArithmetic = temp    '返回值

End Function



Optional SectNum As Long = 100) ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '本过程是采用逐点连线的方法用（三次）Hermit曲线按照给出条件连接两个点 '参数Pic表示在上面进行处理的窗体或图片框 '参数P0、P1分别表示起点和终点矢量 '参数R0、R1分别表示起点和终点对于参数的切线矢量 '参数Color表示曲线的颜色 '参数SectNum为分段连线的数目，可选参数，默认值为100 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Dim t As Double '参数，范围0～1 Dim F1 As Double '调和函数1，方程为：F1(t)=2*t^3 - 3*t^2 + 1 Dim F2 As Double '调和函数2，方程为：F2(t)=-2*t^3 + 3*t^2 Dim F3 As Double '调和函数3，方程为：F3(t)=t^3 - 2*t^2 + t Dim F4 As Double '调和函数4，方程为：F4(t)=t^3 - t^2 Dim X() As Double '曲线上的点横坐标数组 Dim Y() As Double '曲线上的点纵坐标数组 ReDim X(SectNum) '分段数目决定取点多少 ReDim Y(SectNum) '分段数目决定取点多少 X(0) = P0.X '起点横坐标 Y(0) = P0.Y '起点纵坐标 Dim Span As Double '跨度值 Span = 1 / CDbl(SectNum) '用其它语言改写的时候，注意整数除法的陷阱 Dim i As Long '用于控制循环 '循环连线，描绘曲线 For i = 1 To SectNum t = i * Span '参数取值 F1 = 2 * t ^ 3 - 3 * t ^ 2 + 1 '调和函数F1的值 F2 = -2 * t ^ 3 + 3 * t ^ 2 '调和函数F2的值 F3 = t ^ 3 - 2 * t ^ 2 + t '调和函数F3的值 F4 = t ^ 3 - t ^ 2 '调和函数F4的值 X(i) = F1 * P0.X + F2 * P1.X + F3 * R0.X + F4 * R1.X '该点的X坐标 Y(i) = F1 * P0.Y + F2 * P1.Y + F3 * R0.Y + F4 * R1.Y '该点的Y坐标 Pic.Line (X(i - 1), Y(i - 1))-(X(i), Y(i)), Color Next i End Sub