dbsprg.bas

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

'            FindField = True
'            Exit Function
'        End If
'    Next
'    FindField = False
'    Exit Function
'err:
'    errorHandle ErrCase
'    FindField = False
'End Function
'
''表的重新命名
'Function TableRename(dbs As Database, oldname As String, newname As String)
''On Error GoTo err
'    dbs.TableDefs(oldname).name = newname
'ErrCase = ""
'    Exit Function
'err:
'    errorHandle ErrCase
'End Function
'
''从一个表中（字段相同）将数据增加到另一个表中
'Function AppendFromTable(trst As Recordset, srst As Recordset)
''On Error Resume Next
'
'    If trst.RecordCount > 0 Then
'        trst.MoveFirst
'        Do While Not trst.EOF
'            trst.Delete
'            trst.MoveNext
'        Loop
'    End If
'
'    fn = srst.Fields.Count - 1
'    If srst.RecordCount > 0 Then
'        srst.MoveFirst
'    End If
'
'    Do While Not srst.EOF
'        trst.AddNew
'        For i = 0 To fn
'            If FindField(Trim(srst.Fields(i).name), trst) Then
'                Select Case LCase(trst.Fields(Trim(srst.Fields(i).name)).Type)
'
'                    Case "dbsingle"
'                        trst.Fields(Trim(srst.Fields(i).name)).Value = CSng(srst.Fields(Trim(srst.Fields(i).name)).Value)
'                    Case "dbtext"
'                        trst.Fields(Trim(srst.Fields(i).name)).Value = CStr(srst.Fields(Trim(srst.Fields(i).name)).Value)
'                    Case "dblong"
'                        trst.Fields(Trim(srst.Fields(i).name)).Value = CLng(srst.Fields(Trim(srst.Fields(i).name)).Value)
'                    Case "dbinteger"
'                        trst.Fields(Trim(srst.Fields(i).name)).Value = CInt(srst.Fields(Trim(srst.Fields(i).name)).Value)
'                    Case "dbdate"
'                        trst.Fields(Trim(srst.Fields(i).name)).Value = CDate(srst.Fields(Trim(srst.Fields(i).name)).Value)
'               End Select
'
'            End If
'        Next
'
'        trst.Update
'        srst.MoveNext
'    Loop
'End Function
'
'Function TypeCh2En(cty As String) As String
'
'    Select Case LCase(Trim(cty))
'        Case "文字", "text"
'            TypeCh2En = dbText
'        Case "整数", "integer"
'            TypeCh2En = dbInteger
'        Case "长整数", "long"
'            TypeCh2En = dbLong
'        Case "单精度", "single"
'            TypeCh2En = dbSingle
'        Case "双精度", "double"
'            TypeCh2En = dbDouble
'        Case "日期", "date"
'            TypeCh2En = dbDate
'    End Select
'End Function
'
'
'Function TypeEn2Ch(ety As String) As String
'
'    If IsNumeric(ety) Then
'        Select Case CInt(ety)
'            Case dbText
'                TypeEn2Ch = "文字"
'            Case dbInteger
'                TypeEn2Ch = "整数"
'            Case dbLong
'                TypeEn2Ch = "长整数"
'            Case dbSingle
'                TypeEn2Ch = "单精度"
'            Case dbDouble
'                TypeEn2Ch = "双精度"
'            Case dbDate
'                TypeEn2Ch = "日期"
'        End Select
'    Else
'        Select Case LCase(ety)
'            Case "text"
'                TypeEn2Ch = "文字"
'            Case "integer"
'                TypeEn2Ch = "整数"
'            Case "long"
'                TypeEn2Ch = "长整数"
'            Case "single"
'                TypeEn2Ch = "单精度"
'            Case "double"
'                TypeEn2Ch = "双精度"
'            Case "date"
'                TypeEn2Ch = "日期"
'            Case Else
'                TypeEn2Ch = ety
'        End Select
'    End If
'End Function
'
'
'Function TypeEn2Idx(ety As String) As Integer
'
'    Select Case LCase(Trim(ety))
'        Case "文字", "text"
'            TypeEn2Idx = 0
'        Case "整数", "integer"
'            TypeEn2Idx = 1
'        Case "长整数", "long"
'            TypeEn2Idx = 2
'        Case "单精度", "single"
'            TypeEn2Idx = 3
'        Case "双精度", "double"
'            TypeEn2Idx = 4
'        Case "日期", "date"
'            TypeEn2Idx = 5
'        Case Else
'            TypeEn2Idx = 0
'
'    End Select
'
'End Function


