clsdatabase.cls

用VB实现的数据库转换工具,可以将DBF转换为Access数据库

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "ClsDatabase"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Public db As ADODB.Connection  'Access Database
Public db1 As ADODB.Connection 'Foxpro Database

Private Sub Class_Initialize()
Set db = New ADODB.Connection
db.CursorLocation = adUseClient
db.ConnectionString = "Data Source=ApoFire"

Set db1 = New ADODB.Connection
db1.ConnectionString = "Provider=MSDASQL.1;Driver=Microsoft Visual Foxpro Driver;SourceType=DBF;SourceDB=" & g_db1ConnectString 'SourceDB=E:\jp\北京Work\APOTransTool\ApoDB"
End Sub

Private Sub Class_Terminate()
If db.State = adStateOpen Then db.Close
Set db = Nothing

If db1.State = adStateOpen Then db1.Close
Set db1 = Nothing
End Sub

Public Function OpenDb() As Boolean
On Error GoTo dbError
If db.State = adStateOpen Then db.Close
db.Open
OpenDb = True
Exit Function
dbError:
OpenDb = False
MsgBox Err.Description, vbOKOnly + vbCritical, "转换工具"
End Function

Public Function CloseDb() As Boolean
On Error GoTo dbError
If db.State = adStateOpen Then db.Close
CloseDb = True
Exit Function
dbError:
CloseDb = False
MsgBox Err.Description, vbOKOnly + vbCritical, "转换工具"
End Function

Public Function OpenRecordSet(str As String, rs As ADODB.Recordset) As Long
On Error GoTo dbError
rs.Open str, db, adOpenKeyset, adLockOptimistic
OpenRecordSet = rs.RecordCount
Exit Function
dbError:
OpenRecordSet = 0
MsgBox Err.Description, vbOKOnly + vbCritical, "转换工具"
End Function

Public Sub CloseRecordSet(rs As ADODB.Recordset)
On Error GoTo dbError
rs.Close
Exit Sub
dbError:
MsgBox Err.Description, vbOKOnly + vbCritical, "转换工具"
End Sub

Public Function OpenDb1() As Boolean
On Error GoTo dbError
If db1.State = adStateOpen Then db1.Close
db1.Open
OpenDb1 = True
Exit Function
dbError:
OpenDb1 = False
MsgBox Err.Description, vbOKOnly + vbCritical, "转换工具"
End Function

Public Function CloseDb1() As Boolean
On Error GoTo dbError
If db1.State = adStateOpen Then db1.Close
CloseDb1 = True
Exit Function
dbError:
CloseDb1 = False
MsgBox Err.Description, vbOKOnly + vbCritical, "转换工具"
End Function

Public Function OpenRecordSet1(str1 As String, rs1 As ADODB.Recordset) As Long
On Error GoTo dbError
rs1.Open str1, db1, adOpenKeyset, adLockOptimistic
OpenRecordSet1 = rs1.RecordCount
Exit Function
dbError:
OpenRecordSet1 = 0
MsgBox Err.Description, vbOKOnly + vbCritical, "转换工具"
End Function

Public Sub CloseRecordSet1(rs1 As ADODB.Recordset)
On Error GoTo dbError
rs1.Close
Exit Sub
dbError:
MsgBox Err.Description, vbOKOnly + vbCritical, "转换工具"
End Sub

Public Function BackUp(Optional path As Variant) As Boolean
'Dim tmpOldDBFilePath As String
'Dim tmpPath As String
'Dim reOpen As Boolean
'On Error GoTo dbError
'tmpPath = App.path & "\Backup"
'tmpOldDBFilePath = IIf(IsMissing(path), App.path & "\GstFireSystem.mdb", path)
'If Dir(tmpPath, vbDirectory) = vbNullString Then MkDir tmpPath
'If db.State = adStateConnecting Or db.State = adStateExecuting Or db.State = adStateFetching Then GoTo dbError
'With frmMain.DlgBackup
'    .CancelError = True
'    .FileName = vbNullString
'    .InitDir = tmpPath
'    .DialogTitle = "GSTCRT数据库备份..."
'    .Filter = "Database File(*.mdb)|*.mdb"
'    .flags = FileOpenConstants.cdlOFNHideReadOnly + FileOpenConstants.cdlOFNNoChangeDir
'    .ShowSave
'    If Len(.FileName) > 0 Then
'        tmpPath = .FileName
'        If Dir(tmpPath) <> vbNullString And tmpPath <> tmpOldDBFilePath Then
'            Kill tmpPath
'        End If
'    Else
'        GoTo dbError
'    End If
'
'    db.Close
'    FileCopy tmpOldDBFilePath, tmpPath
'    MsgBox "GSTCRT数据库备份成功!", vbOKOnly + vbInformation, "转换工具"
'    If db.State = adStateClosed Then db.Open
'End With
'BackUp = True
'
'Exit Function
'dbError:
' BackUp = False
' If db.State = adStateClosed Then db.Open
' MsgBox "错误编号：" & Err.Number & "  " & "错误描述：" & Err.Description, vbOKOnly + vbExclamation, "转换工具"
End Function

Public Function Restore(Optional CurPath As Variant) As Boolean
' If MsgBox("保存当前的定义吗?", vbYesNo, "提示") = vbYes Then Exit Function
' Dim tmpCurDBFilePath As String
' Dim tmpPath As String ', tmpForm As Form
' Dim reOpen As Boolean
' Dim delPath As String
' On Error GoTo Error
' tmpPath = App.path & "\Project"
' tmpCurDBFilePath = IIf(IsMissing(CurPath), App.path & "\Project\GstFireSystem.mdb", CurPath)
' If Dir(tmpPath, vbDirectory) = vbNullString Then MkDir tmpPath
' If Dir(App.path & "\Backup", vbDirectory) = vbNullString Then MkDir App.path & "\Backup"
' If db.State = adStateConnecting Or db.State = adStateExecuting Or db.State = adStateFetching Then GoTo Error
' With frmMain.DlgColor
'     .CancelError = True
'     .FileName = vbNullString
'     .InitDir = App.path & "\Backup"
'     .DialogTitle = "restore database from..."
'     .Filter = "Database File(*.mdb)|*.mdb"
'     .Flags = FileOpenConstants.cdlOFNHideReadOnly + FileOpenConstants.cdlOFNNoChangeDir
'     .ShowOpen
'     If Len(.FileName) > 0 Then
'         tmpPath = .FileName
'     Else
'         GoTo Error
'     End If
'     db.Close
'     FileCopy tmpPath, tmpCurDBFilePath
'     If db.State = adStateClosed Then db.Open
'     MsgBox "数据库已经恢复, 请重新启动程序以使之生效!", , "试题库管理系统"
' End With
' Restore = True
' Exit Function
'Error:
' Restore = False
'' MsgBox "information:" & Err.Description, , "试题库管理系统"
' If db.State = adStateClosed Then db.Open
End Function