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 đề
. Ví dụ về một lệnh SQL:maidinhdan > 06-05-16, 03:04 PM
![[Hình: sqltovba.png]](https://sites.google.com/site/congthucassecc/home/hinh-linh-tinh/sqltovba.png)
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.ApplicationFunction 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 FunctionDim objWord As Word.Application
Set objWord = New Word.Application
With objWord 
  .Visible = True
  .Activate
  .WindowState = wdWindowStateMaximize
  .Documents.Open ("c:\temp\temp.doc")
End Withpaulsteigel > 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 SubPrivate 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 SubChe_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