module1.bas

利用三点拉格朗日插值插值算法

Attribute VB_Name = "Module1"
Public mycount As Single
Public mypoint As Single
Public myx() As Single
Public myy() As Single
'记录插值方程数量，次数
Public fangchengshuliang As Single
Public chazhicishu() As Single
'定义曲线开口方向变量
Public opendirection() As Single
'插值曲线的取值区间变量
Public xa As Single
Public xb As Single

Public Function Ln(X As Single)
Dim i As Integer
Dim fn1 As Single
Dim fn As Single
For i = mypoint - mycount + 1 To mypoint
    fn1 = 1
    For j = mypoint - mycount + 1 To mypoint
        
        If j <> i Then
        
            fn1 = fn1 * (X - myx(j)) / (myx(i) - myx(j))
            
        End If
    Next j
    fn1 = fn1 * myy(i)
    fn = fn + fn1
Next i
Ln = fn
fn = 0
End Function
Public Function mylength(qxth As Single)
Dim i As Single
'定义曲线起点变量位置
Dim qidian As Single
Dim zhongdian As Single
Dim linshimypoint As Single
''''''''''''''''''''''
'求曲线长度，按着每个方程的插值次数计算出需要的坐标点
For i = 1 To qxth
 
qidian = qidian + chazhicishu(i)
Next i
qidian = qidian - qxth + 1
zhongdian = qidian
qidian = qidian - chazhicishu(qxth) + 1
linshimypoint = mypoint
mypoint = zhongdian
'起点终点已经求出
'求长度
'定义xa xb
Dim xa As Single
Dim xb As Single
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
lsx1 = myx(mypoint)
lsy1 = myy(mypoint)
lsx2 = myx(mypoint - 1)
lsy2 = myy(mypoint - 1)
lsx3 = myx(mypoint - 2)
lsy3 = myy(mypoint - 2)
                
If opendirection(qxth) = 1 Then
                    
   myx(mypoint) = myy(mypoint)
   myx(mypoint - 1) = myy(mypoint - 1)
   myx(mypoint - 2) = myy(mypoint - 2)
   myy(mypoint) = lsx1
   myy(mypoint - 1) = lsx2
   myy(mypoint - 2) = lsx3
                
End If

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

xa = myx(qidian)
xb = myx(zhongdian)
For i = qidian To zhongdian
    If myx(i) <= xa Then xa = myx(i)
    If myx(i) >= xb Then xb = myx(i)
Next i


mycount = chazhicishu(qxth)
For i = xa To xb
    
    If opendirection(qxth) = 1 Then
    
    form1.Picture1.PSet (Ln(i), i), vbYellow
    mylength = mylength + Sqr(1 ^ 2 + (Ln(i + 1) - Ln(i)) ^ 2)
    Else
    form1.Picture1.PSet (i, Ln(i)), vbYellow
    mylength = mylength + Sqr(1 ^ 2 + (Ln(i + 1) - Ln(i)) ^ 2)
    End If
    
Next i

'''''''''''''[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[
            myx(mypoint) = lsx1
            myy(mypoint) = lsy1
            myx(mypoint - 1) = lsx2
            myy(mypoint - 1) = lsy2
            myx(mypoint - 2) = lsx3
            myy(mypoint - 2) = lsy3

'''''''''''''''[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[

mycount = 1
mypoint = linshimypoint
End Function
Public Function myredraw(qxth As Single, rg As Integer)
Dim i As Single
'定义曲线起点变量位置
Dim qidian As Single
Dim zhongdian As Single
Dim linshimypoint As Single
''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''
For i = 1 To qxth
 
qidian = qidian + chazhicishu(i)
Next i
qidian = qidian - qxth + 1
zhongdian = qidian
qidian = qidian - chazhicishu(qxth) + 1
linshimypoint = mypoint
mypoint = zhongdian
'起点终点已经求出
'求长度
'定义xa xb
Dim xa As Single
Dim xb As Single

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
lsx1 = myx(mypoint)
lsy1 = myy(mypoint)
lsx2 = myx(mypoint - 1)
lsy2 = myy(mypoint - 1)
lsx3 = myx(mypoint - 2)
lsy3 = myy(mypoint - 2)
                
If opendirection(qxth) = 1 Then
                    
   myx(mypoint) = myy(mypoint)
   myx(mypoint - 1) = myy(mypoint - 1)
   myx(mypoint - 2) = myy(mypoint - 2)
   myy(mypoint) = lsx1
   myy(mypoint - 1) = lsx2
   myy(mypoint - 2) = lsx3
                
End If

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



xa = myx(qidian)
xb = myx(zhongdian)
For i = qidian To zhongdian
    If myx(i) <= xa Then xa = myx(i)
    If myx(i) >= xb Then xb = myx(i)
Next i


mycount = chazhicishu(qxth)
For i = xa To xb
    If opendirection(qxth) = 1 Then
        If rg = 1 Then form1.Picture1.PSet (Ln(i), i), vbGreen
        If rg = 0 Then form1.Picture1.PSet (Ln(i), i), vbRed
    Else
        If rg = 1 Then form1.Picture1.PSet (i, Ln(i)), vbGreen
        If rg = 0 Then form1.Picture1.PSet (i, Ln(i)), vbRed
    End If
Next i

'''''''''''''[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[
            myx(mypoint) = lsx1
            myy(mypoint) = lsy1
            myx(mypoint - 1) = lsx2
            myy(mypoint - 1) = lsy2
            myx(mypoint - 2) = lsx3
            myy(mypoint - 2) = lsy3

'''''''''''''''[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[


mycount = 1
mypoint = linshimypoint
End Function