-

所有数理统计知识的源代码都在此,是一本数理统计数的配套光盘.里面有各种分布类型及参数估计插值

'将文件加到菜单数组中
    AddFileToArray strOpenFileName, Me
    Exit Sub
DBNameError:
    strDBName = ""
    MsgBox "数据名错误", , "数据库"
End Sub

'函数功能：检查是否重名
Function SameDBName() As Boolean
'如果同名数据库已经存在,必须先删除旧的数据库,然后才能创建
    If Dir(strDBName) <> "" Then
        msgResult = MsgBox("数据库重名,删除旧的数据库吗?", _
                    vbYesNo, "创建数据库")
        If msgResult = vbYes Then
            Kill (strDBName)        '删除旧的数据库
            SameDBName = False      '不再重名
        Else
            SameDBName = True       '继续重名
            Exit Function
        End If
        SameDBName = False          '无重名现象
    End If
End Function

'过程功能：创建或打开数据库
Sub CreateOrOpenDB(blnNew As Boolean)
    If blnNew Then                  '新建数据库
        Set db = DBEngine(0).CreateDatabase(strDBName, dbLangGeneral)
    Else                            '打开数据库
        Set db = DBEngine(0).OpenDatabase(strDBName)
    End If
End Sub

'过程功能：取得数据表名称
Sub GetTDName(blnNew As Boolean)
    If blnNew Then
        strTDName = InputBox("键入数据表名称", "数据表")
    Else
        strTDName = lstTDName
    End If
End Sub

'过程功能：创建或打开数据表
Sub CreateOrOpenTD(blnNew As Boolean)
    lblPoint.Visible = True
    If blnNew Then                  '新建数据表
        Set td = db.CreateTableDef(strTDName)
        Line1.Visible = True
        lblPoint.Caption = "提示：必须转入“字段”操作，否则" & _
                "创建的数据表无效！"
    Else                            '打开数据表
        Set td = db.TableDefs(strTDName)
    End If
End Sub

'函数功能：检查是否有打开的数据库和数据表
Function CheckOpen() As Boolean
    CheckOpen = True
    If strDBName = "" Then
        MsgBox "没有打开数据库,重作!", 0
        CheckOpen = False
        Exit Function
    End If
    If strTDName = "" Then
        MsgBox "没有打开数据表,重作!", 0
        CheckOpen = False
    End If
End Function

'*********************以下为菜单事件*****************************
'显示驱动器信息
Private Sub mnuDrive_Click()
    Unload Me
    frmDriveList.Show
End Sub

'显示目录信息
Private Sub mnuDir_Click()
    Unload Me
    frmDirList.Show
End Sub

'显示文件信息
Private Sub mnuFile_Click()
    Unload Me
    frmFileList.Show
End Sub

'单击“数据库”菜单事件
Private Sub mnuDatabase_Click()
    Line1.Visible = True        '显示分割线
    lblPoint.Caption = _
    "提示：如果要进行数据库的压缩或修理，数据库必须是关闭状态，不能打开再作！"
    lblPoint.Visible = True     '显示提示标签
End Sub

'创建数据库
Private Sub mnuCreateDatabase_Click()
    Line1.Visible = False           '不显示分割线
    lblPoint.Visible = False        '不显示提示标签
    lblTDName.Visible = False
    lstTDName.Visible = False
    GetDBName True                  '取得数据库名
    If SameDBName Then              'SameDBName为True意味重名
        MsgBox "停止建库", , "创建数据库"
        Exit Sub                    '重名,且不删除旧的则停止建库
    End If
    mnuTable.Enabled = True         '“数据表”菜单可用
    mnuCreateTable.Enabled = True   '“新建”数据表菜单可用
    mnuOpenTable.Enabled = False    '“打开”数据表菜单不可用
    mnuDeleteTable.Enabled = False  '“删除”数据表菜单不可用
    CreateOrOpenDB True             '新建数据库
End Sub

'关闭数据库
Private Sub mnuCloseDatabase_Click()
    On Error Resume Next
    db.Close                        '关闭数据库
    Unload Me                       '卸载窗体
End Sub

'创建数据表
Private Sub mnuCreateTable_Click()
    On Error GoTo CreateError
    If strDBName = "" Then
        MsgBox "没有打开数据库,重作!", 0, "“字段”"
        Exit Sub
    End If
    mnuField.Enabled = True         '“字段”菜单可用
    GetTDName True                  '取得数据表名
    CreateOrOpenTD True             '创建数据表
    Exit Sub
CreateError:
    MsgBox "创建数据表错误", , "创建数据表"
End Sub

'打开数据库
Private Sub mnuOpenDatabase_Click()
    Line1.Visible = False           '不显示分割线
    lblPoint.Visible = False        '不显示提示标签
    On Error GoTo OpenError
    GetDBName False               '取得数据库名
    CreateOrOpenDB False          '打开数据库
    lblTDName.Visible = True      '使数据表名指示标签可视
    lstTDName.Visible = True      '使数据表名列表框可视
    lstTDName.Clear
    If db.TableDefs.Count <= 4 Then
        MsgBox "该数据库无数据表，没有建成，需要重新创建！"
        Exit Sub
    End If
