dbsprg.bas

一套好的餐饮行业管理软件

Attribute VB_Name = "dbsprg"
'数据后端类型，用作为连接字符串
Global Const gsMSACCESS = "Microsoft Access"
Global Const gsFOXPRO20 = "FoxPro 2.0"
Global Const gsFOXPRO25 = "FoxPro 2.5"
Global Const gsFOXPRO26 = "FoxPro 2.6"
Global Const gsFOXPRO30 = "FoxPro 3.0"
Global Const gsDBASEIII = "Dbase III"
Global Const gsDBASEIV = "Dbase IV"
Global Const gsDBASE5 = "Dbase 5.0"

Global Const gsEXCEL30 = "Excel 3.0"
Global Const gsEXCEL40 = "Excel 4.0"
Global Const gsEXCEL50 = "Excel 5.0"
Global Const gsTEXTFILES = "Text"


Global Const gnDT_NONE = -1
Global Const gnDT_MSACCESS = 0
Global Const gnDT_DBASEIV = 1
Global Const gnDT_DBASEIII = 2
Global Const gnDT_FOXPRO26 = 3
Global Const gnDT_FOXPRO25 = 4
Global Const gnDT_FOXPRO20 = 5

Global Const gnDT_PARADOX4X = 6
Global Const gnDT_PARADOX3X = 7
Global Const gnDT_BTRIEVE = 8

Global Const gnDT_EXCEL50 = 9
Global Const gnDT_EXCEL40 = 10
Global Const gnDT_EXCEL30 = 11
Global Const gnDT_TEXTFILE = 12


'Public Function CreatDB(dbname As String) As Boolean
''On Error GoTo err
'ErrCase = ""
'
'    Dim dbDatabase As Database
'    Set dbDatabase = CreateDatabase(sNewDBPathAndName, dbLangGeneral, dbEncrypt)
'    CreatDB = True
'Exit Function
'err:
'    errorHandle ErrCase
'    CreatDB = False
'End Function


