求張力樣條插值函數vb代碼


VBScript code

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

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

                          Color As Long, Optional Mode As Integer = 0)

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

'本過程是用光滑的曲線(三次參數樣條曲線)連接離散點

'參數PicHdc表示在上面進行處理的窗體的設備環(huán)境句柄

'參數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 '用于控制循環(huán)

    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 '用于控制循環(huán)

    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 "追趕法中出現(xiàn)零作除數，已進行調整", 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 '用于控制循環(huán) '循環(huán)連線，描繪曲線 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