form1.frm

曲线拟合小工具

End Sub
Private Sub ZuoDian1(x() As Double, y() As Double)
Dim XL As Double
Dim YL As Double
N = UBound(x): Picture1.Cls
Xmin = x(1): Xmax = x(1): Xo = x(1): Yo = y(1)
Ymin = y(1): Ymax = y(1)
For I = 1 To N
    If Xmin > x(I) Then
        Xmin = x(I)
        Xo = Xmin: Yo = y(I)    '后面画曲线时用到。
    End If
    If Xmax < x(I) Then Xmax = x(I)
    If Ymin > y(I) Then Ymin = y(I)
    If Ymax < y(I) Then Ymax = y(I)
Next I
XL = Xmax - Xmin: YL = Ymax - Ymin
Picture1.Scale (Xmin - XL / 10, Ymax + YL / 10)-(Xmax + XL / 10, Ymin - YL / 10)
Picture1.DrawWidth = 5
For I = 1 To N
    Picture1.PSet (x(I), y(I)), vbRed
Next I
Picture1.DrawWidth = 1
Picture1.Line (Xmin, Ymin)-(Xmax, Ymax), vbBlack, B
Dim qi As Integer, jian As Integer
qi = Int(Xmin + 1)
jian = Fix((Xmax - Xmin) / 5)
For I = 1 To 4
Picture1.Line (qi + I * jian, Ymin)-(qi + I * jian, Ymin + (Ymax - Ymin) / 40), vbBlack, B
Next I
qi = Int(Ymin + 1)
jian = Fix((Ymax - Ymin) / 5)
For I = 1 To 4
Picture1.Line (Xmin, qi + I * jian)-(Xmin + (Xmax - Xmin) / 40, qi + I * jian), vbBlack, B
Next I
'Picture1.Refresh
End Sub


Private Sub gph_Click()
Call HuaQuXian(xiaoA, sg)
Check5.Enabled = True
Check2.Enabled = True
End Sub

Private Sub op_Click()
Dim FileName As String
Dim Xstr As String, Ystr As String
On Error GoTo errhandle
CommonDialog1.InitDir = App.Path '设置初始路径   数据导入
CommonDialog1.FileName = "" '清除文件名
CommonDialog1.ShowOpen '显示“打开”对话框
FileName = CommonDialog1.FileName '保存文件名
If Len(CommonDialog1.FileName) > 0 Then
    'File = FreeFile() '获得可用文件号
    Open FileName For Input As #1 '打开文件
End If
I = 0
MousePointer = 11
Do While EOF(1) = False
     I = I + 1
     ReDim Preserve x(I)
     ReDim Preserve y(I)
     MSFlexGrid1.Rows = I + 1
     Input #1, Xstr, Ystr  ' 分别输入各数据
     MSFlexGrid1.TextMatrix(I, 1) = Xstr
     x(I) = Val(Xstr)
     
     MSFlexGrid1.TextMatrix(I, 2) = Ystr
     y(I) = Val(Ystr)
     
     MSFlexGrid1.TextMatrix(I, 0) = I
Loop
Close #1: N = I   '检验一下N是否对？？？



Call ZuoDian1(x, y)


errhandle:
MousePointer = 0
Exit Sub
MousePointer = 0
End Sub
Private Sub JieFangCheng(A() As Double, B() As Double, x() As Double)
N = UBound(B)
Dim TempA As Double, L As Integer, K As Integer, Kk As Integer
Dim Ii As Integer, ChuShu As Double, Sum As Double
For I = 1 To N
    L = 0: Kk = 0
    For J = I To N
      If A(J, I) = 0 Then L = L + 1
    Next J
    For J = I To N - L
      If A(J, I) = 0 Then
        Kk = Kk + 1
        For K = I To N
           TempA = A(J, K)
           A(J, K) = A(N - Kk + 1, K)
           A(N - Kk + 1, K) = TempA
        Next K
        TempA = B(J): B(J) = B(N - Kk + 1): B(N - Kk + 1) = TempA
      End If
    Next J
              
    For Ii = I To N - L
      ChuShu = A(Ii, I)
      For J = I To N
         A(Ii, J) = A(Ii, J) / ChuShu
      Next J
      B(Ii) = B(Ii) / ChuShu
    Next Ii
    For Ii = I + 1 To N - L
      For J = I To N
         A(Ii, J) = A(Ii, J) - A(I, J)
      Next J
      B(Ii) = B(Ii) - B(I)
    Next Ii
