ί

最小二乘法多次曲线拟合.exe

VERSION 5.00
Begin VB.Form Form1 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "最小二乘法多次曲线拟合"
   ClientHeight    =   4455
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   6495
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   297
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   433
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton Command1 
      Caption         =   "改变"
      Height          =   315
      Index           =   1
      Left            =   720
      Style           =   1  'Graphical
      TabIndex        =   15
      Top             =   0
      Width           =   675
   End
   Begin VB.CommandButton Command4 
      Caption         =   "拟合"
      Height          =   315
      Left            =   5580
      Style           =   1  'Graphical
      TabIndex        =   12
      Top             =   0
      Width           =   855
   End
   Begin VB.CommandButton Command2 
      Caption         =   "保存"
      Height          =   315
      Index           =   1
      Left            =   3480
      Style           =   1  'Graphical
      TabIndex        =   14
      Top             =   0
      Width           =   675
   End
   Begin VB.CommandButton Command2 
      Caption         =   "读取"
      Height          =   315
      Index           =   0
      Left            =   2820
      Style           =   1  'Graphical
      TabIndex        =   13
      Top             =   0
      Width           =   675
   End
   Begin VB.TextBox Text4 
      BackColor       =   &H00FFFFC0&
      Height          =   270
      Index           =   1
      Left            =   3540
      Locked          =   -1  'True
      TabIndex        =   11
      ToolTipText     =   "输出Y值"
      Top             =   4140
      Width           =   2895
   End
   Begin VB.CommandButton Command3 
      Caption         =   "->"
      Height          =   255
      Left            =   3000
      Style           =   1  'Graphical
      TabIndex        =   10
      ToolTipText     =   "求对应的Y值"
      Top             =   4140
      Width           =   495
   End
   Begin VB.TextBox Text4 
      BackColor       =   &H00FFFFC0&
      Height          =   270
      Index           =   0
      Left            =   60
      TabIndex        =   9
      ToolTipText     =   "输入X值"
      Top             =   4140
      Width           =   2895
   End
   Begin VB.TextBox Text3 
      BackColor       =   &H00FFFFC0&
      Height          =   270
      Left            =   60
      Locked          =   -1  'True
      TabIndex        =   8
      ToolTipText     =   "曲线函数表达式"
      Top             =   3840
      Width           =   6375
   End
   Begin VB.CommandButton Command1 
      Caption         =   "清除"
      Height          =   315
      Index           =   3
      Left            =   2100
      Style           =   1  'Graphical
      TabIndex        =   5
      Top             =   0
      Width           =   675
   End
   Begin VB.CommandButton Command1 
      Caption         =   "删除"
      Height          =   315
      Index           =   2
      Left            =   1440
      Style           =   1  'Graphical
      TabIndex        =   4
      Top             =   0
      Width           =   675
   End
   Begin VB.TextBox Text2 
      BackColor       =   &H00FFFFC0&
      Height          =   270
      Left            =   4200
      Locked          =   -1  'True
      TabIndex        =   7
      ToolTipText     =   "相关系数"
      Top             =   360
      Width           =   2235
   End
   Begin VB.ListBox List3 
      BackColor       =   &H00FFFFC0&
      Height          =   3120
      Left            =   4200
      TabIndex        =   6
      ToolTipText     =   "回归系数列表"
      Top             =   660
      Width           =   2235
   End
   Begin VB.CommandButton Command1 
      Caption         =   "添加"
      Height          =   315
      Index           =   0
      Left            =   60
      Style           =   1  'Graphical
      TabIndex        =   3
      Top             =   0
      Width           =   675
   End
   Begin VB.TextBox Text1 
      BackColor       =   &H00FFFFC0&
      Height          =   255
      Left            =   60
      TabIndex        =   2
      Text            =   "0,0"
      ToolTipText     =   "数据输入"
      Top             =   360
      Width           =   3555
   End
   Begin VB.ListBox List2 
      BackColor       =   &H00FFFFC0&
      Height          =   3120
      Left            =   60
      TabIndex        =   1
      ToolTipText     =   "数据列表"
      Top             =   660
      Width           =   3555
   End
   Begin VB.ListBox List1 
      BackColor       =   &H00FFFFC0&
      Height          =   2955
      IntegralHeight  =   0   'False
      Left            =   3660
      MultiSelect     =   1  'Simple
      TabIndex        =   0
      ToolTipText     =   "回归函数表达式包含的次数(可多选)"
      Top             =   840
      Width           =   555
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Sub Command1_Click(Index As Integer)
Dim s1 As String, z1 As Long
Select Case Index
Case 0
    s1 = DelSpace(Text1.Text)
    z1 = InStr(s1, ",")
    If z1 > 0 And z1 < Len(s1) Then
        s1 = StrEX(ValEX(Left(s1, z1))) & "," & StrEX(ValEX(Mid(s1, z1 + 1)))
        List2.AddItem s1
    End If
    'List2.ListIndex = List2.ListCount - 1
