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======================
paulsteigel > 06-05-16, 12:31 PM
(06-05-16, 12:27 PM)paulsteigel Đã viết: ==========================BÀI 1=================================1.Đặt vấn đề
maidinhdan > 06-05-16, 03:04 PM
hungle2006 > 07-05-16, 10:08 AM
Minh Tiên > 08-05-16, 11:14 AM
paulsteigel > 08-05-16, 12:06 PM
(08-05-16, 11:14 AM)Minh Tiên Đã viết: ....
Dim oXL As Object
Set oXL = CreateObject("Excel.Application")
Dim oXL As Object
Set oXL = GetObject(, "Excel.Application")
Dim oXL As Excel.Application
Set oXL = New Excel.Application
Function CreateWordDocument(retApp As Object) As Object
'Muc dich: Co gang thiet lap ket noi voi mot phien lam viec cua Word neu duoc. Neu khong thi tao moi
Dim wrdApp As Object
'Co gang tao ket noi
On Error Resume Next
Set wrdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
'Khong tao duoc ketnoi
Err.Clear
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
End If
' Doan code chinh...
Set retApp = wrdApp
Set CreateWordDocument = wrdApp.Documents.Add
End Function
Dim objWord As Word.Application
Set objWord = New Word.Application
With objWord
.Visible = True
.Activate
.WindowState = wdWindowStateMaximize
.Documents.Open ("c:\temp\temp.doc")
End With
paulsteigel > 08-05-16, 02:16 PM
Sub UpdateCustomer()
' Kiểm tra xem các dữ liệu có trống không
If Nz(txtHovatenKhach, "") = "" Or Nz(txtNgayTham, 0) = 0 Or Nz(txtTuoiKhach, 0) = 0 Then GoTo ExitSub
Dim rs As DAO.Recordset
Set rs = CurrentDb.OpenRecordset("Select * from tblCustomerVisit Where TenKhach='" & txtHovatenKhach & "';")
If rs.EOF Then GoTo ExitSub
With rs
.Edit
.Fields("Tuoi") = txtTuoiKhach
.Fields("NgayTham") = txtNgayTham
.Update
End With
ExitSub:
rs.Close
End Sub
Private Sub UpdateCustomer_Click()
'Kiểm tra xem các dữ liệu có trống không
If Nz(txtHovatenKhach, "") = "" Or Nz(txtNgayTham, 0) = 0 Or Nz(txtTuoiKhach, 0) = 0 Then GoTo ExitSub
Dim SqlTxt As String
SqlTxt = "UPDATE tblCustomerVisit SET Tuoi= " & txtTuoiKhach & ", NgayTham=" & txtNgayTham & " " & _
"WHERE TenKhach='" & txtHovatenKhach & "';"
CurrentDb.Execute SqlTxt
ExitSub:
End Sub
Che_Guevara > 08-05-16, 09:58 PM
paulsteigel > 09-05-16, 02:35 PM
Minh Tiên > 10-05-16, 09:30 AM
Function fUpdateDSHH()
Dim strMahang As String, sqlUp As String, rs As Recordset, rsUp As ADODB.Recordset
Set rs = CurrentDb.OpenRecordset("strTableNameTam")
If rs.RecordCount > 0 Then
rs.MoveFirst
Do Until rs.EOF
strMahang = rs!Mahang
sqlUp = "Select * from tblDanhsach_Hanghoa Where Mahang='" & strMahang & "'"
Call OpenConnect
Set rsUp = New ADODB.Recordset
rsUp.Open sqlUp, mConn, adOpenKeyset, adLockOptimistic
If rsUp.RecordCount > 0 Then
rsUp!Soluongton = rsUp!Soluongton + rs!Soluongnhap
rsUp!Dongianhap = rs!Dongianhap
rsUp!Dongiabanle = rs!Dongiabanle
rsUp!Dongiabansy = rs!Dongiabansy
...
rsUp.Update
Else
rsUp.AddNew
rsUp!Mahang = rs!Mahang
rsUp!Tenhang = rs!Tenhang
rsUp!Donvitinh = rs!Donvitinh
rsUp!Nhomhang = rs!Nhomhang
rsUp!Nganhhang = rs!Nganhhang
rsUp!Soluongton = rs!Soluongnhap
rsUp!Dongianhap = rs!Dongianhap
rsUp!Dongiabanle = rs!Dongiabanle
...
rsUp.Update
End If
rs.MoveNext
Loop
End If
rs.Close: rsUp.Close
Call CloseConnect
End Function