Next I
For I = 1 To N
    For J = 1 To I - 1
      A(I, J) = 0
    Next J
Next I
      
      
x(N) = B(N) / A(N, N)
For I = N - 1 To 1 Step -1
   Sum = 0
   For J = I + 1 To N
      Sum = Sum + A(I, J) * x(J)
   Next J
   x(I) = (B(I) - Sum) / A(I, I)
Next I

End Sub

Private Sub typ1_Click()
sg = 1

Dim Xh As Integer
M = 2

Erase B: Erase xiaoA: Erase A   '必不可少***********

ReDim B(M): ReDim xiaoA(1 To M)
'形成方程组的各元素
A(1, 1) = N
For I = 1 To N
   B(1) = B(1) + y(I)
Next I
For J = 2 To M
   For I = 1 To N
      A(1, J) = A(1, J) + x(I) ^ (J - 1)
   Next I
Next J
For I = 2 To M
   For J = 1 To M
      For Xh = 1 To N
         A(I, J) = Val(A(I, J) + x(Xh) ^ (I + J - 2))
         If J = 1 Then
            B(I) = B(I) + x(Xh) ^ (I - 1) * y(Xh)
         End If
      Next Xh
   Next J
Next I

Call JieFangCheng(A, B, xiaoA)

Check1.Enabled = True
End Sub

Private Sub typ2_Click()
sg = 2

Dim Xh As Integer
M = 2

Erase B: Erase xiaoA: Erase A  '必不可少***********

ReDim B(M): ReDim xiaoA(1 To M): ReDim X1(N)
'形成方程组的各元素
For I = 1 To N
X1(I) = Log(x(I))
Next I

A(1, 1) = N
For I = 1 To N
   B(1) = B(1) + y(I)
Next I
For J = 2 To M
   For I = 1 To N
      A(1, J) = A(1, J) + X1(I) ^ (J - 1)
   Next I
Next J
For I = 2 To M
   For J = 1 To M
      For Xh = 1 To N
         A(I, J) = Val(A(I, J) + X1(Xh) ^ (I + J - 2))
         If J = 1 Then
            B(I) = B(I) + X1(Xh) ^ (I - 1) * y(Xh)
         End If
      Next Xh
   Next J
Next I

Call JieFangCheng(A, B, xiaoA)
Check1.Enabled = True
End Sub

Private Sub typ3_Click()
sg = 3
Label2.Enabled = True
Combo1.Enabled = True
Dim Xh As Integer
M = Val(Combo1.Text) + 1

Erase B: Erase xiaoA: Erase A   '必不可少***********

ReDim B(M): ReDim xiaoA(1 To M)
'形成方程组的各元素
A(1, 1) = N
For I = 1 To N
   B(1) = B(1) + y(I)
Next I
For J = 2 To M
   For I = 1 To N
      A(1, J) = A(1, J) + x(I) ^ (J - 1)
   Next I
Next J
For I = 2 To M
   For J = 1 To M
      For Xh = 1 To N
         A(I, J) = Val(A(I, J) + x(Xh) ^ (I + J - 2))
         If J = 1 Then
            B(I) = B(I) + x(Xh) ^ (I - 1) * y(Xh)
         End If
      Next Xh
   Next J
Next I

Call JieFangCheng(A, B, xiaoA)
Check1.Enabled = True
End Sub
Private Sub HuaQuXian(xiaoA() As Double, w As Integer)
Call ZuoDian(x, y)

Dim Ysum As Double, Ii As Double
If w = 3 Then
For Ii = Xmin To Xmax Step (Xmax - Xmin) / 100
      Ysum = 0
      For J = 1 To M
          Ysum = Ysum + xiaoA(J) * Ii ^ (J - 1)
      Next J
      Picture1.Line (Xo, Yo)-(Ii, Ysum)
      Xo = Ii: Yo = Ysum
Next Ii
ElseIf w = 1 Then
For Ii = Xmin To Xmax Step (Xmax - Xmin) / 100
          Ysum = xiaoA(1) + xiaoA(2) * Ii
          Picture1.Line (Xo, Yo)-(Ii, Ysum)
      Xo = Ii: Yo = Ysum
Next Ii
ElseIf w = 2 Then

For Ii = Xmin To Xmax Step (Xmax - Xmin) / 100
          Ysum = xiaoA(1) + xiaoA(2) * Log(Ii)
          Picture1.Line (Xo, Yo)-(Ii, Ysum)
      Xo = Ii: Yo = Ysum
Next Ii
ElseIf w = 4 Then
   'ReDim xiaoB(2)
    'xiaoB(1) = Exp(xiaoA(1))
    'xiaoB(2) = xiaoA(2)
 For Ii = Xmin To Xmax Step (Xmax - Xmin) / 100
          Ysum = xiaoB(1) * Ii ^ xiaoB(2)
         
        Picture1.Line (Xo, Yo)-(Ii, Ysum)
        Xo = Ii: Yo = Ysum
Next Ii
ElseIf w = 5 Then
   ' ReDim xiaoB(2)
    'xiaoB(1) = Exp(xiaoA(1))
    'xiaoB(2) = xiaoA(2)
 For Ii = Xmin To Xmax Step (Xmax - Xmin) / 100
          Ysum = xiaoB(1) * Exp(xiaoB(2) * Ii)
         
        Picture1.Line (Xo, Yo)-(Ii, Ysum)
        Xo = Ii: Yo = Ysum
Next Ii

End If
End Sub

Private Sub typ4_Click()
sg = 4

Dim Xh As Integer
M = 2

Erase B: Erase xiaoA: Erase A  '必不可少***********

ReDim B(M): ReDim xiaoA(1 To M): ReDim X1(N): ReDim Y1(N)
'形成方程组的各元素
For I = 1 To N
X1(I) = Log(x(I))
Y1(I) = Log(y(I))
Next I

A(1, 1) = N
For I = 1 To N
   B(1) = B(1) + Y1(I)
Next I
For J = 2 To M
   For I = 1 To N
      A(1, J) = A(1, J) + X1(I) ^ (J - 1)
   Next I
Next J
For I = 2 To M
   For J = 1 To M
      For Xh = 1 To N
         A(I, J) = Val(A(I, J) + X1(Xh) ^ (I + J - 2))
         If J = 1 Then
            B(I) = B(I) + X1(Xh) ^ (I - 1) * Y1(Xh)
         End If
      Next Xh
   Next J
Next I

Call JieFangCheng(A, B, xiaoA)
Check1.Enabled = True
End Sub

Private Sub typ5_Click()
sg = 5

Dim Xh As Integer
M = 2

Erase B: Erase xiaoA: Erase A  '必不可少***********

ReDim B(M): ReDim xiaoA(1 To M):  ReDim Y1(N)
'形成方程组的各元素
For I = 1 To N
Y1(I) = Log(y(I))
Next I

A(1, 1) = N
For I = 1 To N
   B(1) = B(1) + Y1(I)
Next I
For J = 2 To M
   For I = 1 To N
      A(1, J) = A(1, J) + x(I) ^ (J - 1)
   Next I
Next J
For I = 2 To M
   For J = 1 To M
      For Xh = 1 To N
         A(I, J) = Val(A(I, J) + x(Xh) ^ (I + J - 2))
         If J = 1 Then
            B(I) = B(I) + x(Xh) ^ (I - 1) * Y1(Xh)
         End If
      Next Xh
   Next J
Next I

Call JieFangCheng(A, B, xiaoA)
Check1.Enabled = True
End Sub
Sub spline(x(), y(), N, y2())
   Dim u(100)
   y2(1) = 0
   u(1) = 0
   For I = 2 To N - 1
     sig = (x(I) - x(I - 1)) / (x(I + 1) - x(I - 1))
     p = sig * y2(I - 1) + 2#
     y2(I) = (sig) / p
     
     
     
End Sub

End Sub