Private Function ChDBSType(stype As String) As Integer

    Select Case stype
        
        Case gsMSACCESS
            rt = 0
        Case gsDBASEIII
            rt = 1
        Case gsDBASEIV
            rt = 2
        
        Case gsFOXPRO20
            rt = 5
        Case gsFOXPRO25
            rt = 4
        Case gsFOXPRO26
            rt = 3
        
        Case gsEXCEL30
            rt = 11
        Case gsEXCEL40
            rt = 10
        Case gsEXCEL50
            rt = 9
            
        Case gsTEXTFILES
            rt = 12
    End Select
    ChDBSType = rt
End Function



Public Function Export(rsfromdbs As String, rsFromTbl As String, rsToDB As String, exptable As String, datatype As String, rs As String)

  'On Error GoTo ExpErr
ErrCase = ""
    Dim sConnect As String
    Dim sNewTblName As String
    Dim sDBName As String
    Dim nErrState As Integer
    Dim idxFrom As Index
    Dim idxTo As Index
    
    Dim sField As String
    Dim sFrom As String
    Dim sTmp As String
    Dim i As Integer
    Dim rsdbs As Database
    
    
    nErrState = 1
    Select Case ChDBSType(datatype)
      
        Case gnDT_MSACCESS
        
            sConnect = "[;database=" & rsToDB & "]."
            Set gExpDB = OpenDatabase(rsToDB)
      
        Case gnDT_FOXPRO26
        
            sDBName = StripFileName(rsToDB)
            sConnect = "[FoxPro 2.6;database=" & StripFileName(rsToDB) & "]."
            Set gExpDB = OpenDatabase(sDBName, 0, 0, gsFOXPRO26)
      
        Case gnDT_FOXPRO25
        
            sDBName = StripFileName(rsToDB)
            sConnect = "[FoxPro 2.5;database=" & StripFileName(rsToDB) & "]."
            Set gExpDB = OpenDatabase(sDBName, 0, 0, gsFOXPRO25)
      
        Case gnDT_FOXPRO20
      
            sDBName = StripFileName(rsToDB)
            sConnect = "[FoxPro 2.0;database=" & StripFileName(rsToDB) & "]."
            Set gExpDB = OpenDatabase(sDBName, 0, 0, gsFOXPRO20)
      
        Case gnDT_EXCEL50, gnDT_EXCEL40, gnDT_EXCEL30
        
            sConnect = "[Excel 5.0;database=" & rsToDB & "]."
            Set gExpDB = OpenDatabase(rsToDB, 0, 0, gsEXCEL50)
      
        Case gnDT_TEXTFILE
        
            sDBName = StripFileName(rsToDB)
            sConnect = "[Text;database=" & StripFileName(rsToDB) & "]."
            Set gExpDB = OpenDatabase(sDBName, 0, 0, gsTEXTFILES)
    
    End Select
    
    If datatype = gsMSACCESS Or datatype = gsEXCEL50 Or _
       datatype = gsEXCEL40 Or datatype = gsEXCEL30 Then
             
        If Len(exptable) = 0 Then
            Exit Function
        Else
            sNewTblName = exptable
        End If
    Else
      
      '得到文件名的表部分
      '去掉路径
        For i = Len(rsToDB) To 1 Step -1
        
            If Mid(rsToDB, i, 1) = "\" Then
                Exit For
            End If
        Next
        sTmp = Mid(rsToDB, i + 1, Len(rsToDB))
      
        '去掉扩展名
        For i = 1 To Len(sTmp)
            If Mid(sTmp, i, 1) = "." Then
                Exit For
            End If
        Next
        sNewTblName = Left(sTmp, i - 1)
    End If
    
    Screen.MousePointer = vbHourglass
    
    If Len(rsFromTbl) > 0 Then
        Set rsdbs = OpenDatabase(rsfromdbs, True)
        tmp = rs
        pos = InStr(tmp, "from")
        tmp = Left(tmp, pos - 1)
        
        rsdbs.Execute "select * into " & sConnect & StripOwner(sNewTblName) & " from " & StripOwner(rsFromTbl)
    
        If datatype <> gsTEXTFILES Then
      
            nErrState = 2
            'MsgBar MSG59 & " '" & sNewTblName & "'", True
            gExpDB.TableDefs.Refresh
        
            For Each idxFrom In rsdbs.TableDefs(rsFromTbl).Indexes
                Set idxTo = gExpDB.TableDefs(sNewTblName).CreateIndex(idxFrom.Name)
                With idxTo
                    .Fields = idxFrom.Fields
                    .Unique = idxFrom.Unique
                End With
                gExpDB.TableDefs(sNewTblName).Indexes.Append idxTo
            Next
        End If
        Screen.MousePointer = 0
      
      'MsgBox MSG60 & " '" & rsFromTbl & "'", 64
    End If
    
    dataout.Lts.Visible = True
    Exit Function
    