'Function DBCompress(olddb As String, newdb As String)
'    'On Error GoTo CompactAccErr
'ErrCase = ""
'    Dim newdb2 As String
'    Dim nEncrypt As Integer
'
'    If Dir(newdb) <> vbNullString And olddb <> newdb Then
'        Kill newdb
'    End If
'
'    Screen.MousePointer = vbHourglass
'      '如果想覆盖同一个文件，需要创建一个新的 MDB
'      '并在压缩成功后更名
'    If olddb = newdb Then
'      newdb2 = newdb '保存新名
'      newdb = Left(newdb, Len(newdb) - 1) & "N"
'    End If
'
'    DBEngine.CompactDatabase olddb, newdb, dbLangGeneral, dbEncrypt + dbVersion30
'
'    '检查原来 mdb 的覆盖
'    If VBA.Right(newdb, 1) = "N" Then
'      Kill newdb2             '删掉旧的
'      Name newdb As newdb2 '把新的改为原来的名称
'      newdb = newdb2       '重置为正确的名称
'    End If
'
'    Screen.MousePointer = vbDefault
'
'    Exit Function
'
'CompactAccErr:
'    MousePointer = 0
'    errorHandle ErrCase
'End Function
'
''------------------------------------------------------------
''这个函数在 frmCopyStruct 窗体中从一个表向另一个表复制数据
''这里示范了事务的用法来加快这种类型的操作
''------------------------------------------------------------
'Function CopyData(FromDB As String, ToDB As String, rFromName As String, rToName As String) As Integer
'    'On Error GoTo CopyErr
' ErrCase = ""
'
'    Dim recRecordset1 As Recordset, recRecordset2 As Recordset
'    Dim rfromdb, rtodb As Database
'    Dim i As Integer
'    Dim nRC As Integer
'    Dim fld As Field
'
'    Set rfromdb = OpenDatabase(FromDB, True)
'    Set rtodb = OpenDatabase(ToDB, True)
'
'    rtodb.Execute "delete from " & rToName
'
'    '打开两个记录集
'    Set recRecordset1 = rfromdb.OpenRecordset(rFromName)
'    Set recRecordset2 = rtodb.OpenRecordset(rToName)
'
'    BeginTrans
'    While recRecordset1.EOF = False
'      recRecordset2.AddNew
'      '这个循环从每个字段向新表复制数据
'      For i = 0 To recRecordset1.Fields.Count - 1
'        Set fld = recRecordset1.Fields(i)
'        recRecordset2(fld.name).Value = fld.Value
'      Next
'      recRecordset2.Update
'      recRecordset1.MoveNext
'      nRC = nRC + 1
'      '这个测试将按每 1000 记录提交一次事务
'      If nRC = 1000 Then
'        CommitTrans
'        BeginTrans
'        nRC = 0
'      End If
'    Wend
'    CommitTrans
'
'      recRecordset1.Close
'      recRecordset2.Close
'      rfromdb.Close
'      rtodb.Close
'    CopyData = True
'    Exit Function
'
'CopyErr:
'
'    errorHandle ErrCase
'    CopyData = False
'End Function
'
''------------------------------------------------------------
''这个函数复制一个表的结构给一个新表，
''这个新表或是在同一个数据库中或是在不同的数据库中
''------------------------------------------------------------
'Function CopyStruct(FromDB As String, ToDB As String, vfromname As String, vtoname As String, bCreateIndex As Integer, fg As Integer) As Integer
'    'On Error GoTo CSErr
'ErrCase = ""
'
'    Dim i As Integer
'    Dim vfromdb, vtodb As Database
'    Dim tblTableDefObj As TableDef
'    Dim fldFieldObj As Field
'    Dim indIndexObj As Index
'    Dim tdf As TableDef
'    Dim fld, newfld As Field
'    Dim idx As Index
'
'    Set vfromdb = OpenDatabase(FromDB, True)
'    Set vtodb = OpenDatabase(ToDB, True)
'    '搜索看表是否存在
'NameSearch:
'    BeginTrans
'
'    For i = 0 To vtodb.TableDefs.Count - 1
'      Set tdf = vtodb.TableDefs(i)
'      If UCase(tdf.name) = UCase(vtoname) Then
'          If fg Then
'              vtodb.TableDefs.Delete tdf.name
'              Exit For
'          End If
'
'          If MsgBox("表已经存在，删除吗？", vbYesNo + vbQuestion) = vbYes Then
'              vtodb.TableDefs.Delete tdf.name
'          Else
'              vtoname = InputBox("输入新表名称：")
'              If Len(vtoname) = 0 Then
'                  Exit Function
'              Else
'                  GoTo NameSearch
'              End If
'          End If
'          Exit For
'      End If
'    Next
'
'    Set tblTableDefObj = vfromdb.CreateTableDef()
'
'    '必要时去掉拥有者
'    tblTableDefObj.name = StripOwner(vtoname)
'
'    '创建字段
'
'    For i = 0 To vfromdb.TableDefs(vfromname).Fields.Count - 1
'      Set fld = vfromdb.TableDefs(vfromname).Fields(i)
'      Set fldFieldObj = vfromdb.TableDefs(vfromname).CreateField(fld.name, fld.Type, fld.Size)
'      tblTableDefObj.Fields.Append fldFieldObj
'    Next
'
'    '创建索引
'    If bCreateIndex <> False Then
'
'      For i = 0 To vfromdb.TableDefs(vfromname).Indexes.Count - 1
'        Set idx = vfromdb.TableDefs(vfromname).Indexes(i)
'        Set indIndexObj = vfromdb.TableDefs(vfromname).CreateIndex(idx.name)
'        With indIndexObj
'          indIndexObj.Fields = idx.Fields
'          indIndexObj.Unique = idx.Unique
'          indIndexObj.Primary = idx.Primary
'        End With
'        tblTableDefObj.Indexes.Append indIndexObj
'      Next
'    End If
'
'    '追加新表
'    vtodb.TableDefs.Append tblTableDefObj
'
'    '设置属性
'    For i = 0 To vfromdb.TableDefs(vfromname).Fields.Count - 1
'      Set fld = vfromdb.TableDefs(vfromname).Fields(i)
'      Set newfld = vtodb.TableDefs(vtoname).Fields(i)
'      With fld
'          newfld.AllowZeroLength = .AllowZeroLength
'          newfld.Required = .Required
'      End With
'    Next
'    CommitTrans
'
'      vtodb.Close
'      vfromdb.Close
'    CopyStruct = True
'    Exit Function
'
'CSErr:
'    errorHandle ErrCase
'    CopyStruct = False
'End Function
'
''------------------------------------------------------------
'去掉 ODBC 表名的拥有者
'------------------------------------------------------------
Function StripOwner(rsTblName As String) As String

    If InStr(rsTblName, ".") > 0 Then
        rsTblName = Mid(rsTblName, InStr(rsTblName, ".") + 1, Len(rsTblName))
    End If
    StripOwner = rsTblName