Case 1
    If List2.ListIndex >= 0 Then
    s1 = DelSpace(Text1.Text)
    z1 = InStr(s1, ",")
    If z1 > 0 And z1 < Len(s1) Then
        s1 = StrEX(ValEX(Left(s1, z1))) & "," & StrEX(ValEX(Mid(s1, z1 + 1)))
        List2.List(List2.ListIndex) = s1
    End If
    End If
Case 2
    If List2.ListIndex >= 0 Then
        z1 = List2.ListIndex
        List2.RemoveItem List2.ListIndex
        If z1 >= List2.ListCount Then z1 = List2.ListCount - 1
        If z1 >= 0 Then List2.ListIndex = z1
    End If
Case 3
    List2.Clear
End Select
Command4.Enabled = List2.ListCount > List1.SelCount
End Sub

Private Sub Command2_Click(Index As Integer)
Dim s1 As String, z1 As Long
Select Case Index
Case 0
Me.Tag = "open"
Load Dialog
Dialog.Show 1
If Len(Me.Tag) = 0 Then Exit Sub
Open Me.Tag For Input As #1
Do Until EOF(1)
Line Input #1, s1
    s1 = DelSpace(s1)
    z1 = InStr(s1, ",")
    If z1 > 0 And z1 < Len(s1) Then
        s1 = StrEX(ValEX(Left(s1, z1))) & "," & StrEX(ValEX(Mid(s1, z1 + 1)))
        List2.AddItem s1
    End If
    List2.ListIndex = List2.ListCount - 1
Loop
Close #1
Command4.Enabled = List2.ListCount > List1.SelCount
Case 1
Me.Tag = "save"
Load Dialog
Dialog.Show 1
If Len(Me.Tag) = 0 Then Exit Sub
z1 = 0
If Len(Dir(Me.Tag)) > 0 Then z1 = MsgBox("覆盖此文件吗", vbYesNo)
If z1 = vbNo Then Exit Sub
On Error Resume Next
Open Me.Tag For Output As #1
If Err.Number <> 0 Then GoTo ED
For z1 = 0 To List2.ListCount - 1
Print #1, List2.List(z1)
Next
Close #1
Exit Sub
On Error GoTo 0
ED:
Call MsgBox("Could not save", 48)
Err.Clear
End Select
End Sub

Private Sub Command3_Click()
Dim d1 As Double, d2 As Double
Dim z1 As Long, z2 As Long, z3 As Long, z4 As Long
d2 = ValEX(Text4(0).Text): z4 = List1.SelCount
'If z4 + 1 = List3.ListCount Then
On Error GoTo ED
    d1 = ValEX(List3.List(0))
    z3 = 0
    For z2 = 0 To z4 - 1
    z3 = z3 + 1
BegIF1:
    If List1.Selected(z3 - 1) = False Then z3 = z3 + 1: GoTo BegIF1
    d1 = d1 + ValEX(List3.List(z2 + 1)) * d2 ^ z3
    Next
    Text4(1).Text = StrEX(d1)
