档案馆模型库系统的VB实现

公共变量：

Public cnn As ADODB.Connection
Public rs As ADODB.Recordset

 

Form1：

Private Sub Form_load()
    '建立与模型库的连接
    Set cnn = New ADODB.Connection
    With cnn
        .Provider = "microsoft.jet.oledb.4.0"  '数据库驱动程序
        .Open "D:\档案模型系统.mdb"
    End With
    '查找模型库中的模型，并设置给“模型清单”列表框
    Call 获取模型清单
End Sub

Public Sub 获取模型清单()
    '获取模型库中的表
    Set rs = cnn.OpenSchema(adSchemaTables)
    With 模型清单
        .Clear
        Do Until rs.EOF
            If Left(rs!table_name, 4) <> "MSys" Then  '系统表不显示
                模型清单.AddItem rs!table_name
            End If
            rs.MoveNext
        Loop
    End With
End Sub

Private Sub 查找模型_Click()
    '指定要查找模型的名称
    myNewName = InputBox("请输入要查找的模型名称：", "输入模型名称")
    If Len(Trim(myNewName)) = 0 Then 'Trim(str)，去掉str两边的空格
        MsgBox "没有输入有效的模型名！", vbCritical
        Exit Sub
    End If
    '检查模型库中是否有同名模型
    Set rs = cnn.OpenSchema(adSchemaTables) '语法：Set 记录集对象名= connection.OpenSchema(QueryType, Criteria, SchemaID)，参数：QueryType 所要运行的模式查询类型可以是一系列常量，比如adSchemaColumns
    Do Until rs.EOF
        If LCase(rs!table_name) = LCase(myNewName) Then
            模型清单.Text = rs!table_name
            MsgBox "找到模型：" & myNewName
            Exit Sub
        End If
        rs.MoveNext
    Loop
    If rs.EOF = True Then
        MsgBox "没有找到模型：" & myNewName & " ！", vbCritical, "警告"
    End If
End Sub

    Private Sub 创建模型_Click()
        Form2.Show   '打开“创建模型窗体”子窗体
        Call 获取模型清单    '刷新“模型清单”列表框
    End Sub

    Private Sub 打开模型_Click()
        '判断是否选择了要打开的模型
        If 模型清单.ListIndex = -1 Then
            MsgBox "没有选择要打开的模型！", vbCritical, "警告"
            Exit Sub
        End If
        '打开选择的模型
        Dim myAccess As Object  'Object 数据类型保存引用对象的 32 位（4 字节）地址。可以为 Object 的变量分配任何引用类型（字符串、数组、类或接口）。Object 变量还可以引用任何值类型（数值、Boolean、Char、Date、结构或枚举）的数据。
        Set myAccess = CreateObject("D:\档案模型系统.mdb")
        With myAccess
            .Visible = True
            .DoCmd.OpenTable 模型清单.Text  'DoCmd 对象方法的任务是打开和关闭Access对象
            .DoCmd.Maximize
        End With
        '释放变量
        Set myAccess = Nothing
    End Sub

    Private Sub 复制模型_Click()
        Dim SQL As String, myNewName As String
        '判断是否选择了要复制的模型
        If 模型清单.ListIndex = -1 Then
            MsgBox "没有选择要复制的模型！", vbCritical, "警告"
            Exit Sub
        End If
        '确认是否复制选择的模型
        If MsgBox("是否要复制模型<" & 模型清单.Text & ">？", _
            vbQuestion + vbYesNo) = vbNo Then Exit Sub
begin:
        '指定模型的新名称
        myNewName = InputBox("请输入模型新名称：", "输入模型名称")
        If Len(Trim(myNewName)) = 0 Then
            MsgBox "没有输入有效的模型名！", vbCritical
            Exit Sub
        End If
        '检查模型库中是否有同名模型
        Set rs = cnn.OpenSchema(adSchemaTables)
        Do Until rs.EOF
            If LCase(rs!table_name) = LCase(myNewName) Then
                MsgBox "模型<" & myNewName & ">已经存在！请重新输入模型名！", _
                    vbCritical, "警告"
                GoTo begin
                Exit Sub
            End If
            rs.MoveNext
        Loop
        '生成一个查询表
        SQL = "select * into " & myNewName & " from " & 模型清单.Text
        Set rs = cnn.Execute(SQL)
        MsgBox "将模型<" & 模型清单.Text & ">复制了一份。名称为<" _
            & myNewName & ">", vbInformation + vbOKOnly, "复制模型"
        '刷新“模型清单”列表框
        Call 获取模型清单
        '删除“字段清单”列表框中的项目
        字段清单.Clear
    End Sub

    Private Sub 改变字段长度_Click()
        Dim SQL As String, myFieldType As String
        '判断是否选择了要改变字段长度的字段
        If 字段清单.ListIndex = -1 Then
            MsgBox "没有选择要改变字段长度的字段！", vbCritical, "警告"
            Exit Sub
        End If
        '确认是否改变选择字段的长度
        If MsgBox("是否改变字段<" & 字段清单.Text & ">的长度？", _
            vbQuestion + vbYesNo) = vbNo Then Exit Sub
begin:
        '指定字段新类型
        myFieldType = InputBox("请输入字段类型及长度：", "输入字段类型及长度")
        If Len(Trim(myFieldType)) = 0 Then
            MsgBox "没有输入有效的字段类型和长度！", vbCritical
            Exit Sub
        End If
        '改变选择字段的模型类型
        SQL = "alter table " & 模型清单.Text & " alter " _
            & 字段清单.Text & Space(1) & myFieldType
        Set rs = New ADODB.Recordset
        rs.Open SQL, cnn, adOpenDynamic, adLockOptimistic  '游标类型，加锁类型  ADOPENDYNAMIC(=2) 可读写 , 当前数据记录可自由移动   ADLOCKOPTIMISTIC(=3) 乐观锁定 ，直到用Update方法提交更新记录时才锁定记录。
        MsgBox "模型<" & 模型清单.Text & ">中的字段<" _
            & 字段清单.Text & ">的长度被改变！", _
            vbInformation + vbOKOnly, "改变字段长度"
    End Sub

    Private Sub 改变字段类型_Click()
        Dim SQL As String, myFieldType As String
        '判断是否选择了要改变模型类型的字段
        If 字段清单.ListIndex = -1 Then
            MsgBox "没有选择要改变模型类型的字段！", vbCritical, "警告"
            Exit Sub
        End If
        '确认是否改变选择字段的模型类型
        If MsgBox("是否改变字段<" & 字段清单.Text & ">的模型类型？", _
            vbQuestion + vbYesNo) = vbNo Then Exit Sub
begin:
        '指定字段新类型
        myFieldType = InputBox("请输入字段新类型：", "输入字段新类型")
        If Len(Trim(myFieldType)) = 0 Then
            MsgBox "没有输入有效的字段类型！", vbCritical
            Exit Sub
        End If
        '改变选择字段的模型类型
        SQL = "alter table " & 模型清单.Text & " alter " _
            & 字段清单.Text & Space(1) & myFieldType
        Set rs = New ADODB.Recordset
        rs.Open SQL, cnn, adOpenDynamic, adLockOptimistic
        MsgBox "模型<" & 模型清单.Text & ">中的字段<" _
            & 字段清单.Text & ">的类型被改变！", _
            vbInformation + vbOKOnly, "改变字段类型"
    End Sub

    Private Sub 删除模型_Click()
        Dim SQL As String
        '判断是否选择了要删除的模型
        If 模型清单.ListIndex = -1 Then
            MsgBox "没有选择要删除的模型！", vbCritical, "警告"
            Exit Sub
        End If
        '确认是否删除选择的模型
        If MsgBox("是否要删除模型<" & 模型清单.Text & ">？", _
            vbQuestion + vbYesNo) = vbNo Then Exit Sub
        '删除选定的模型
        SQL = "drop table " & 模型清单.Text
        Set rs = cnn.Execute(SQL)
        MsgBox "模型<" & 模型清单.Text & ">被成功删除！", _
            vbInformation + vbOKOnly, "删除模型"
        '刷新“模型清单”列表框
        Call 获取模型清单
        '删除“字段清单”列表框中的项目
        字段清单.Clear
    End Sub

    Private Sub 删除字段_Click()
        Dim SQL As String
        '判断是否选择了要删除的字段
        If 字段清单.ListIndex = -1 Then
            MsgBox "没有选择要删除的字段！", vbCritical, "警告"
            Exit Sub
        End If
        '确认是否删除选择的字段
        If MsgBox("是否要删除字段<" & 字段清单.Text & ">？", _
            vbQuestion + vbYesNo) = vbNo Then Exit Sub
        '删除选定的字段
        SQL = "alter table " & 模型清单.Text & " drop " & 字段清单.Text
        Set rs = New ADODB.Recordset
        rs.Open SQL, cnn, adOpenDynamic, adLockOptimistic
        MsgBox "模型<" & 模型清单.Text & ">中的字段<" _
            & 字段清单.Text & ">被成功删除！", _
            vbInformation + vbOKOnly, "删除模型"
        '刷新“字段清单”列表框
        Call 获取字段清单
    End Sub
Private Sub 模型清单_Click()
        Call 获取字段清单
End Sub
Public Sub 获取字段清单()
        On Error Resume Next
        Dim SQL As String, i As Integer
        '查询选择的模型，将字段名清单设置给“字段清单”列表框
        SQL = "select * from " & 模型清单.Text
        Set rs = cnn.Execute(SQL)
        With 字段清单
            .Clear
            For i = 0 To rs.Fields.Count - 1
                .AddItem rs.Fields(i).Name
            Next i
        End With
        rs.Close
End Sub
Private Sub 刷新_Click()
    Call 获取模型清单
End Sub

    Private Sub 添加字段_Click()
        Dim SQL As String, myNewField As String
        '判断是否选择了要添加字段的模型
        If 模型清单.ListIndex = -1 Then
            MsgBox "没有选择要添加字段的模型！", vbCritical, "警告"
            Exit Sub
        End If
begin:
        '指定新字段名称
        myNewField = InputBox("请输入新字段名称和类型：", "输入新字段名称类型")
        If Len(Trim(myNewField)) = 0 Then
            MsgBox "没有输入有效的字段名！", vbCritical
            Exit Sub
        End If
        '确认是否添加字段
        If MsgBox("是否要向模型<" & 模型清单.Text _
            & ">中添加字段<" & myNewField & ">？", _
            vbQuestion + vbYesNo) = vbNo Then Exit Sub
        '检查模型中是否有同名的字段
        Set rs = cnn.OpenSchema(adSchemaColumns)
        Do Until rs.EOF
            If LCase(rs!column_name) = LCase(myNewField) Then
               MsgBox "在模型<" & 模型清单 & ">中已经存在字段< " _
                & myNewField & ">！", vbCritical, "警告"
                GoTo begin
                Exit Sub
            End If
            rs.MoveNext
        Loop
        '添加字段
        SQL = "alter table " & 模型清单.Text & " add " & myNewField
        Set rs = New ADODB.Recordset
        rs.Open SQL, cnn, adOpenDynamic, adLockOptimistic
        MsgBox "在模型<" & 模型清单.Text & ">中成功添加了字段<" _
            & myNewField, vbInformation + vbOKOnly, "删除模型"
        '刷新“字段清单”列表框
        Call 获取字段清单
    End Sub

    Private Sub 退出系统_Click()
        cnn.Close
        Set rs = Nothing
        Set myCat = Nothing
        Set cnn = Nothing
        Unload Form1
    End Sub

Private Sub 重命名模型_Click()
    Dim SQL As String, myNewName As String
    '判断是否选择了要重命名的模型
    If 模型清单.ListIndex = -1 Then
        MsgBox "没有选择要重命名的模型！", vbCritical, "警告"
        Exit Sub
    End If
    '确认是否删除选择的模型
    If MsgBox("是否要重命名模型<" & 模型清单.Text & ">？", _
        vbQuestion + vbYesNo) = vbNo Then Exit Sub
begin:
    '指定模型的新名称
    myNewName = InputBox("请输入模型新名称：", "输入模型名称")
    If Len(Trim(myNewName)) = 0 Then
        MsgBox "没有输入有效的模型名！", vbCritical
        Exit Sub
    End If
    '检查模型库中是否有同名模型
    Set rs = cnn.OpenSchema(adSchemaTables)
    Do Until rs.EOF
        If LCase(rs!table_name) = LCase(myNewName) Then
            MsgBox "模型<" & myNewName & ">已经存在！请重新输入模型名！", _
                vbCritical, "警告"
            GoTo begin
            Exit Sub
        End If
        rs.MoveNext
    Loop
    '生成一个查询表
    SQL = "select * into " & myNewName & " from " & 模型清单.Text
    Set rs = cnn.Execute(SQL)
    '删除原来的模型
    SQL = "drop table " & 模型清单.Text
    Set rs = cnn.Execute(SQL)
    MsgBox "成功将模型<" & 模型清单.Text & ">名称改为<" _
        & myNewName & ">", vbInformation + vbOKOnly, "模型重命名"
    '刷新“模型清单”列表框
    Call 获取模型清单
    '删除“字段清单”列表框中的项目
    字段清单.Clear