End Function


'Function ModField(dbsname As String, tablename As String, _
'    vfromname As String, vtoname As String, varorder As Integer)
''On Error GoTo err
'    Dim mdbs As Database
'ErrCase = ""
'    Set mdbs = OpenDatabase(dbsname, True)
'    Dim tdftemp As TableDef
'
'    Set tdftemp = mdbs.TableDefs(Trim(tablename))
'
'    With tdftemp
'
'        If .Updatable = False Then
'            MsgBox "不能更新！ " & _
'                "此次操作没有完成。"
'            Exit Function
'        End If
'
'        .Fields(vfromname).OrdinalPosition = varorder
'        .Fields(vfromname).name = vtoname
'    End With
'
'    mdbs.Close
'    Exit Function
'err:
'    errorHandle ErrCase
'End Function
'
'
'Function AddDelField(dbsname As String, tablename As String, _
'    strCommand As String, strName As String, _
'    Optional varType, Optional varSize, Optional vorder)
'    Dim vidx As Integer
''On Error GoTo err
'ErrCase = ""
'
'    Dim mdbs As Database
'    Set mdbs = OpenDatabase(dbsname, True)
'    Dim tdftemp As TableDef
'
'    Set tdftemp = mdbs.TableDefs(Trim(tablename))
'    With tdftemp
'
'        If .Updatable = False Then
'            MsgBox "不能更新！ " & _
'                "此次操作没有完成。"
'            Exit Function
'        End If
'
'        If LCase(strCommand) = "add" Then
'            vidx = vorder
'            .Fields.Append .CreateField(strName, _
'                varType, varSize)
'
'            ModField dbsname, tablename, strName, strName, vidx
'        Else
'            If LCase(strCommand) = "del" Then
'                .Fields.Delete strName
'            End If
'        End If
'
'    End With
'    mdbs.Close
'    Exit Function
'err:
'    errorHandle ErrCase
'End Function
'
'
'Function DelAllField(dbsname As String, tablename As String)
''On Error GoTo err
'ErrCase = ""
'
'    Dim mdbs As Database
'    Set mdbs = OpenDatabase(dbsname, True)
'
'    If FindTable("工资表打印中间库", mdbs) Then
'        mdbs.Execute "drop table 工资表打印中间库;"
'    End If
'    mdbs.Execute "create table 工资表打印中间库 (a TEXT);"
'
'    mdbs.Close
'    Exit Function
'err:
'    errorHandle ErrCase
'End Function
'
'
'Function CopyTable(vfromdb As String, vtodb As String, vfromname As String, vtoname As String, bCreateIndex As Integer, fg As Integer) As Integer
'
'    If CopyStruct(vfromdb, vtodb, vfromname, vtoname, bCreateIndex, fg) And _
'        CopyData(vfromdb, vtodb, vfromname, vtoname) Then
'            CopyTable = True
'    Else
'        CopyTable = False
'    End If
'
'End Function
'
'Function FindTable(tdfname As String, dbsname As Database) As Boolean '检查一个表在库中是否存在
'  'On Error GoTo err
'  ErrCase = ""
'
'  Dim sTmp As String
'  Dim tbl As TableDef
'
'  For Each tbl In dbsname.TableDefs
'    sTmp = tbl.name
'    If sTmp = tdfname Then
'        FindTable = True
'        Exit Function
'    End If
'  Next
'
'  FindTable = False
'Exit Function
'err:
'errorHandle ErrCase
'FindTable = False
'End Function
'
''检查一个字段在表中是否存在
'Function FindField(fldname As String, tdfname As Recordset) As Boolean
''On Error GoTo err
'    Dim fld As Field
'ErrCase = ""
'    For Each fld In tdfname.Fields
'        If fld.name = fldname Then