'在列表框显示数据表
    For Each td In db.TableDefs
        If (td.Attributes And dbSystemObject) = 0 Then  '甩掉系统表
            If (td.Attributes <> dbAttachedTable) Then  '甩掉附属表
                lstTDName.AddItem td.Name               '用户表进入列表框
            End If
        End If
    Next
    Line1.Visible = True
    lblPoint.Visible = True
    lblPoint.Caption = _
    "提示：进入“记录集”、“字段”、“索引”等操作前，" & Chr(10) & Chr(13) & _
    "       需单击列表框中的数据表,再用“数据表”菜单打开该数据表"
    mnuIndex.Enabled = False        '“索引”菜单项无效
    mnuRecordset.Enabled = False    '“记录集”菜单项无效
    mnuField.Enabled = False        '“字段”菜单项无效
    mnuRelation.Enabled = True      '“强制关联”菜单项有效
    mnuQuery.Enabled = True         '“查询”菜单项有效
    mnuTable.Enabled = True         '“数据表”菜单可用
    mnuCreateTable.Enabled = True   '“新建”数据表菜单可用
    mnuOpenTable.Enabled = True     '“打开”数据表菜单可用
    mnuDeleteTable.Enabled = True   '“删除”数据表菜单可用
    Exit Sub
OpenError:
    MsgBox "打开数据库错误", , "打开数据库"
End Sub

'压缩数据库,事先打开数据库会产生错误
Private Sub mnuCompactDatabase_Click()
    Dim strOldDBName As String, strNewDBName As String
    On Error GoTo compactErr
    MsgBox "准备提供被压缩的数据库名"
    GetDBName False                     '取得被压缩的数据库名
    strOldDBName = strDBName            '被压缩的数据库名
    MsgBox "准备提供压缩后的数据库名，两者不能重名"
    GetDBName True                      '取得压缩后的数据库名
    strNewDBName = strDBName            '压缩后的数据库名
    If strOldDBName = strNewDBName Then
        MsgBox "提供压缩后的数据库名,不能与被压缩的数据库名相重"
    End If
'执行压缩
    lblPoint.Visible = True
    lblPoint.Caption = "提示：正在压缩数据库_" & strOldDBName
    DBEngine.CompactDatabase strOldDBName, strNewDBName
    lblPoint.Caption = "提示：压缩完成，请继续其他工作"
    Exit Sub
compactErr:
    MsgBox Err.Description, vbExclamation, "数据库压缩错误"
    lblPoint.Caption = "提示：压缩数据库不正常终止，请继续其他工作"
End Sub

'修理数据库,事先打开数据库会产生错误
Private Sub mnuRepairDatabase_Click()
    Dim strRepairDBName
    On Error GoTo repairErr
    MsgBox "准备提供被修理的数据库名"
    GetDBName False                     '取得被修理的数据库名
    strRepairDBName = strDBName         '被修理的数据库名
'执行修理
    lblPoint.Visible = True             '使提示标签可视
    lblPoint.Caption = "提示：正在修理数据库_" & strRepairDBName
    DBEngine.RepairDatabase strRepairDBName
    lblPoint.Caption = "提示：修理完成，请继续其他工作"
    Exit Sub
repairErr:
    MsgBox Err.Description, vbExclamation, "数据库修理错误"
    lblPoint.Caption = "提示：修理数据库不正常终止，请继续其他工作"
End Sub

'打开数据表
Private Sub mnuOpenTable_Click()
    On Error GoTo OpenError
    If strDBName = "" Then
        MsgBox "没有打开数据库,重作!", 0, "添加字段"
        Exit Sub
    End If
    GetTDName False                 '取得数据表名
    CreateOrOpenTD False            '打开数据表
    lblField.Visible = True         '使字段名指示标签可视
    lstField.Visible = True         '使字段名列表框可视
    lstField.Clear
    lblField.Caption = strTDName & "所包括的字段："
    For Each fd In td.Fields
        lstField.AddItem fd.Name    '字段名加入列表框
    Next
    lblIndex.Visible = True         '使索引名指示标签可视
    lstIndex.Visible = True         '使索引名列表框可视
    lstIndex.Clear
    lblIndex.Caption = strTDName & "所包括的索引："
    For Each id In td.Indexes
        lstIndex.AddItem id.Name    '索引名加入列表框
    Next
    mnuField.Enabled = True         '“字段”菜单项有效
    mnuIndex.Enabled = True         '“索引”菜单项有效
    mnuRecordset = True             '“记录集”菜单项有效
    mnuRelation.Enabled = False     '“强制关联”菜单项无效
    mnuQuery.Enabled = False        '“查询”菜单项无效
    lblPoint.Caption = "提示：可以转入“字段”、“索引”、或“记录集”等操作"
    Exit Sub
OpenError:
    MsgBox "打开数据表错误,试着重新打开数据库或创建新表或新字段", , _
           "打开数据表"
    lblPoint.Caption = "提示：试着重新打开数据库或创建新表或新字段"
End Sub

'删除数据表
Private Sub mnuDeleteTable_Click()
'必须先打开数据库和数据表,然后才能删除数据表
    If CheckOpen = False Then Exit Sub      '没有打开的数据库或数据表
    msgResult = MsgBox("确实要删除数据表:" & strTDName, vbYesNo, "数据表")
    If msgResult = vbYes Then db.TableDefs.Delete (strTDName)   '删除数据表
    lstTDName.Clear
    For Each td In db.TableDefs
        If (td.Attributes And dbSystemObject) = 0 Then  '甩掉系统表
            If (td.Attributes <> dbAttachedTable) Then  '甩掉附属表
                lstTDName.AddItem td.Name               '用户表进入列表框
            End If
        End If
    Next
    lblField.Visible = False         '使字段名指示标签不可视
    lstField.Visible = False         '使字段名列表框不可视
    lblIndex.Visible = False         '使索引名指示标签不可视
    lstIndex.Visible = False         '使索引名列表框不可视