End Sub
Private Sub 字段清单_Click()
        Call 获取字段信息
End Sub
Public Sub 获取字段信息()
        Dim SQL As String, i As Integer
        '查询选择的模型
        SQL = "select * from " & 模型清单.Text
        Set rs = New ADODB.Recordset
        rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
        '将字段名称、类型和大小输出到有关文字框
        字段名称.Text = rs.Fields(字段清单.Text).Name
        字段类型 = getType(rs.Fields(字段清单.Text).Type)
        字段长度 = rs.Fields(字段清单.Text).DefinedSize
End Sub
Function getType(num)
   getType = num
   Select Case num
     Case "202":
       getType = "文本"  'nvarchar(255) 可以  nvarchar 数据类型用作变长的统一编码字符型数据。此数据类型能存储4000种字符，使用的字节空间增加了一倍
     Case "203":
       getType = "备注"  'ntext(536870910) 可以  ntext 数据类型用来存储大量的统一编码字符型数据。这种数据类型能存储230 -1或将近10亿个字符，且使用的字节空间增加了一倍
     Case "3":
       getType = "长整型"  'int(4) 不可以  int 数据类型可以存储从- 231(-2147483648)到231 (2147483 647)之间的整数。存储到数据库的几乎所有数值型的数据都可以用这种数据类型。这种数据类型在数据库里占用4个字节
     Case "2":
       getType = "整型"    'smallint(2)  不可以 smallint 数据类型可以存储从- 215(-32768)到215(32767)之间的整数。这种数据类型对存储一些常限定在特定范围内的数值型数据非常有用。这种数据类型在数据库里占用2 字节空间
     Case "17":
       getType = "字节"    'tinyint(1)  不可以  tinyint 数据类型能存储从0到255 之间的整数。它在你只打算存储有限数目的数值时很有用。 这种数据类型在数据库中占用1 个字节
     Case "4":
       getType = "单精浮点"    'real(4)   不可以   real 数据类型像浮点数一样，是近似数值类型。它可以表示数值在-3.40E+38到3.40E+38之间的浮点数
     Case "5":
       getType = "双精浮点"    'float(8)   不可以  float 数据类型是一种近似数值类型，供浮点数使用。说浮点数是近似的，是因为在其范围内不是所有的数都能精确表示。浮点数可以是从-1.79E+308到1.79E+308 之间的任意数
     Case "7":
       getType = "日期/时间"   'datetime(8)   不可以 datetime数据类型用来表示日期和时间。这种数据类型存储从1753年1月1日到9999年12月3 1日间所有的日期和时间数据， 精确到三百分之一秒或3.33毫秒
     Case "6":
       getType = "货币"    'money(8)  不可以  money 数据类型用来表示钱和货币值。这种数据类型能存储从-9220亿到9220 亿之间的数据，精确到货币单位的万分之一
     Case "11":
       getType = "是/否"    'bit(2)  不可以   bit 数据类型是整型，其值只能是0、1或空值。这种数据类型用于存储只有两种可能值的数据，如Yes 或No、True 或Fa lse 、On 或Off
   End Select
End Function

Form2：

Private Sub Form_load()
        字段字符串.Text = "示例：  字段1 nvarchar(10) primary key,字段2 datetime,字段3 float"
End Sub
    Private Sub 字段字符串_Enter()
        字段字符串.Text = ""
    End Sub
    Private Sub 取消_Click()
        Unload Form2
    End Sub
    Private Sub 确定_Click()
        Dim SQL As String
        '检查模型库中是否有同名模型
        Set rs = cnn.OpenSchema(adSchemaTables)
        Do Until rs.EOF
            If LCase(rs!table_name) = LCase(模型名.Text) Then
                MsgBox "模型<" & mytable & ">已经存在！请重新输入模型名！"
                模型名.Text = ""
                模型名.SetFocus
                Exit Sub
            End If
            rs.MoveNext
        Loop
        '创建模型
        SQL = "create table " & 模型名.Text & Space(1) & "(" & 字段字符串.Text & ")"
        Set rs = cnn.Execute(SQL)
        MsgBox "模型创建成功！", vbInformation, "创建模型"
        Unload Form2
    End Sub

Form4：