mdlcreatemdb.bas

这是一个实际的工程中所用的源程序

    Dim wrkDefault As Workspace
    Dim dbsNew As Database
    Dim tdfNew As TableDef
    Dim idfNew As Index
    Dim i As Integer
    Dim MbIndex As String
    Debug.Print "Tables been created!"
    On Error GoTo err1:
    Set wrkDefault = DBEngine.Workspaces(0)
    Set dbsNew = wrkDefault.OpenDatabase(PathMdb)
        
         Set tdfNew = dbsNew.CreateTableDef(TableName)
        
         With tdfNew
        
             .Fields.Append .CreateField("Id", dbLong) '0.
             .Fields.Append .CreateField("Name", dbText, 20)
             .Fields.Append .CreateField("Addr", dbInteger)   '1.
             .Fields.Append .CreateField("CangId", dbInteger)   '1.
             .Fields.Append .CreateField("Mark", dbInteger)  '2.
             .Fields.Append .CreateField("mDate", dbDate)  '2.
             .Fields.Append .CreateField("mTime", dbDate)    '3.
             .Fields.Append .CreateField("mValue", dbDouble)    '4.
             .Fields("Name").AllowZeroLength = True
             .Fields("Id").Attributes = dbAutoIncrField '不要
       End With
       dbsNew.TableDefs.Append tdfNew
       '建索引
       Set idfNew = tdfNew.CreateIndex(PrimaryKey)
       With idfNew
         .Fields.Append .CreateField("Id", dbLong)
         .Primary = True
         .Unique = True
       End With
       tdfNew.Indexes.Append idfNew
       
   dbsNew.Close
exitSub:
       
    Set dbsNew = Nothing
    Set wrkDefault = Nothing
    
    Exit Sub
err1:
    Call meErr("CreateTableDef_Monitor", Err.Description) ', , , , PATH_Errlog)
    Err.Clear
    Resume exitSub
  End Sub
  Public Sub CreateTableDef_tblUr(vDatabasePath As String)  'Mk:库名 idxMk:库中各个表的索引
  '可以创建一个标准的数据库接口，接受灵活的表及字段输入，
    Dim wrkDefault As Workspace
    Dim dbsNew As Database
    Dim tdfNew As TableDef
    Dim idfNew As Index
    Dim i As Integer
    Dim MbIndex As String
    Debug.Print "Tables been created!"
    On Error GoTo err1:
    Set wrkDefault = DBEngine.Workspaces(0)
    Set dbsNew = wrkDefault.OpenDatabase(vDatabasePath)
        
         Set tdfNew = dbsNew.CreateTableDef("Ur")
        
         With tdfNew
        
             .Fields.Append .CreateField("用户", dbText, 10)   '4.
             .Fields.Append .CreateField("密码", dbText, 10)   '4.
             
             .Fields.Append .CreateField("hh", dbLong)    '4.
             
             
             .Fields("用户").AllowZeroLength = True '
             .Fields("密码").AllowZeroLength = True '
             
       End With
       dbsNew.TableDefs.Append tdfNew
       '建索引(略)
    dbsNew.Close
exitSub:
    Set dbsNew = Nothing
    Set wrkDefault = Nothing
    
    Exit Sub
err1:
    Debug.Assert False
    Call meErr("CreateTableDef_tblUr", Err.Description) ', , , , PATH_Errlog)
    Err.Clear
    Resume exitSub
  End Sub


  Public Sub CreateTableDef_tblQX(vDatabasePath As String, IdxMk As String) 'Mk:库名 idxMk:库中各个表的索引
    If Dir(vDatabasePath) <> "" Then Exit Sub
  '
    Dim vTableName As String
    Dim wrkDefault As Workspace
    Dim dbsNew As Database
    Dim tdfNew As TableDef
    Dim idfNew As Index
    Dim i As Integer
    Dim MbIndex As String
    Debug.Print "Tables been created!"
    On Error GoTo err1:
    Set wrkDefault = DBEngine.Workspaces(0)
    
      Set dbsNew = wrkDefault.CreateDatabase(vDatabasePath, _
        dbLangGeneral, dbEncrypt)
        
    For i = 1 To 31
        vTableName = CStr(i)
        
         Set tdfNew = dbsNew.CreateTableDef(vTableName)
        
         With tdfNew
        
             .Fields.Append .CreateField("RQ", dbDate)  '0.
             .Fields.Append .CreateField("sj", dbDate)
             .Fields.Append .CreateField("b1", dbSingle)   '1.
             .Fields.Append .CreateField("b2", dbSingle)   '1.
             .Fields.Append .CreateField("b3", dbSingle)   '1.
             .Fields.Append .CreateField("b4", dbSingle)   '1.
             
