📄 两组判别f2.frm
字号:
Top = 1440
Width = 5055
End
Begin VB.Label lbl001F
Appearance = 0 'Flat
BackColor = &H80000005&
BorderStyle = 1 'Fixed Single
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 375
Left = 4680
TabIndex = 7
Top = 960
Width = 1455
End
Begin VB.Label lbl005F
Appearance = 0 'Flat
BackColor = &H80000005&
BorderStyle = 1 'Fixed Single
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 375
Left = 4680
TabIndex = 6
Top = 600
Width = 1455
End
Begin VB.Label lblCV
Appearance = 0 'Flat
BackColor = &H80000005&
BorderStyle = 1 'Fixed Single
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 375
Left = 4680
TabIndex = 5
Top = 240
Width = 1455
End
Begin VB.Label lblf001
Alignment = 1 'Right Justify
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "显著性水平为0.01的F临界值："
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 375
Left = 1320
TabIndex = 4
Top = 960
Width = 3375
End
Begin VB.Label lblf005
Alignment = 1 'Right Justify
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "显著性水平为0.05的F临界值："
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 375
Left = 1320
TabIndex = 3
Top = 600
Width = 3375
End
Begin VB.Label lblFC
Alignment = 1 'Right Justify
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "判别方程F检验值："
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 375
Left = 2040
TabIndex = 2
Top = 240
Width = 2655
End
End
Attribute VB_Name = "frmCalculate"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'两组判别
Option Explicit
Const St1 As String = "A组"
Const St2 As String = "B组"
Const St3 As String = "待定"
Dim I As Integer, J As Integer, K As Integer
Dim F005 As Double, F001 As Double, FF As Double
Dim sngF005 As Single, sngF001 As Single
Dim sngH As Single, sngC As Single
Dim UA As Integer, Ue As Integer
Dim S1 As Double, S2 As Double, M1 As Integer
Private Sub Form_Load()
lblNC(0).Visible = False: lblN(0).Visible = False
lblC(0).Visible = False: lblTV(0).Visible = False
lblTT.Visible = False: lbltR(0).Visible = False
lblFC.Visible = False: lblCV.Visible = False
lblf005.Visible = False: lbl005F.Visible = False
lblf001.Visible = False: lbl001F.Visible = False
lblFR.Visible = False: lblRR.Visible = False
lblCC.Visible = False: lblCR.Visible = False
lblCoe.Visible = False
lblResult.Visible = False: lbltY(0).Visible = False
lblVV.Visible = False: Line1.Visible = False
End Sub
'计算
Private Sub cmdCalculate_Click()
On Error Resume Next
lblFC.Visible = True: lblCV.Visible = True
lblf005.Visible = True: lbl005F.Visible = True
lblf001.Visible = True: lbl001F.Visible = True
lblFR.Visible = True: lblRR.Visible = True
lblTT.Visible = True: lblResult.Visible = True
lblCC.Visible = True: lblCR.Visible = True
lblCoe.Visible = True
Line1.Visible = True
'求A组、B组样本的各个变量的平均值
For J = 1 To M
S1 = 0#
For I = 1 To N1
S1 = S1 + X1(I, J)
Next I
CP1(J) = S1 / N1 'A组样本的变量平均值
S1 = 0#
For I = 1 To N2
S1 = S1 + X2(I, J)
Next I
CP2(J) = S1 / N2 'B组样本的变量平均值
Next J
'计算判别方程的系数矩阵XS
M1 = M + 1
For I = 1 To M
For J = 1 To M
S1 = 0#
S2 = 0#
For K = 1 To N1
S1 = S1 + (X1(K, I) - CP1(I)) * (X1(K, J) - CP1(J))
Next K
For K = 1 To N2
S2 = S2 + (X2(K, I) - CP2(I)) * (X2(K, J) - CP2(J))
Next K
XS(I, J) = S1 + S2
Next J
Next I
For I = 1 To M
DD(I) = CP1(I) - CP2(I) '求判别方程时的右侧向量
Next I
'解线性代数方程组
Invert XS '矩阵求逆
For I = 1 To M
For J = 1 To M
'DD是线性代数方程组的右侧向量。CC是求出的判别方程系数
CC(I) = CC(I) + XS(I, J) * DD(J)
Next J
Next I
D2 = 0#
For I = 1 To M
D2 = D2 + (CP1(I) - CP2(I)) * CC(I)
Next I
D2 = (N1 + N2 - 2) * D2 '马哈拉诺比斯距离
sngC = D2
lblCR.Caption = Str(sngC)
'F检验值
FF = D2 * (N1 * N2 * (N1 + N2 - M - 1)) / ((N1 + N2) * (N1 + N2 - 2) * M)
sngC = FF
lblCV.Caption = Str(sngC)
UA = M: Ue = N1 + N2 - M - 1
PF_DIST UA, Ue, 0.05, F005 '计算显著性为0.05的F临界值
PF_DIST UA, Ue, 0.01, F001 '计算显著性为0.01的F临界值
sngF005 = F005: sngF001 = F001
lbl005F.Caption = Str(sngF005): lbl001F.Caption = Str(sngF001)
If FF <= F005 Then lblRR = "判别方程的意义不显著"
If FF > F005 And FF <= F001 Then lblRR = "判别方程的意义显著"
If FF > F001 Then lblRR = "判别方程的意义特别显著"
'根据判别方程计算每个样本的判别值
For I = 1 To N1
Y1(I) = 0#
For J = 1 To M
'Y1为A组样本的判别值
Y1(I) = Y1(I) + X1(I, J) * CC(J)
Next J
Next I
For I = 1 To N2
Y2(I) = 0#
For J = 1 To M
'Y2为B组样本的判别值
Y2(I) = Y2(I) + X2(I, J) * CC(J)
Next J
Next I
For I = 1 To N3
Y3(I) = 0#
For J = 1 To M
'Y3为待定样本的判别值
Y3(I) = Y3(I) + X3(I, J) * CC(J)
Next J
Next I
'利用标签数组显示判别方程系数
lblNC(0).Visible = True: lblN(0).Visible = True
sngH = lblN(0).Height '标签元素的高度
For I = 1 To M
Load lblNC1(I): Load lblN1(I)
lblNC1(I).Caption = "C" & Str(I): sngC = CC(I)
lblN1(I).Caption = Str(sngC) '在标签数组放置判别方程系数
Next I
For I = 1 To M '置放标签数组
Load lblNC(I): Load lblN(I)
lblNC(I).Move lblNC(0).Left, lblNC(0).Top + I * sngH
lblN(I).Move lblN(0).Left, lblN(0).Top + I * sngH
lblN(I).Visible = True: lblNC(I).Visible = True
lblNC(I) = lblNC1(I): lblN(I) = lblN1(I)
Next I
YA = 0#: YB = 0#
For I = 1 To M
YA = YA + CP1(I) * CC(I) 'A组样本综合指标
YB = YB + CP2(I) * CC(I) 'B组样本综合指标
Next I
YC = (N1 * YA + N2 * YB) / (N1 + N2) '样本归属临界值
sngC = YC: lblVV.Caption = Str(sngC): lblVV.Visible = True
'将判断结果保存在虚设的标签数组
For I = 1 To intRow
Load lblC1(I): Load lblTV1(I): Load lblTY1(I): Load lblTR1(I)
Next I
'显示A组判别结果
For I = 1 To N1
lblC1(I).Caption = "1-" & Str(I): sngC = Y1(I)
lblTV1(I) = sngC
If Y1(I) > YC Then lblTY1(I) = St1 Else lblTY1(I) = St2
lblTR1(I) = St1
Next I
'显示B组判别结果
For I = N1 + 1 To N1 + N2
lblC1(I).Caption = "2-" & Str(I - N1): sngC = Y2(I - N1)
lblTV1(I) = sngC
If Y2(I - N1) > YC Then lblTY1(I) = St1 Else lblTY1(I) = St2
lblTR1(I) = St2
Next I
'显示待定组判别结果
For I = N1 + N2 + 1 To intRow
lblC1(I).Caption = "3-" & Str(I - N1 - N2): sngC = Y3(I - N1 - N2)
lblTV1(I) = sngC
If Y3(I - N1 - N2) > YC Then lblTY1(I) = St1 Else lblTY1(I) = St2
lblTR1(I) = St3
Next I
lblC(0).Visible = True: lblTV(0).Visible = True
lbltY(0).Visible = True: lbltR(0).Visible = True
'利用标签数组显示判别结果
For I = 1 To intRow
Load lblC(I): Load lblTV(I): Load lbltY(I): Load lbltR(I)
lblC(I).Move lblC(0).Left, lblC(0).Top + I * sngH
lblTV(I).Move lblTV(0).Left, lblTV(0).Top + I * sngH
lbltY(I).Move lbltY(0).Left, lbltY(0).Top + I * sngH
lbltR(I).Move lbltR(0).Left, lbltR(0).Top + I * sngH
lblC(I).Visible = True '编号
lblTV(I).Visible = True '判别值
lbltY(I).Visible = True '判别分类
lbltR(I).Visible = True '原有分类
lblC(I) = lblC1(I) '编号
lblTV(I) = lblTV1(I) '判别值
lbltY(I) = lblTY1(I) '判别分类
lbltR(I) = lblTR1(I) '原有分类
Next I
cmdCalculate.Visible = False
End Sub
'在右侧控制判别结论的垂直滚动条
Private Sub VScroll1_Change()
Dim V As Integer
On Error Resume Next
V = VScroll1.Value
lblC(0) = "编号": lblTV(0) = "判别值"
lbltY(0) = "判别分类": lbltR(0) = "原有分类"
For I = 1 To intRow
If I + V > intRow Then GoTo 10
lblC(I) = lblC1(I + V) '编号
lblTV(I) = lblTV1(I + V) '判别值
lbltY(I) = lblTY1(I + V) '判别分类
lbltR(I) = lblTR1(I + V) '原有分类
GoTo 20
10: lblC(I) = "": lblTV(I) = "": lbltY(I) = "": lbltR(I) = ""
20: Next I
End Sub
'在左侧控制判别方法系数的垂直滚动条
Private Sub VScroll2_Change()
Dim V As Integer
On Error Resume Next
V = VScroll2.Value
lblC(0) = "编号": lblTV(0) = "判别值"
lbltY(0) = "判别分类": lbltR(0) = "原有分类"
For I = 1 To M
If I + V > M Then GoTo 10
lblNC(I) = lblNC1(I + V) '系数编号
lblN(I) = lblN1(I + V) '系数值
GoTo 20
10: lblNC(I) = "": lblN(I) = ""
20: Next I
End Sub
'结束
Private Sub cmdExit_Click()
Unload Me
End
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -