点群分析f1.frm

<VB数理统计实用算法>书中的算法源程序

      Height          =   1470
      Left            =   480
      TabIndex        =   2
      Top             =   1080
      Width           =   2655
   End
   Begin VB.DirListBox Dir1 
      Appearance      =   0  'Flat
      Height          =   2190
      Left            =   3360
      TabIndex        =   1
      Top             =   360
      Width           =   2415
   End
   Begin VB.DriveListBox Drive1 
      Appearance      =   0  'Flat
      Height          =   300
      Left            =   480
      TabIndex        =   0
      Top             =   360
      Width           =   2655
   End
   Begin VB.Label Label5 
      Alignment       =   2  'Center
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      Caption         =   "数据文件全名"
      ForeColor       =   &H80000008&
      Height          =   255
      Left            =   1800
      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            =   480
      TabIndex        =   5
      Top             =   840
      Width           =   2655
   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            =   480
      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, I As Integer, J As Integer
Dim intFileNumber As Integer            '文件号
Dim strData As String                   '临时保存数据
Dim blnTitle As Boolean                 '是否有标题
Dim blnRowLabel As Boolean              '是否有行标
Dim blnColLabel As Boolean              '是否有列标
Dim XX(1 To 1000, 1 To 100)             '临时工作数组

Private Sub Form_Load()
    File1.Pattern = "*.dat"             '只显示数据文件
    Frame1.Visible = False: Frame2.Visible = False: Frame3.Visible = False
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
End Sub

'在选择文件之后，框架可视
Private Sub txtFile_Change()
    Frame1.Visible = True
    Frame2.Visible = True
    Frame3.Visible = True
End Sub

'确定，给出文件名和行数、列数后单击
Private Sub cmdOK_Click()
    If txtFile.Text = "" Then
        MsgBox "必须先选定数据文件！"
        Exit Sub
    End If
    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 intCol >= 2 Then
        For intI = 2 To intCol          '空转，读*****
            Input #intFileNumber, strData
        Next intI
    End If
    If intRow < intCol Then
        MsgBox "数据的行数小于列数，重新建立数据文件！", _
                vbOKOnly + vbExclamation, "数据文件错误"
        End
    End If
    N = intRow: M = intCol
'重新定义自变量数组
    ReDim X(1 To N, 1 To M)
    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               '读数据
            X(intI, intJ) = Val(strData)
        Next intJ
    Next intI
    If Option1 Then Data_S1 X                           '标准差标准化
    If Option2 Then Data_S2 X                           '极差标准化
    If Option3 Then Data_S3 X                           '极差正规化
    If Option6 Then Key = 1                             'Q型距离系数
    If Option7 Then Key = 2                             'Q型夹角余弦
    If Option8 Then Key = 3                             'Q型相关系数
    If Option5 Then                                     'R型相关系数
        Key = 4
'将已经变换的数据保存
        For intI = 1 To intRow
            For intJ = 1 To intCol
                XX(intJ, intI) = X(intI, intJ)
            Next intJ
        Next intI
'重新按R型的要求改变数组，行、列互换
        M = intRow: N = intCol
        ReDim X(1 To N, 1 To M)
        For intI = 1 To intRow
            For intJ = 1 To intCol
                X(intJ, intI) = XX(intI, intJ)
            Next intJ
        Next intI
    End If
    Close
    frmCalculate.Visible = True
End Sub

'只在Q型时显示分类统计量
Private Sub Option4_Click()
    Frame3.Visible = True
End Sub

'R型时不显示分类统计量
Private Sub Option5_Click()
    Frame3.Visible = False
End Sub

'结束运行
Private Sub cmdExit_Click()
    Unload Me
    End
End Sub