'Else
'    Call MsgBox("无效指令", 48, "错误")
'End If
Exit Sub
ED:
Call MsgBox("发生错误", 48, "错误")
End Sub

Private Sub Command4_Click()
Dim z1 As Long, z2 As Long
Dim hRoot(16) As Double, hMaxIndex As Long, hData() As Double, LenData As Long
hMaxIndex = 16
For z2 = 0 To 15
If List1.Selected(z2) Then hRoot(z2 + 1) = 1
Next
LenData = List2.ListCount - 1
ReDim hData(LenData, 1) As Double
For z2 = 0 To LenData
z1 = InStr(List2.List(z2), ",") + 1
hData(z2, 0) = ValEX(Left(List2.List(z2), z1))
hData(z2, 1) = ValEX(Mid(List2.List(z2), z1))
Next
z2 = GetMINNHvalue(hRoot(), hMaxIndex, hData(), LenData + 1)
If z2 = -1 Then z1 = MsgBox("除数为0", 48, "错误"): Exit Sub
If z2 = -2 Then z1 = MsgBox("溢出", 48, "错误"): Exit Sub
List3.Clear
Text2.Text = z2
List3.AddItem StrEX(hRoot(0))
For z2 = 1 To hMaxIndex
List3.AddItem StrEX(hRoot(z2))
Next
Text3.Text = GetExpression
End Sub

Private Sub Form_Load()
Dim z1 As Long
For z1 = 0 To 15
List1.AddItem z1 + 1
Next
For z1 = 0 To 1
List1.Selected(z1) = True
Next
End Sub

Private Sub List1_Click()
Command4.Enabled = List2.ListCount > List1.SelCount
End Sub

Private Sub List2_Click()
If List2.ListIndex >= 0 Then Text1.Text = List2.List(List2.ListIndex)
End Sub

Private Function GetExpression() As String
Dim z1 As Long, z2 As Long
Dim s1 As String, s2 As String, d1 As Double, d2 As Double
z2 = List3.ListCount - 1
'If z2 = 0 Then GetExpression = "": Exit Function
s1 = StrEX(ValEX(List3.List(0)))
'If z2 = 1 Then GetExpression = "y=" & s1: Exit Function
d1 = ValEX(List3.List(1))
d2 = ValEX(List3.List(0))
If d1 <> 0 Then
If d2 < 0 Then s2 = "" Else s2 = "+"
Select Case d1
    Case 1
        s1 = "x" & s2 & s1
    Case -1
        s1 = "-x" & s2 & s1
    Case Else
        s1 = StrEX(d1) & "x" & s2 & s1
End Select
End If
For z1 = 2 To z2
d1 = ValEX(List3.List(z1))
d2 = ValEX(List3.List(z1 - 1))
If d1 <> 0 Then
If d2 < 0 Then s2 = "" Else s2 = "+"
Select Case d1
    Case 1
        s1 = "x^" & StrEX(z1) & s2 & s1
    Case -1
        s1 = "-x^" & StrEX(z1) & s2 & s1
    Case Else
        s1 = StrEX(d1) & "x^" & StrEX(z1) & s2 & s1
End Select
End If
Next
If Len(s1) <= 1 Then GetExpression = "y=" & s1: Exit Function
If Right(s1, 2) = "+0" Then
GetExpression = "y=" & Left(s1, Len(s1) - 2)
Else
GetExpression = "y=" & s1
End If
End Function

Private Function DelSpace(ByVal Text As String) As String
Dim z1 As Long, z2 As Long, z3 As Long
z2 = Len(Text): z3 = Len(Text)
For z1 = 1 To z2
If Asc(Mid(Text, z1, 1)) = 32 Then Mid(Text, z1) = Mid(Text, z1 + 1): z3 = z3 - 1
Next z1
DelSpace = Left(Text, z3)
End Function

Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then Call Command1_Click(1)
End Sub