paulsteigel > 06-05-16, 12:27 PM
Option Explicit
' Duong dan den csdl
Private dbPath As String
' Doi tuong de ket noi voi CSDL
Private dbObject As Object
' Const for ADODB
Private Const Jet10 = 1
Private Const Jet11 = 2
Private Const Jet20 = 3
Private Const Jet3x = 4
Private Const Jet4x = 5
' Const for DAO
Private Const dbVersion10 = 1
Private Const dbVersion11 = 8
Private Const dbVersion20 = 16
Private Const dbVersion30 = 32
Private Const dbVersion40 = 64
' Cach thuc ket noi
Private ConnectByADODB As Boolean
Sub LoadForm()
' Mo form ra nao
frmSearch.Show vbModal
End Sub
Sub CreateDb()
' Khoi tao CSDL Access
dbPath = ThisWorkbook.Path & "\Data.mdb"
' Kiem tra xem CSDL da co khong, neu co thi xoa di
If FileOrDirExists(dbPath, True) Then Kill dbPath
'Tao CSDL phien ban Access 2000 (ho tro Unicode)
If Range("dbType") = "DAO" Then
' Dung DAO
CreateDbDAO dbPath
Else
' Dung ADO
CreateDbAdo dbPath
End If
' Khoi tao cac bang so lieu
CreateTable
' Them so lieu vao cac bang
AddData2Table
' Dong CSDL
dbObject.Close
End Sub
' Them so lieu tu Excel vao cac bang trong CSDL
Private Sub AddData2Table()
' Tien hanh nap du lieu bang Ma canbo
Dim dbRange As Range, ptrCell As Range, SqlTxt As String
Set dbRange = Range("tblCanbo")
Set ptrCell = dbRange.Cells(1)
While ptrCell <> ""
SqlTxt = "INSERT INTO tblCanbo(fldMaCanbo, fldMaDiaban) VALUES('" & ptrCell & "','" & ptrCell.Offset(0, 1) & "');"
Call ExcuteSQL(SqlTxt)
Set ptrCell = ptrCell.Offset(1)
Wend
' Tao bang dia ban
Set dbRange = Range("tblDiaban")
Set ptrCell = dbRange.Cells(1)
While ptrCell <> ""
SqlTxt = "INSERT INTO tblDiaban(fldMaDiaban, fldTenDiaban, fldDoi) VALUES('" & ptrCell & "','" & ptrCell.Offset(0, 1) & "'," & ptrCell.Offset(0, 2) & ");"
Call ExcuteSQL(SqlTxt)
Set ptrCell = ptrCell.Offset(1)
Wend
' Xoa cac bien khoi bo nho
Set dbRange = Nothing
Set ptrCell = Nothing
End Sub
'======================================
' Phan chen so lieu vao bang thi giong
' nhau giua DAO va ADODB
'-------------TAO BANG CSDL-------------
' Nhom cac thu tuc lam viec voi ADODB
Private Sub CreateTable()
Dim SqlTxt As String
SqlTxt = "Create Table tblCanbo(fldMaCanbo Text(20), fldMaDiaban Text(20));"
Call ExcuteSQL(SqlTxt)
SqlTxt = "Create Table tblDiaban(fldMaDiaban Text(20), fldTenDiaban Text(255), fldDoi Long);"
Call ExcuteSQL(SqlTxt)
End Sub
Private Function ExcuteSQL(SqlStr As String) As Boolean
On Error GoTo ErrHandler
dbObject.Execute SqlStr
ExcuteSQL = True
ErrHandler:
End Function
'================END======================
'======================================
' Nhom cac thu tuc lam viec voi ADODB
Private Sub CreateDbAdo(FileName As String, Optional Format As Long = Jet4x)
Dim Catalog As Object
' Khoi tao mot phien lam viec voi ADO
Set Catalog = CreateObject("ADOX.Catalog")
' Tao csdl dang Access 2000
Catalog.Create "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Jet OLEDB:Engine Type=" & Format & ";Data Source=" & FileName
Set Catalog = Nothing
Set dbObject = CreateObject("ADODB.Connection")
' Mo CSDL
dbObject.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & FileName & ";"
End Sub
'================END======================
'======================================
' Nhom cac thu tuc lam viec voi DAO
Sub CreateDbDAO(FileName As String, Optional Format As Long = dbVersion40)
Dim Engine As Object
Set Engine = CreateObject("DAO.DBEngine.36")
Engine.CreateDatabase FileName, ";LANGID=0x0409;CP=1252;COUNTRY=0", Format
' Mo CSDL
Set dbObject = Engine.Workspaces(0).OpenDatabase(FileName)
End Sub
'================END======================
'======================================
' Khoi tao ket noi voi CSDL
Property Get ConnectDatabase(dpPath As String, Optional ConnectAsADODB As Boolean = True) As Object
Dim dbs As Object
On Error GoTo ErrHandler
If ConnectAsADODB Then
Set dbs = CreateObject("ADODB.Connection")
dbs.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dpPath & ";"
Set ConnectDatabase = dbs
Else
Set dbs = CreateObject("DAO.DBEngine.36")
Set ConnectDatabase = dbs.Workspaces(0).OpenDatabase(dpPath)
End If
ConnectByADODB = ConnectAsADODB
ErrHandler:
End Property
' Khoi tao ket noi voi recordset -
' tuy thuoc vao kieu ket noi nhe
Property Get GetRecordset(dbObj As Object, SqlText As String) As Object
On Error GoTo ErrHandler
If ConnectByADODB Then
' Voi ADODB, Like '*abc*' phai la '%abc%' nhe
Set GetRecordset = CreateObject("ADODB.Recordset")
GetRecordset.Open Replace(SqlText, "*", "%"), dbObj
Else
' Voi DAO, Like '*abc*' de tim kiem
Set GetRecordset = dbObj.Openrecordset(SqlText)
End If
Debug.Print GetRecordset.EOF
ErrHandler:
End Property
'================END======================
'======================================
' Nhom cac thu tuc lam viec voi Thu muc
Function FileOrDirExists(PathName As String, Optional FileObject As Boolean = False) As Boolean
'Kiem tra xem file hoac folder co ton tai hay khong?
Dim Fso As Object
Dim FilePath As String, lRet As Boolean
Set Fso = CreateObject("Scripting.FileSystemObject")
If PathName = "" Then Exit Function
If FileObject Then
FileOrDirExists = Fso.FileExists(PathName)
Else
FileOrDirExists = Fso.FolderExists(PathName)
End If
Set Fso = Nothing
End Function
'================END======================