📄 form01.frm
字号:
VERSION 5.00
Object = "{5E9E78A0-531B-11CF-91F6-C2863C385E30}#1.0#0"; "MSFLXGRD.OCX"
Begin VB.Form Form01
BackColor = &H80000013&
Caption = "聚类分析"
ClientHeight = 6255
ClientLeft = 1770
ClientTop = 1335
ClientWidth = 10485
FillColor = &H80000013&
ForeColor = &H80000013&
Icon = "Form01.frx":0000
LinkTopic = "Form1"
ScaleHeight = 6255
ScaleWidth = 10485
Begin VB.TextBox Text3
BorderStyle = 0 'None
Height = 270
Left = 4920
TabIndex = 7
Top = 600
Visible = 0 'False
Width = 910
End
Begin VB.Frame Frame1
BackColor = &H80000013&
Caption = "分类结果"
Height = 2055
Left = 720
TabIndex = 5
Top = 3960
Width = 8055
Begin VB.Label Label4
BackColor = &H80000013&
Height = 1455
Left = 240
TabIndex = 6
Top = 360
Width = 7695
End
End
Begin VB.CommandButton Command1
BackColor = &H80000013&
Caption = "分 析"
Height = 615
Left = 960
MaskColor = &H00FFFF00&
TabIndex = 4
Top = 2880
Width = 1575
End
Begin VB.TextBox Text2
Height = 270
Left = 2040
TabIndex = 3
Top = 1560
Width = 855
End
Begin VB.TextBox Text1
Height = 270
Left = 2040
TabIndex = 2
Top = 960
Width = 855
End
Begin MSFlexGridLib.MSFlexGrid Grid1
Height = 1935
Left = 4080
TabIndex = 8
Top = 360
Width = 4575
_ExtentX = 8070
_ExtentY = 3413
_Version = 393216
Rows = 8
Cols = 5
FixedRows = 0
FixedCols = 0
BackColor = -2147483628
BackColorBkg = -2147483629
FillStyle = 1
GridLines = 2
End
Begin VB.Label Label3
Caption = "Label3"
Height = 15
Left = 5400
TabIndex = 10
Top = 720
Width = 135
End
Begin VB.Label Label5
BackColor = &H80000013&
Caption = $"Form01.frx":0E42
Height = 975
Left = 4080
TabIndex = 9
Top = 2760
Width = 4575
End
Begin VB.Label Label2
BackColor = &H80000013&
Caption = "指标数"
Height = 255
Left = 840
TabIndex = 1
Top = 1560
Width = 855
End
Begin VB.Label Label1
BackColor = &H80000013&
Caption = "样品数"
Height = 255
Left = 840
TabIndex = 0
Top = 960
Width = 855
End
End
Attribute VB_Name = "Form01"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Const ASC_ENTER = 13 '回车
Dim gRow As Integer
Dim gCol As Integer
Private Sub Grid1_KeyPress(KeyAscii As Integer)
' Move the text box to the current grid cell:
Text3.Top = Grid1.CellTop + Grid1.Top
Text3.Left = Grid1.CellLeft + Grid1.Left
' Save the position of the grids Row and Col for later:
gRow = Grid1.row
gCol = Grid1.Col
' Make text box same size as current grid cell:
Text3.Width = Grid1.CellWidth - 2 * Screen.TwipsPerPixelX
Text3.Height = Grid1.CellHeight - 2 * Screen.TwipsPerPixelY
' Transfer the grid cell text:
Text3.Text = Grid1.Text
' Show the text box:
Text3.Visible = True
Text3.ZOrder 0 ' 把 Text3 放到最前面！
Text3.SetFocus
' Redirect this KeyPress event to the text box:
If KeyAscii <> ASC_ENTER Then
SendKeys Chr$(KeyAscii)
End If
End Sub
Private Sub OLE1_Updated(Code As Integer)
End Sub
Private Sub Text3_KeyPress(KeyAscii As Integer)
If KeyAscii = ASC_ENTER Then
Grid1.SetFocus ' Set focus back to grid, see Text_LostFocus.
KeyAscii = 0 ' Ignore this KeyPress.
End If
End Sub
Private Sub Text3_LostFocus()
Dim tmpRow As Integer
Dim tmpCol As Integer
' Save current settings of Grid Row and col. This is needed only if
' the focus is set somewhere else in the Grid.
tmpRow = Grid1.row
tmpCol = Grid1.Col
' Set Row and Col back to what they were before Text3_LostFocus:
Grid1.row = gRow
Grid1.Col = gCol
Grid1.Text = Text3.Text ' Transfer text back to grid.
Text3.SelStart = 0 ' Return caret to beginning.
Text3.Visible = False ' Disable text box.
' Return row and Col contents:
Grid1.row = tmpRow
Grid1.Col = tmpCol
End Sub
Private Sub Grid1_Click()
If Text1.Text = "" Or Text2.Text = "" Then
w = MsgBox("请输入样品数和指标数！")
Else
Grid1.Rows = Text1.Text + 1
Grid1.Cols = Text2.Text + 1
End If
End Sub
Private Sub Command1_Click()
Label4.Caption = ""
If Text1.Text = "" Or Text2.Text = "" Then
w = MsgBox("请输入样品数和指标数！")
Else
Dim i, j, k, p, q As Integer 'm为样品数，n为指标数
m = CInt(Text1.Text)
n = CInt(Text2.Text)
ReDim x(m, n), d(m, m) As Double
For i = 0 To m - 1 '将控件中的数据赋给x矩阵
For j = 0 To n - 1
x(i, j) = CDbl(Grid1.TextMatrix(i + 1, j + 1))
Next j
Next i
'数据转换(标准化)
ReDim pxj(n), sj(n), Y(m, n) As Double
For j = 0 To n - 1
For i = 0 To m - 1
pxj(j) = pxj(j) + x(i, j)
Next i
pxj(j) = pxj(j) / m
Next j
For j = 0 To n - 1
For i = 0 To m - 1
sj(j) = sj(j) + (x(i, j) - pxj(j)) ^ 2
Next i
sj(j) = Sqr(sj(j) / (m - 1))
Next j
For i = 0 To m - 1
For j = 0 To n - 1
Y(i, j) = (x(i, j) - pxj(j)) / sj(j)
Next j
Next i
'样品间的绝对值距离
For i = 0 To m - 1
For j = 0 To m - 1
For k = 0 To n - 1
d(i, j) = d(i, j) + Abs(Y(i, k) - Y(j, k))
Next k
Next j
Next i
'最短距离法分类
'd(i,j)中最小元素及位置
For i = 1 To m
Label4.Caption = Label4.Caption & "第" & i & "个样品为G" & i & "类 "
Next i
Dim min As Double
q = m
min = d(1, 0): k = 2: p = 1
For i = 2 To m - 1
For j = 0 To i - 2
If min > d(i, j) Then
min = d(i, j)
k = i + 1
p = j + 1
End If
Next j
Next i
q = q + 1
Label4.Caption = Label4.Caption & Chr(10) & "第" & k & "个和第" & p & "个样品为G" & q & "类 "
For i = 1 To m - 1
For j = 0 To i - 1
If d(i, j) = min And i <> k - 1 Then
q = q + 1
Label4.Caption = Label4.Caption & "第" & i + 1 & "个和第" & j + 1 & "个样品为G" & q & "类"
End If
Next j
Next i
End If
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -