mdlcreatemdb.bas

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

Attribute VB_Name = "mdlCreateMdb"
Option Explicit
Public Sub CreateTableDef_DataBase(vDatabasePath As String) 'Mk:库名 idxMk:库中各个表的索引
  '可以创建一个标准的数据库接口，接受灵活的表及字段输入，
    Dim wrkDefault As Workspace
    Dim dbsNew As Database
    Debug.Print "Tables been created!"
    On Error GoTo err1:
    Set wrkDefault = DBEngine.Workspaces(0)
      Set dbsNew = wrkDefault.CreateDatabase(vDatabasePath, _
        dbLangChineseSimplified, dbEncrypt)
       
    dbsNew.Close
exitSub:
    Set dbsNew = Nothing
    Set wrkDefault = Nothing
    
    Exit Sub
err1:
    Call MsgBox("CreateTableDef_DataBase" & vbCr & Err.Description)
    Err.Clear
    Resume exitSub
  End Sub

    Public Sub CreateTableDef_tblBanUS(vDatabasePath As String, IdxMk 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)
        
        vTableName = "tblBanUS"
        
         Set tdfNew = dbsNew.CreateTableDef(vTableName)
        
         With tdfNew
        
             .Fields.Append .CreateField("日期", dbDate)   '0.
             .Fields.Append .CreateField("班次", dbText, 10)  '1.
             .Fields.Append .CreateField("时间", dbDate)
             .Fields.Append .CreateField("值班人", dbText, 10)  '1.
             .Fields.Append .CreateField("Cang1", dbDouble)   '1.
             .Fields.Append .CreateField("Cang2", dbDouble)   '1.
             .Fields.Append .CreateField("Cang3", dbDouble)   '1.
             .Fields.Append .CreateField("Cang4", dbDouble)   '1.
             .Fields.Append .CreateField("Cang5", dbDouble)   '1.
             
             .Fields("班次").AllowZeroLength = True '
             .Fields("值班人").AllowZeroLength = True '
             

       End With
       dbsNew.TableDefs.Append tdfNew
       '建索引
       Set idfNew = tdfNew.CreateIndex(IdxMk)
       
       With idfNew
         .Fields.Append .CreateField("日期", dbDate)
         .Fields.Append .CreateField("时间", dbDate)
         .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_tblBanUS", Err.Description) ', , , , PATH_Errlog)
    Err.Clear
    Resume exitSub
  End Sub
  Public Sub CreateTableDef_tblBanXR(vDatabasePath As String, IdxMk 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)
        
        vTableName = "tblBanXR"
        
         Set tdfNew = dbsNew.CreateTableDef(vTableName)
'Public Enum eShop
'    [e仪表] = -1
'    [e船名] = 0
'    [e煤种] = 1
'    [e流程] = 2
'    [e设定] = 3
'    [e计量] = 4
'    [e日期] = 5
'    [e时间] = 6
'    [e备注] = 7
'End Enum
         With tdfNew
             .Fields.Append .CreateField(nmShop(eShop.e仪表), dbText, 10)
             .Fields.Append .CreateField(nmShop(eShop.e船名), dbText, 20)
             .Fields.Append .CreateField(nmShop(eShop.e煤种), dbText, 10)   '1.
             .Fields.Append .CreateField(nmShop(eShop.e流程), dbText, 10)   '1.
             .Fields.Append .CreateField(nmShop(eShop.e设定), dbDouble)
             .Fields.Append .CreateField(nmShop(eShop.e计量), dbDouble)
             .Fields.Append .CreateField(nmShop(eShop.e日期), dbDate)   '0.
             .Fields.Append .CreateField(nmShop(eShop.e时间), dbDate)
             .Fields.Append .CreateField(nmShop(eShop.e备注), dbText, 50)
'             For i = 1 To TechCount
'             .Fields.Append .CreateField("NameTech" & CStr(i), dbDouble)   '1.
'             Next i
             .Fields(nmShop(eShop.e船名)).AllowZeroLength = True  '
             .Fields(nmShop(eShop.e煤种)).AllowZeroLength = True   '
             .Fields(nmShop(eShop.e流程)).AllowZeroLength = True   '
             .Fields(nmShop(eShop.e备注)).AllowZeroLength = True '

       End With
       dbsNew.TableDefs.Append tdfNew
       '建索引
       Set idfNew = tdfNew.CreateIndex(IdxMk)
       
       With idfNew
         .Fields.Append .CreateField(nmShop(eShop.e日期), dbDate)
         .Fields.Append .CreateField(nmShop(eShop.e时间), dbDate)
         .Fields.Append .CreateField(nmShop(eShop.e仪表), dbText, 10)    '1.
         .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_tblBanXR", Err.Description) ', , , , PATH_Errlog)
    Err.Clear
    Resume Next 'exitSub
  End Sub

  Public Sub CreateTableDef_tblCiiXR(vDatabasePath As String, vTableName As String, IdxMk 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(vTableName)
        
         With tdfNew
        
             .Fields.Append .CreateField("Addr", dbInteger)   '1.
             .Fields.Append .CreateField("日期", dbDate)  '2.
             .Fields.Append .CreateField("开始时间", dbDate)    '3.
             .Fields.Append .CreateField("结束时间", dbDate)    '3.
             .Fields.Append .CreateField("开始值", dbDouble)    '4.
             .Fields.Append .CreateField("结束值", dbDouble)    '4.
             .Fields.Append .CreateField("合计值", dbDouble)    '4.
             .Fields.Append .CreateField("上煤码头", dbText, 10)  '4.
             .Fields("上煤码头").AllowZeroLength = True '
             
       End With
       dbsNew.TableDefs.Append tdfNew
       '建索引
       Set idfNew = tdfNew.CreateIndex(IdxMk)
       With idfNew
         .Fields.Append .CreateField("Addr", dbInteger)
         .Fields.Append .CreateField("日期", dbDate)
         .Fields.Append .CreateField("开始时间", dbDate)
         .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_tblCiiXR", Err.Description) ', , , , PATH_Errlog)
    Err.Clear
    Resume exitSub
  End Sub
  Public Sub CreateTableDef_tblRuning(vDatabasePath As String, vTableName As String, IdxMk 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(vTableName)
        
         With tdfNew
        
             .Fields.Append .CreateField("日期", dbDate)  '2.
             .Fields.Append .CreateField("Addr", dbInteger)   '1.
             .Fields.Append .CreateField("物料", dbText, 10)  '1.
             .Fields.Append .CreateField("开始时间", dbDate)    '3.
             .Fields.Append .CreateField("结束时间", dbDate)    '3.
             .Fields.Append .CreateField("开始值", dbDouble)    '4.
             .Fields.Append .CreateField("结束值", dbDouble)    '4.
       End With
       dbsNew.TableDefs.Append tdfNew
       '建索引
       Set idfNew = tdfNew.CreateIndex(IdxMk)
       With idfNew
         .Fields.Append .CreateField("日期", dbDate)
         .Fields.Append .CreateField("Addr", dbInteger)
         .Fields.Append .CreateField("开始时间", dbDate)
         .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", Err.Description) ', , , , PATH_Errlog)
    Err.Clear
    Resume exitSub
  End Sub

Public Sub CreateTableDef_Monitor(ByVal PathMdb As String, ByVal TableName As String, Optional ByVal PrimaryKey As String = "idx")

  '可以创建一个标准的数据库接口，接受灵活的表及字段输入，