'             .Fields("班次").AllowZeroLength = True'不容许,为了炉数据中的定位(4个班表)
             

       End With
       dbsNew.TableDefs.Append tdfNew
       '建索引
       Set idfNew = tdfNew.CreateIndex(IdxMk)
       
       With idfNew
         .Fields.Append .CreateField("sj", dbDate)
         .Primary = True
         .Unique = True
       End With
       tdfNew.Indexes.Append idfNew
       
       Next i '下一表
    dbsNew.Close
exitSub:
    Set dbsNew = Nothing
    Set wrkDefault = Nothing
    
    Exit Sub
err1:
    Debug.Assert False
    Call meErr("CreateTableDef_tblBanX", Err.Description) ', , , , PATH_Errlog)
    Err.Clear
    Resume exitSub
  End Sub
  Public Sub CreateTableDef_tblProportion(vDatabasePath As String, IdxMk As String) 'Mk:库名 idxMk:库中各个表的索引
  '四个日表:tblRii1,tblRii2,tblRii3,tblRii4
    Dim vTableName As String
    Dim wrkDefault As Workspace
    Dim dbsNew As Database
    Dim tdfNew As TableDef
    Dim idfNew As Index
    Dim i As Integer
    Dim MbIndex As String
    Debug.Print "Tables been created!"
    On Error GoTo err1:
    Set wrkDefault = DBEngine.Workspaces(0)
    Set dbsNew = wrkDefault.OpenDatabase(vDatabasePath)
        vTableName = "tblProportion"
         Set tdfNew = dbsNew.CreateTableDef(vTableName)
        
         With tdfNew
        
             .Fields.Append .CreateField("名称", dbText, 10) '0.
             For i = 1 To TechCount
             
                .Fields.Append .CreateField("Pb" & CStr(i), dbSingle)   '1.
             Next i
             
             .Fields("名称").Required = True
       End With
       dbsNew.TableDefs.Append tdfNew
       '建索引
       Set idfNew = tdfNew.CreateIndex(IdxMk)
       
       With idfNew
         .Fields.Append .CreateField("名称", dbText, 10)
         .Primary = True
         .Unique = True
       End With
       tdfNew.Indexes.Append idfNew
       
    dbsNew.Close
exitSub:
    Set dbsNew = Nothing
    Set wrkDefault = Nothing
    
    Exit Sub
err1:
    Call meErr("CreateTableDef_tblRiiUS", Err.Description) ', , , , PATH_Errlog)
    Err.Clear
    Resume exitSub
  End Sub

  Public Sub CreateTableDef_tblAppLog(vDatabasePath As String, vTableName As String) 'Mk:库名 idxMk:库中各个表的索引
  '四个班表:tblBan1,tblBan2,tblBan3,tblBan4
'    Dim vTableName As String
    Dim wrkDefault As Workspace
    Dim dbsNew As Database
    Dim tdfNew As TableDef
    Dim idfNew As Index
    Dim i As Integer
    Dim MbIndex As String
    Debug.Print "Tables been created!"
    On Error GoTo err1:
    Set wrkDefault = DBEngine.Workspaces(0)
    Set dbsNew = wrkDefault.OpenDatabase(vDatabasePath)


         Set tdfNew = dbsNew.CreateTableDef(vTableName)

         With tdfNew
             .Fields.Append .CreateField("类型", dbText, 10)
             .Fields.Append .CreateField("时间", dbDate)
             .Fields.Append .CreateField("来源", dbText, 30)
             .Fields.Append .CreateField("事件", dbText, 30)
             .Fields.Append .CreateField("描述", dbText, 255)
             .Fields.Append .CreateField("用户", dbText, 30)
             .Fields("类型").AllowZeroLength = True '
             .Fields("来源").AllowZeroLength = True '
             .Fields("事件").AllowZeroLength = True '
             .Fields("描述").AllowZeroLength = True '
             .Fields("用户").AllowZeroLength = True '
       End With
       Dim field_Id As Field

       dbsNew.TableDefs.Append tdfNew
       '建索引
       Set idfNew = tdfNew.CreateIndex("idx")

       With idfNew
         .Fields.Append .CreateField("时间", dbInteger)
         .Primary = True
         .Unique = True
       End With
       tdfNew.Indexes.Append idfNew

exitSub:

    dbsNew.Close
    Set dbsNew = Nothing
    Set wrkDefault = Nothing

    Exit Sub
err1:
    Call meErr("CreateTableDef_tblAppLog", Err.Description)
    Err.Clear
    Resume exitSub
  End Sub