ExpErr:
    
    If err = 3010 Then      '表存在
        If MsgBox("表已经存在，覆盖吗？", 32 + 1 + 256) = 1 Then
            gExpDB.TableDefs.Delete sNewTblName
            Resume
        Else
            Screen.MousePointer = vbDefault
            'MsgBar vbNullString, False
            Exit Function
        End If
    End If
    
    '如果不能创建索引，删除新表
    If nErrState = 2 Then
        gExpDB.TableDefs.Delete sNewTblName
    End If
    MousePointer = 0
    ErrorHandle ErrCase
End Function

Public Sub ADO_Export()
Dim Cn As New ADODB.Connection

    Cn.ConnectionString = Cnstr
    Cn.Open

    Dim rsToDB As String
    Dim rsFromTbl As String
    Dim sNewTblName As String
    
    rsFromTbl = "tb_card"
    rsToDB = "G:\suncard\tmp.txt"
    sConnect = "[Text;database=" & StripFileName(rsToDB) & "]."
    
    '得到文件名的表部分
    '去掉路径
    For i = Len(rsToDB) To 1 Step -1
    
        If Mid(rsToDB, i, 1) = "\" Then
            Exit For
        End If
    Next
    sTmp = Mid(rsToDB, i + 1, Len(rsToDB))
    
    '去掉扩展名
    For i = 1 To Len(sTmp)
        If Mid(sTmp, i, 1) = "." Then
            Exit For
        End If
    Next
    sNewTblName = Left(sTmp, i - 1)

'    Kill rsToDB
    
'    Cn.Execute "select * into " & sConnect & StripOwner(sNewTblName) & " from " & StripOwner(rsFromTbl)
    Cn.Close
    
End Sub



Public Sub ADO_OpenConn(Cn As ADODB.Connection, DataSource As String)
    Cn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & DataSource & ";Persist Security Info=False"       '指定连接字符串
    Cn.Open
End Sub

Public Sub ADO_OpenRecordset(Cn As ADODB.Connection, cmd As ADODB.Command, sqlstr As String, rst As ADODB.Recordset)
    
    With cmd
        .ActiveConnection = Cn
        .CommandType = adCmdText               '有四种可选择的类型
        .CommandText = sqlstr           '存储过程名称
    End With
    
    With rst
        .CursorLocation = adUseClient
        .CursorType = adOpenDynamic
        .Open cmd
    End With

End Sub