📄 模糊聚类f3.frm
字号:
VERSION 5.00
Object = "{3B7C8863-D78F-101B-B9B5-04021C009402}#1.2#0"; "RICHTX32.OCX"
Begin VB.Form frmResult
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "模糊聚类分析"
ClientHeight = 6285
ClientLeft = 60
ClientTop = 450
ClientWidth = 7890
LinkTopic = "Form1"
ScaleHeight = 6285
ScaleWidth = 7890
StartUpPosition = 3 '窗口缺省
Begin VB.CommandButton cmdPrint
Caption = "打 印"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 3240
TabIndex = 4
Top = 0
Width = 1170
End
Begin VB.CommandButton cmdCata
Caption = "分 类"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 1080
TabIndex = 3
Top = 0
Width = 1095
End
Begin RichTextLib.RichTextBox rTxt
Height = 5655
Left = 120
TabIndex = 2
Top = 480
Width = 7695
_ExtentX = 13573
_ExtentY = 9975
_Version = 393217
Enabled = -1 'True
ScrollBars = 2
DisableNoScroll = -1 'True
Appearance = 0
TextRTF = $"模糊聚类F3.frx":0000
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin VB.CommandButton cmdSave
Caption = "保 存"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 2160
TabIndex = 1
Top = 0
Width = 1095
End
Begin VB.CommandButton cmdExit
Caption = "退 出"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 0
TabIndex = 0
Top = 0
Width = 1095
End
Begin VB.Label lblW
Alignment = 2 'Center
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "分类时请耐心等待！"
BeginProperty Font
Name = "隶书"
Size = 15.75
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 375
Left = 4440
TabIndex = 5
Top = 0
Width = 3015
End
End
Attribute VB_Name = "frmResult"
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, intK As Integer
Dim intL As Integer, intM As Integer, strR As String
Dim Lamda(1 To 100) As Double '保存“入”值
Dim II As Integer, JJ As Integer
Dim IJ(1 To 100, 1 To 100) As Integer '保存某种“入”值的分类结果
Dim La As Double, intC As Integer
Private Sub Form_Load()
strR = Chr(13) + Chr(10) '回车换行符
'获取所有可能的“入”值
intL = 1 '“入”值个数计数器
Lamda(1) = RR(1, 1)
For intI = 1 To intRow
For intJ = intI To intRow
For intK = 1 To intL
If RR(intI, intJ) = Lamda(intK) Then GoTo 100
Next intK
intL = intL + 1
Lamda(intL) = RR(intI, intJ)
100:
Next intJ
Next intI
'对“入”值排序，先大后小
For intI = 1 To intL
For intJ = intI To intL
If Lamda(intJ) > Lamda(intI) Then
La = Lamda(intJ)
Lamda(intJ) = Lamda(intI)
Lamda(intI) = La
End If
Next intJ
Next intI
cmdPrint.Visible = False: cmdSave.Visible = False
End Sub
'分类
Private Sub cmdCata_Click()
rTxt.Text = rTxt.Text & "共有" & intL & "种截值（入）进行分类"
rTxt.Text = rTxt.Text & "----------------------------------"
For intK = 1 To intL
'恢复R矩阵
For intI = 1 To intRow
For intJ = 1 To intRow
R(intI, intJ) = RR(intI, intJ)
Next intJ
Next intI
'以下将对R矩阵进行一系列处理
'对“入”值求截矩阵（将R矩阵改成截矩阵）
For intI = 1 To intRow
For intJ = 1 To intRow
If Lamda(intK) <= RR(intI, intJ) Then _
R(intI, intJ) = 1 Else R(intI, intJ) = 0
Next intJ
Next intI
For intI = 1 To 100 '可以有100种不同的分类
For intJ = 1 To 100 '最大的一类中可以包括100个元素
IJ(intI, intJ) = 0 '使分类结果数组初值化
Next intJ
Next intI
'使截矩阵的下半部为0（将R矩阵改成上三角矩阵）
For intI = 1 To intRow
For intJ = 1 To intRow
If intI > intJ Then R(intI, intJ) = 0
Next intJ
Next intI
'只要某个元素出现在某类中，则该元素对应的各列全部充为0
'（进一步简化R矩阵，只保留对分类起作用的元素）
For intI = 1 To intRow
For intJ = 1 To intRow
If R(intI, intJ) <> 0 And intJ <> intI Then
'某行某列中出现不为0的元素，比如第1行第3列，该元素将对分类起作用
For intM = 1 To intRow
'将第3列所对应的第3行的各个列元素全部充为0，不再参与分类（因为已经参与分类）
R(intJ, intM) = 0
Next intM
End If
Next intJ
Next intI
'经过一系列处理，现在的R中对分类有意义的元素为1，其余为0
'将分类结果按元素号集中在数组IJ的左上角
II = 0 '类计数器
For intI = 1 To intRow
JJ = 0 '元素计数器
For intJ = 1 To intRow
If R(intI, intJ) <> 0 Then
JJ = JJ + 1
If JJ = 1 Then II = II + 1
IJ(II, JJ) = intJ
End If
Next intJ
Next intI
'在富文本框中显示分类结果
rTxt.Text = rTxt.Text & strR & "入值：" & Lamda(intK)
intC = 0
For intI = 1 To intRow
If IJ(intI, 1) <> 0 Then
intC = intC + 1
rTxt.Text = rTxt.Text & strR & "第" & intI & "类："
End If
For intJ = 1 To intRow
If IJ(intI, intJ) <> 0 Then
rTxt.Text = rTxt.Text & "u" & IJ(intI, intJ) & " "
End If
Next intJ
Next intI
If Fa1 = 0 Or Fa2 = 0 Then GoTo 100 '如果显著性有一个为0，则不进行F检验
F_Check X, IJ, F '计算F检验值
If F > 9990 Then
rTxt.Text = rTxt.Text & strR & "F检验值：" _
& "****"
Else
rTxt.Text = rTxt.Text & strR & "F检验值：" _
& Int(F * 1000 + 0.5) / 1000
End If
'计算显著性为Fa1的F临界值F1
If intC - 1 = 0 Or intRow - intC = 0 Then F1 = 9999 '避免溢出
If intC - 1 <> 0 And intRow - intC <> 0 Then _
PF_DIST intC - 1, intRow - intC, Fa1, F1
'计算显著性为Fa2的F临界值F2
If intC - 1 = 0 Or intRow - intC = 0 Then F2 = 9999 '避免溢出
If intC - 1 <> 0 And intRow - intC <> 0 Then _
PF_DIST intC - 1, intRow - intC, Fa2, F2
If F1 > 9990 Then
rTxt.Text = rTxt.Text & strR & "显著性为" & Fa1 & "的F临界值：" _
& "****"
Else
rTxt.Text = rTxt.Text & strR & "显著性为" & Fa1 & "的F临界值：" _
& Int(F1 * 1000 + 0.5) / 1000
End If
If F2 > 9990 Then
rTxt.Text = rTxt.Text & strR & "显著性为" & Fa2 & "的F临界值：" _
& "****"
Else
rTxt.Text = rTxt.Text & strR & "显著性为" & Fa2 & "的F临界值：" _
& Int(F2 * 1000 + 0.5) / 1000
End If
If F <= F1 Then rTxt.Text = _
rTxt.Text & strR & "结论：在给定的临界值下，该分类效果不显著"
If F > F1 And F <= F2 Then rTxt.Text = _
rTxt.Text & strR & "结论：在给定的临界值下，该分类效果显著"
If F > F2 Then rTxt.Text = _
rTxt.Text & strR & "结论：在给定的临界值下，该分类效果特别显著"
rTxt.Text = rTxt.Text & strR & "******************************"
100:
Next intK
cmdCata.Visible = False: cmdPrint.Visible = True: cmdSave.Visible = True
lblW.Visible = False
End Sub
'打印
Private Sub cmdPrint_Click()
rTxt.SelLength = 0
rTxt.SelPrint Printer.hDC
cmdPrint.Visible = False
End Sub
'保存
Private Sub cmdSave_Click()
rTxt.SaveFile strResultFile, 1
cmdSave.Visible = False
End Sub
'退出
Private Sub cmdExit_Click()
Unload Me
frmFile.Visible = True
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -