<VB数理统计实用算法>书中的算法源程序
源代码在线查看： 二元多项式逐步回归f1.frm
VERSION 5.00
Begin VB.Form frmFileName
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "二元多项式逐步回归"
ClientHeight = 6735
ClientLeft = 60
ClientTop = 345
ClientWidth = 5670
LinkTopic = "Form1"
ScaleHeight = 6735
ScaleWidth = 5670
StartUpPosition = 3 '窗口缺省
Begin VB.TextBox txtCol
Alignment = 2 'Center
Appearance = 0 'Flat
Height = 270
Left = 3240
TabIndex = 20
Top = 5520
Width = 1095
End
Begin VB.TextBox txtRow
Alignment = 2 'Center
Appearance = 0 'Flat
Height = 270
Left = 3240
TabIndex = 19
Top = 5040
Width = 1095
End
Begin VB.OptionButton Option3
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "预测"
ForeColor = &H80000008&
Height = 375
Left = 120
TabIndex = 16
Top = 5640
Width = 1455
End
Begin VB.OptionButton Option2
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "平滑"
ForeColor = &H80000008&
Height = 375
Left = 120
TabIndex = 15
Top = 5280
Width = 1455
End
Begin VB.OptionButton Option1
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "网格"
ForeColor = &H80000008&
Height = 375
Left = 120
TabIndex = 14
Top = 4920
Value = -1 'True
Width = 1455
End
Begin VB.TextBox txtErr
Alignment = 2 'Center
Appearance = 0 'Flat
Height = 270
Left = 120
TabIndex = 13
Top = 4440
Width = 5415
End
Begin VB.TextBox txtResult
Alignment = 2 'Center
Appearance = 0 'Flat
Height = 270
Left = 120
TabIndex = 11
Top = 3720
Width = 5415
End
Begin VB.TextBox txtFile
Alignment = 2 'Center
Appearance = 0 'Flat
Height = 270
Left = 120
TabIndex = 9
Top = 3000
Width = 5415
End
Begin VB.CommandButton cmdExit
Caption = "退出"
Height = 375
Left = 4920
TabIndex = 7
ToolTipText = "结束程序运行"
Top = 6240
Width = 615
End
Begin VB.CommandButton cmdOK
Caption = "确定"
Height = 375
Left = 4320
TabIndex = 6
ToolTipText = "选择好文件并给出行数和列数后单击"
Top = 6240
Width = 615
End
Begin VB.FileListBox File1
Appearance = 0 'Flat
Height = 1470
Left = 120
TabIndex = 2
Top = 1080
Width = 2655
End
Begin VB.DirListBox Dir1
Appearance = 0 'Flat
Height = 2190
Left = 3000
TabIndex = 1
Top = 360
Width = 2415
End
Begin VB.DriveListBox Drive1
Appearance = 0 'Flat
Height = 300
Left = 120
TabIndex = 0
Top = 360
Width = 2655
End
Begin VB.Label Label8
Alignment = 1 'Right Justify
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "网格的列数："
ForeColor = &H80000008&
Height = 255
Left = 1800
TabIndex = 18
Top = 5520
Width = 1335
End
Begin VB.Label Label7
Alignment = 1 'Right Justify
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "网格的行数："
ForeColor = &H80000008&
Height = 255
Left = 1920
TabIndex = 17
Top = 5040
Width = 1215
End
Begin VB.Label Label6
Alignment = 2 'Center
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "保存残差的数据文件全名"
ForeColor = &H80000008&
Height = 255
Left = 1200
TabIndex = 12
Top = 4200
Width = 3255
End
Begin VB.Label Label5
Alignment = 2 'Center
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "保存网格结果的文件全名"
ForeColor = &H80000008&
Height = 255
Left = 720
TabIndex = 10
Top = 3480
Width = 4215
End
Begin VB.Label Label4
Alignment = 2 'Center
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "数据文件全名"
ForeColor = &H80000008&
Height = 255
Left = 1320
TabIndex = 8
Top = 2760
Width = 3015
End
Begin VB.Label Label3
Alignment = 2 'Center
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "选择数据文件"
ForeColor = &H80000008&
Height = 255
Left = 120
TabIndex = 5
Top = 840
Width = 2535
End
Begin VB.Label Label2
Alignment = 2 'Center
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "选择目录"
ForeColor = &H80000008&
Height = 255
Left = 3000
TabIndex = 4
Top = 120
Width = 2415
End
Begin VB.Label Label1
Alignment = 2 'Center
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "选择驱动器"
ForeColor = &H80000008&
Height = 255
Left = 120
TabIndex = 3
Top = 120
Width = 2655
End
End
Attribute VB_Name = "frmFileName"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'二元多项式逐步回归文件窗体
Option Explicit
Dim intI As Integer, intJ As Integer
Dim intFileNumber As Integer '文件号
Dim strData As String '临时保存数据
Private Sub Form_Load()
Label5.Caption = "保存网格结果的文件全名"
Label6.Caption = "保存网格残差的文件全名"
File1.Pattern = "*.dat" '只显示数据文件
Key = 1
End Sub
'选择目录
Private Sub Dir1_Change()
File1.Path = Dir1.Path
End Sub
'选择驱动器
Private Sub Drive1_Change()
Dir1.Path = Drive1.Drive
End Sub
'确定数据文件
Private Sub File1_Click()
txtFile.Text = Dir1.Path & "\" & File1.FileName '原始数据文件
If Option1 Then
txtResult.Text = Dir1.Path & "\" & "网值_" & File1.FileName '网格化
txtErr.Text = Dir1.Path & "\" & "网差_" & File1.FileName '残差
End If
If Option2 Then
txtResult.Text = Dir1.Path & "\" & "平值_" & File1.FileName '平滑
txtErr.Text = Dir1.Path & "\" & "平差_" & File1.FileName '残差
End If
End Sub
'确定，给出文件名和行数、列数后单击
Private Sub cmdOK_Click()
blnOpt = False '假设非网格化
strFileName = txtFile.Text '文件名
intFileNumber = FreeFile '取得空闲的文件号码
Open strFileName For Input As intFileNumber
Input #intFileNumber, strData '读列数
intCol = Val(strData) '取得列数
If intCol >= 2 Then
For intI = 2 To intCol '空转，读*****
Input #intFileNumber, strData
Next intI
End If
Input #intFileNumber, strData '读数据行数
intRow = Val(strData) '取得数据行数
If intRow 3 Then
MsgBox "数据行数不等于3，不符合要求，退出检查数据"
Exit Sub
End If
If intCol >= 2 Then
For intI = 2 To intCol '空转，读*****
Input #intFileNumber, strData
Next intI
End If
'重新定义数据数组
ReDim p(1 To intRow, 1 To intCol) '原始数据
ReDim X(1 To intCol), Y(1 To intCol), Z(1 To intCol)
ReDim G(1 To intCol), C(1 To intCol)
Input #intFileNumber, strData '读总行数
intRowAll = Val(strData) '取得总行数
If intCol >= 2 Then
For intI = 2 To intCol '空转，读*****
Input #intFileNumber, strData
Next intI
End If
blnTitle = False: blnRowLabel = False: blnColLabel = False
'优先考虑图题
If intRowAll > intRow + 3 Then blnTitle = True '有图题
'其次考虑行标
If intRowAll > 2 * intRow + 3 Then
blnRowLabel = True '有行标
ReDim strRowLabel(1 To intRow) '重新定义行标数组
End If
'最后考虑列标
If intRowAll > 2 * intRow + 4 Then
blnColLabel = True '有列标
ReDim strColLabel(1 To intCol) '重新定义列标数组
End If
If blnTitle Then
Input #intFileNumber, strData '读图形标题
strLabelName = strData '保存图题
If intCol >= 2 Then
For intI = 2 To intCol '空转，读*****号
Input #intFileNumber, strData
Next intI
End If
End If
If blnRowLabel Then
For intI = 1 To intRow
Input #intFileNumber, strData '读行标题
If intCol >= 2 Then
For intJ = 2 To intCol '空转，读*****号
Input #intFileNumber, strData
Next intJ
End If
Next intI
End If
If blnColLabel Then
For intI = 1 To intCol '读列标题
Input #intFileNumber, strData
Next intI
End If
For intI = 1 To intRow
For intJ = 1 To intCol
Input #intFileNumber, strData '读数据
p(intI, intJ) = Val(strData)
Next intJ
Next intI
Close
For intJ = 1 To intCol
X(intJ) = p(1, intJ)
Y(intJ) = p(2, intJ)
Z(intJ) = p(3, intJ)
Next intJ
strRes_Name = txtResult.Text '保存滑动平均结果文件名
strErr_Name = txtErr.Text '保存残差文件名
If Option1 Then
'网格的行数MM和网格的列数NN
MM = Val(txtRow.Text): NN = Val(txtCol.Text): blnOpt = True
End If
If Option3 Then
X0 = Val(txtRow.Text): Y0 = Val(txtCol.Text) '预测点坐标
End If
Unload Me
frmCalculate.Visible = True '显示计算窗体
End Sub
'退出
Private Sub cmdExit_Click()
Unload Me
End
End Sub
'选择网格
Private Sub Option1_Click()
Label5.Caption = "保存网格结果的文件全名"
Label6.Caption = "保存网格残差的文件全名"
txtResult.Text = Dir1.Path & "\" & "网值_" & File1.FileName '网格化
txtErr.Text = Dir1.Path & "\" & "网差_" & File1.FileName '残差
Label5.Visible = True: Label6.Visible = True
txtResult.Visible = True: txtErr.Visible = True
Label7.Visible = True: Label7.Caption = "网格的行数："
Label8.Visible = True: Label8.Caption = "网格的列数："
txtRow.Visible = True: txtCol.Visible = True
Key = 1
End Sub
'选择平滑
Private Sub Option2_Click()
Label5.Caption = "保存平滑结果的文件全名"
Label6.Caption = "保存平滑残差的文件全名"
txtResult.Text = Dir1.Path & "\" & "平值_" & File1.FileName '平滑
txtErr.Text = Dir1.Path & "\" & "平差_" & File1.FileName '残差
Label5.Visible = True: Label6.Visible = True
txtResult.Visible = True: txtErr.Visible = True
Label7.Visible = False: Label8.Visible = False
txtRow.Visible = False: txtCol.Visible = False
Key = 2
End Sub
'选择预测
Private Sub Option3_Click()
Label5.Visible = False: Label6.Visible = False
txtResult.Visible = False: txtErr.Visible = False
Label7.Caption = "键入X值：": Label7.Visible = True
Label8.Caption = "键入Y值：": Label8.Visible = True
txtRow.Visible = True: txtCol.Visible = True
Key = 3
End Sub
