Xây dựng một ứng dụng kết hợp

[lethanhnhan]

Thể theo yêu cầu

Chào các bạn,
Thật sự đây là bài tóan không phải dễ đối với các bạn mới chập chững bước vào. Nhưng theo tôi nghĩ nếu các bạn từng bước theo hướng dẫn của tôi, các bạn sẽ làm được thôi.
Theo yêu cầu tôi gởi lên file để theo dõi số lượng tồn kho.

Thân,

Lê Thanh Nhân

 

[lethanhnhan]

Từng bước xây dựng chương trình

Chào các bạn,
Chúng ta hãy bắt đầu từng bước xây dựng chương trình.
Để xây dựng chương trình các bạn cần có kiến thức về ADO và cách sử dụng control MSHFLXGD.OCX.
Hơi khó phải không các bạn? Về ADO các bạn có thể xem bài viết tại www.levanduyetexcel.netfirms.com
Còn về việc sử dụng MSHFLXGD.OCX tôi nghỉ trong chương trình chúng ta sẽ hiểu thôi !
Trong File Stock_Check.xls chúng ta có 2 worksheet:
_STOCK_CHECK
_STOCK_FIG
Trong worksheet STOCK_CHECK chúng ta chỉ để 2 nút lệnh: Kiểm tồn kho và Cập nhật.
Mục đích của nút cập nhật là để đưa dữ liệu từ bên ngòai (Excel) vào database (*.mdb). Khi các bạn click vào nút Cập nhật một form sẽ hiện ra giúp các bạn chọn workbook, và worksheet có chứa dữ liệu các bạn cần "đẩy" vào database.

Chúng ta sẽ có hai checkbox:
ckbHearderChecking và ckbDeleteBeforeImport
ckbHearderChecking: nhằm kiểm tra xem tiêu đề của dữ liệu cần đưa vào Database có theo như định dạng yêu cầu không? Chú ý với mỗi ứng dụng bạn phải viết lại hàm:

Function CheckReqWorkbookName() As Boolean
'This function will check the data format in the
'sTenWorkbookThaoTac, tai sheet sTenWorksheetThaoTac
'Neu dung thi tra ve True
Dim arrMangColHeader As Variant
Dim i As Long, sHeader As String
    On Error GoTo CheckReqWorkbookName_Error
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
    arrMangColHeader = Array("Material", "Material Description", "Plnt", "SLoc", _
                             "SL", "BUn", "Unrestr.", "Trans./Tfr", "Qual.Insp.", _
                             "Restricted", "Blocked", "Returns")
    'Check the sTenWorkbookThaoTac and sTenWorksheetThaoTac
    If Trim(sTenWorkbookThaoTac) = "" Or Trim(sTenWorksheetThaoTac) = "" Then
        CheckReqWorkbookName = False
        Exit Function
    End If

    'Check the format of the data in the ActiveWorkbook
    For i = 0 To UBound(arrMangColHeader)
        sHeader = Trim(Application.Workbooks(sTenWorkbookThaoTac).Worksheets(sTenWorksheetThaoTac).Range("B2").Offset(0, i))
        If sHeader <> arrMangColHeader(i) Then
            CheckReqWorkbookName = False
            Exit Function
        End If
    Next i
    CheckReqWorkbookName = True

ErrorExit:
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
    Exit Function

CheckReqWorkbookName_Error:
    If bCentralErrorHandler("frmInputData", "CheckReqWorkbookName", , False) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If
End Function

arrMangColHeader : mảng chứa các tiêu đề của các cột.
Application.Workbooks(sTenWorkbookThaoTac).Worksheets(sTenWorksheetThaoTac).Range("B2").Offset(0,
i)
Các bạn chú ý rằng chương trình sẽ bắt đầu tại B2. Tùy theo dữ liệu của bạn mà các bạn sửa lại đọan code trong chương trình của mình.
Tại cột B, chương trình sẽ quét cho tới khi không có giá trị trong cột này.
Nếu các bạn đã đọc qua các đọan code ở trên, chắc chắn các bạn sẽ hỏi tại sao thường có đọan code sau:

If bCentralErrorHandler("frmInputData", "CheckReqWorkbookName", , [B]False[/B]) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If

Mục đích của đọan code này là không cho xuất hiện báo lỗi. Khi có lỗi xãy ra, chương trình sẽ ghi ra một file text cùng thư mục với file chứa đọan code này. Tôi đã giới thiệu hàm này trong phần đầu bài viết.
Như vậy khi các bạn cung cấp file cho người dùng, người dùng sẽ bớt chán nãn khi xuất hiện nhiều thông báo lỗi.
Các bạn chú ý, nếu trong quá trình test thì tôi sẽ đặt thông số

bCentralErrorHandler("frmInputData", "CheckReqWorkbookName", , True)

Như vậy ngòai việc ghi lỗi ra file, nó cũng sẽ hiện thông báo cho tôi biết.

Thực chất, sau khi các bạn đã test hết rồi thì các bạn mới đặt lại thông số là False và cung cấp cho khách hàng.

Lê Thanh Nhân

 

[lethanhnhan]

Trong thủ tục sự kiện UserForm_Initialze()
Chúng ta thêm vào cboChoseWB tên các workbook hiện đang mở. Điều này có nghĩa là bạn chỉ có thể nhập dữ liệu vào từ các Workbook đang mở.

  Private Sub UserForm_Initialize()
  Dim iSoLuongWB As Integer
  Dim i As Integer
      On Error Resume Next
      iSoLuongWB = Application.Workbooks.Count
      For i = 1 To iSoLuongWB
          cboChoseWB.AddItem Application.Workbooks(i).Name
      Next i
      cboChoseWB.ListIndex = 0
      ckbHearderChecking.Value = 1
  End Sub

Sau đó dựa vào sự kiện Change của cboChoseWB để thêm vào tên các Worksheet của Workbook được chọn ở trên.

  Private Sub cboChoseWB_Change()
  Dim iSoLuongWS As Integer
  Dim i As Integer
  Dim sTenWB As String
      On Error Resume Next
      cboChoseWS.Clear
      sTenWB = cboChoseWB.Text
      iSoLuongWS = Workbooks(sTenWB).Worksheets.Count
      For i = 1 To iSoLuongWS
          cboChoseWS.AddItem Workbooks(sTenWB).Worksheets(i).Name
      Next i
      cboChoseWS.ListIndex = 0
  End Sub

Cuối cùng dựa vào sự kiện Change của cboChoseWS để xác định hai biến
sTenWorkbookThaoTac
sTenWorksheetThaoTac

  Private Sub cboChoseWS_Change()
      If cboChoseWS <> -1 Then
          sTenWorkbookThaoTac = cboChoseWB.Text
          sTenWorksheetThaoTac = cboChoseWS.Text
      End If
  End Sub

Và bây giờ chúng ta đi vào phân tích thủ tục chính khi click vào nút cmdImportData

  Private Sub cmdImportData_Click()
  'Delete the data before import
      On Error GoTo cmdImportData_Click_Error
      With Application
          .Calculation = xlCalculationManual
          .ScreenUpdating = False
          .DisplayAlerts = False
      End With
      sTenWorkbookThaoTac = Me.cboChoseWB.Text
      sTenWorksheetThaoTac = Me.cboChoseWS.Text
      sTableInDBName = "tbStock"
      If ckbHearderChecking Then
          If Not CheckReqWorkbookName Then
              MsgBox "Khong dung nhu format yeu cau!" & vbCrLf & _
                     "This is not the requirement's format!" & vbCrLf & _
                     "Pls, check.", vbOKOnly, "Inf"
              Exit Sub
          End If
      End If
      If ckbDeleteBeforeImport Then
          Call DeleteAll("tbStock")
      End If
      'If the format correct then action
      If gcnAccess.State = ObjectStateEnum.adStateClosed Then
          Call ConnectToDatabase
      End If
      If bConnected Then
          Call ADOFromExcelToAccess
      End If
      MsgBox "You have finished importing the data!", vbOKOnly, "Notice"
   
  ErrorExit:
      With Application
          .Calculation = xlCalculationManual
          .ScreenUpdating = True
          .DisplayAlerts = True
      End With
      Exit Sub
   
  cmdImportData_Click_Error:
      If bCentralErrorHandler("frmInputData", "cmdImportData_Click", , False) Then
          Stop
          Resume
      Else
          Resume ErrorExit
      End If
  End Sub

Dựa vào sự lựa chọn của người dùng chúng ta gán giá trị cho hai biến

  sTenWorkbookThaoTac = Me.cboChoseWB.Text
  sTenWorksheetThaoTac = Me.cboChoseWS.Text

Thực sự ra chúng ta không cần thực hiện lệnh gán này vì ở thủ tục sự kiện cbochoseWS_Change.
Sau đó dựa vào sự lựa chọn của người dùng khi click vào checkbox ckbHeaderChecking mà chúng ta kiểm tra xem các Header của các cột dữ liệu chúng ta muốn nhập vào có đúng hay không? Nếu không đúng thì thông báo và thoát.
Sau đó dựa vào việc chọn lựa của người dùng với checkbox ckbDeleteBeforeImport mà quyết định xóa dữ liệu trước khi nhập vào. Thủ tục xóa dữ liệu của bảng tbStock như sau: DeleteAll("tbStock")

  Sub DeleteAll(ByVal sTableName As String)
  Dim rsData As ADODB.Recordset
  Dim cmAccess As ADODB.Command
  Dim sSQL As String
  Dim lAffected As Long
      On Error GoTo DeleteAll_Error
      With Application
          .Calculation = xlCalculationManual
          .ScreenUpdating = False
      End With
      'If the format correct then action
      If gcnAccess.State = ObjectStateEnum.adStateClosed Then
          Call ConnectToDatabase
      End If
      Set rsData = New ADODB.Recordset
      If gcnAccess.State = ObjectStateEnum.adStateClosed Then
          'Chi thuc hien khi da ket noi voi co so du lieu
          gcnAccess.Open
          sSQL = " DELETE FROM " & sTableName & ";"
          'Create and execute the Command Object
          Set cmAccess = New ADODB.Command
          cmAccess.ActiveConnection = gcnAccess
          cmAccess.CommandText = sSQL
          cmAccess.CommandType = adCmdText
          cmAccess.Execute lAffected, , adExecuteNoRecords
      End If
  ErrorExit:
      Set rsData = Nothing
      If gcnAccess.State = ObjectStateEnum.adStateOpen Then
          gcnAccess.Close
          bConnected = False
      End If
      With Application
          .Calculation = xlCalculationManual
          .ScreenUpdating = True
      End With
      Exit Sub
   
  DeleteAll_Error:
      If bCentralErrorHandler("MainModule", "DeleteAll", , False) Then
          Stop
          Resume
      Else
          Resume ErrorExit
      End If
  End Sub

Các bạn để ý rằng trong tất cả các thủ tục có xử lý số liệu trong các bảng Access, chúng ta thường có thủ tục ConnectToDatabase.
Các bạn chú ý trong Module PubConst chúng ta có khai báo
Option Explicit
'Declare the Public variance
Public gcnAccess As New ADODB.Connection 'Global connection Access
Biến này kiểu ADODB.Connection, nhằm kết nối với cơ sở dữ liệu. Kiểu Connection các bạn có thể hiểu “nôm na” như sau: Kiểu connection giống như khi các bạn nhấc máy điện thoại lên gọi đến số máy khác. Khi kết nối không được các bạn không thể trò chuyện với người ở máy bên kia. Tương tự đối với biến kiểu Connection. Một khi kết nối được thì bạn hãy nói đến chuyện thao tác với cơ sở dữ liệu. Sau khi kết nối thành công thì đặt biến bConnected = True

Public Sub ConnectToDatabase()
  Const msMODULE As String = "MainMod"            'Module name
  Const sSOURCE As String = "ConnectToDatabase"            ' Sub name
  Dim sConnect As String
  Dim lAttempt As Long
  Dim sSQL As String
      On Error GoTo ErrorHandler
      With Application
          .Calculation = xlCalculationManual
          .ScreenUpdating = False
          .DisplayAlerts = False
      End With
      'Check if the connection has creased then exit sub
      If gcnAccess.State = ObjectStateEnum.adStateOpen Then
          MsgBox "The connection has creased!", vbOKOnly, "Notice"
          GoTo ErrorExit
      End If
      'Create the SConnect Path
      sConnect = "DSN=WareHouseDB;UID=admin;PWD=;"
      With gcnAccess
          .Mode = adModeReadWrite
          .ConnectionTimeout = 100
          .CursorLocation = adUseClient
          .ConnectionString = sConnect
          .Open
      End With
      bConnected = True
      'Close the connection to enable connection pooling
      If gcnAccess.State = ObjectStateEnum.adStateOpen Then gcnAccess.Close
  ErrorExit:
      With Application
          .Calculation = xlCalculationManual
          .ScreenUpdating = True
          .DisplayAlerts = True
      End With
      Exit Sub
   
  ErrorHandler:
   
      'We will try to make the connection 3 times before bailing out
     ‘Cố gắng kết nối với cơ sở dữ liệu 3 lần trước khi kết thúc
      If lAttempt < 3 And gcnAccess.Errors.Count > 0 Then
          If gcnAccess.Errors(0).NativeError = 17 Then
              lAttempt = lAttempt + 1
              Resume
          End If
      End If
      If bCentralErrorHandler(msMODULE, sSOURCE, , False) Then
          Stop
          Resume
      Else
          Resume ErrorExit
      End If
  End Sub

Đây có thể nói là thủ tục cơ bản khi bạn kết nối đến các cơ sở dữ liệu khác. Khi muốn kết nối với cơ sở dữ liệu khác bạn chỉ cần thay biến

sConnect = "DSN=WareHouseDB;UID=admin;PWD=;"

Bạn tham khảo bài viết về Connection trong Topic khác.
Sau khi kiểm tra kết nối, và kết nôi với cơ sở dữ liệu chúng ta đến thủ tục chính. Thủ tục này nhằm đưa dữ liệu vào bảng của Access.
sTableInDBName: tên bảng dữ liệu bạn cần để nhập dữ liệu vào.

Application.Workbooks(sTenWorkbookThaoTac).Worksheets(sTenWorksheetThaoTac).Range("B" & r).Formula

Chúng ta dựa vào dữ liệu của cột B để quyết định nhập liệu tiếp hay không.

.Fields("MaterialNumber") = Application.Workbooks(sTenWorkbookThaoTac).Worksheets(sTenWorksheetThaoTac).Range("B" & r).Value

Câu lệnh trên có nghĩa là giá trị dữ liệu của trường MaterialNumber sẽ bằng giá trị tại ô Range("B" & r).Value
Tương tự cho các trường khác.


Le Thanh Nhan

 

[lethanhnhan]

  Sub ADOFromExcelToAccess()
  ' exports data from the active worksheet to a table in an Access database
  ' this procedure must be edited before use
  Dim rs As ADODB.Recordset, r As Long
  Dim dteDate As Date
  Dim ItemCode As String
      On Error GoTo ADOFromExcelToAccess_Error
      With Application
          .Calculation = xlCalculationManual
          .ScreenUpdating = False
          .DisplayAlerts = False
      End With
      If gcnAccess.State = ObjectStateEnum.adStateClosed Then
          Call ConnectToDatabase
          If gcnAccess.State = ObjectStateEnum.adStateClosed Then
              gcnAccess.Open
          End If
          Set rs = New ADODB.Recordset
          rs.Open sTableInDBName, gcnAccess, adOpenKeyset, adLockOptimistic, adCmdTable
          ' all records in a table
          r = 4    ' the start row in the worksheet
          Do While Len(Application.Workbooks(sTenWorkbookThaoTac).Worksheets(sTenWorksheetThaoTac).Range("B" & r).Formula) > 0
              ' repeat until first empty cell in column B
              With rs
                  .AddNew    ' create a new record
                  ' add values to each field in the record
                  .Fields("MaterialNumber") = Application.Workbooks(sTenWorkbookThaoTac).Worksheets(sTenWorksheetThaoTac).Range("B" & r).Value
                  .Fields("Descriptions") = Application.Workbooks(sTenWorkbookThaoTac).Worksheets(sTenWorksheetThaoTac).Range("C" & r).Value
                  .Fields("Plnt") = Application.Workbooks(sTenWorkbookThaoTac).Worksheets(sTenWorksheetThaoTac).Range("D" & r).Value
                  .Fields("SLoc").Value = Application.Workbooks(sTenWorkbookThaoTac).Worksheets(sTenWorksheetThaoTac).Range("E" & r).Value
                  .Fields("UoM").Value = Application.Workbooks(sTenWorkbookThaoTac).Worksheets(sTenWorksheetThaoTac).Range("G" & r).Value
                  .Fields("UnrestQty").Value = Application.Workbooks(sTenWorkbookThaoTac).Worksheets(sTenWorksheetThaoTac).Range("H" & r).Value
                  .Fields("TransQty").Value = Application.Workbooks(sTenWorkbookThaoTac).Worksheets(sTenWorksheetThaoTac).Range("I" & r).Value
                  .Fields("QIQty").Value = Application.Workbooks(sTenWorkbookThaoTac).Worksheets(sTenWorksheetThaoTac).Range("J" & r).Value
                  .Fields("RestrictedQty").Value = Application.Workbooks(sTenWorkbookThaoTac).Worksheets(sTenWorksheetThaoTac).Range("K" & r).Value
                  .Fields("BlockedQty").Value = Application.Workbooks(sTenWorkbookThaoTac).Worksheets(sTenWorksheetThaoTac).Range("L" & r).Value
                  .Fields("ReturnsQty").Value = Application.Workbooks(sTenWorkbookThaoTac).Worksheets(sTenWorksheetThaoTac).Range("M" & r).Value
                  ' add more fields if necessary...
                  .Update    ' stores the new record
              End With
              r = r + 1    ' next row
          Loop
          rs.Close
      End If
  ErrorExit:
      With Application
          .Calculation = xlCalculationManual
          .ScreenUpdating = True
          .DisplayAlerts = True
      End With
      Exit Sub
   
  ADOFromExcelToAccess_Error:
      If bCentralErrorHandler("frmInputData", "ADOFromExcelToAccess", , False) Then
          Stop
          Resume
      Else
          Resume ErrorExit
      End If
  End Sub

Như vậy chúng ta đã hoàn thành phần cơ bản ĐƯA DỮ LIỆU TỪ BÊN NGOÀI VÀO BẢNG TRONG ACCESS.

Bây giờ chúng ta qua phần THỂ HIỆN DỮ LIỆU TỪ CƠ SỞ DỮ LIỆU
Phần này tương đối “dễ nuốt” hơn phần trên. Các bạn nên đọc phần SQL cơ bản trong trang web www.levanduyetexcel.netfirms.com
Nguyên lý của form frmQuery như sau:
Khi mở form lên, chúng ta sẽ kiểm tra kết nối và kết nối với cơ sở dữ liệu. Nếu kết nối không được thì thoát. Nếu kết nối được chúng ta sẽ dùng câu lệnh SQL để lấy dữ liệu về thông qua recordset rsData. Recordset này được khai báo tại module PubConst, hoặc bạn cũng có thể khai báo trên cùng của đoạn mã trong frmQuery như sau:

Dim rsData As New ADODB.Recordset

Câu lệnh quan trọng ở đây là

rsData.CursorLocation = adUseClient

Với câu lệnh này, chúng ta dễ dàng lọc, sắp xếp dữ liệu tại client. Đây là kỹ thuật chính của form này.
Cuối cùng bạn gán thuộc tính DataSource của MSHFlexGridDB cho rsData.

Me.MSHFlexGridDB.DataSource = rsData

Đoạn mã của sự kiện Initialize của frmQuery như sau:

  Private Sub UserForm_Initialize()
  Dim rsDataCount As Long
  Dim sSQL As String, i As Long, lLen As Long
  Dim sngQty As Single
      On Error GoTo UserForm_Initialize_Error
      With Application
          .Calculation = xlCalculationManual
          .ScreenUpdating = False
          .DisplayAlerts = False
      End With
      If gcnAccess.State = ObjectStateEnum.adStateClosed Then
          Call ConnectToDatabase
      End If
      If bConnected = False Then
          MsgBox "Khong the ket noi voi Co so du lieu!" & vbCrLf & _
                 "Xin ban kiem tra lai!", vbOKOnly, "Thong bao"
          End
      End If
      If gcnAccess.State = ObjectStateEnum.adStateClosed Then
          gcnAccess.Open
          With Me.cbbSL
              .AddItem "R001"
              .AddItem "P001"
              .ListIndex = 0
          End With
  [COLOR=red]        sSQL = "SELECT * " & _[/COLOR]
  [COLOR=red]               "FROM tbStock " & _[/COLOR]
  [COLOR=red]               "ORDER BY Descriptions ; "[/COLOR]
          'When we set this property to adUseClient
          'So you can Sort at the Client
          With rsData
              .CursorLocation = adUseClient
              .Open sSQL, gcnAccess, adOpenKeyset, adLockOptimistic
              rsDataCount = .RecordCount
          End With
          If rsDataCount > 0 Then
              With Me.MSHFlexGridDB
                  Set .DataSource = rsData
                  'Let the user resize the size of the Grid
                  .AllowUserResizing = 3
                  'Adjust the column width
                  .ColWidth(0) = 0
                  .ColWidth(1) = 1500    'MaterialNumber
                  .ColWidth(2) = 5000    'Description
                  .ColWidth(3) = 500    'Plnt
                  .ColWidth(4) = 500    'SLoc
                  .ColWidth(5) = 500    'UoM
                  'Set the Grid
                  .Gridlines = flexGridInset
                  .BackColor = &H80FFFF
              End With
              'Update the value
              Do Until rsData.EOF
                  sngQty = sngQty + Val(rsData.Fields("UnrestQty").Value)
                  rsData.MoveNext
              Loop
              txtTotal.Text = Format(sngQty, "##,##0.00") & "/" & rsDataCount
          Else
              txtTotal.Text = Format(0, "##,##0.00")
          End If
   
      End If
      'Pls take note that,
      'If you close the connection here, then you can not refresh the
      'Recordset when you want to sort or do something.
  ErrorExit:
      With Application
          .Calculation = xlCalculationManual
          .ScreenUpdating = True
          .DisplayAlerts = True
      End With
      Exit Sub
   
  UserForm_Initialize_Error:
      If bCentralErrorHandler("frmQuery", "UserForm_Initialize", , True) Then
          Stop
          Resume
      Else
          Resume ErrorExit
      End If
  End Sub

Le Thanh Nhan

 

[lethanhnhan]

Tôi nghĩ thủ thuật thứ hai các bạn cần quan tâm ở thủ tục Private Sub txtFilter_Change()

Private Sub txtFilter_Change()
  Dim iPos1 As Long, iPos2 As Long, iPos3 As Long
  Dim sCompare1 As String, sCompare2 As String
  Dim sCompare3 As String, sCompare4 As String
  Dim sFilter As String
  Dim lRecordCount As Long, sngQty As Single
      On Error GoTo txtFilter_Change_Error
      With Application
          .Calculation = xlCalculationManual
          .ScreenUpdating = False
          .DisplayAlerts = False
      End With
      If txtFilter.Text <> "" Then
          'Define the filter criteria
          iPos1 = InStr(1, txtFilter.Text, "*")
          If iPos1 > 0 Then
              iPos2 = InStr(iPos1 + 1, txtFilter.Text, "*")
          End If
          If iPos1 > 0 And iPos2 > 0 Then
              iPos3 = InStr(iPos2 + 1, txtFilter.Text, "*")
          End If
          'Suppose limit of the search criteria is 4
          If iPos1 > 0 And iPos2 > 0 And iPos3 > 0 Then
              sCompare1 = Mid(txtFilter.Text, 1, iPos1 - 1): sCompare1 = Trim(sCompare1)
              sCompare2 = Mid(txtFilter.Text, iPos1 + 1, iPos2 - iPos1 - 1): sCompare2 = Trim(sCompare2)
              sCompare3 = Mid(txtFilter.Text, iPos2 + 1, iPos3 - iPos2 - 1): sCompare3 = Trim(sCompare3)
              If Len(txtFilter.Text) > iPos3 Then
                  sCompare4 = Mid(txtFilter.Text, iPos3 + 1, Len(txtFilter.Text) - iPos3): sCompare2 = Trim(sCompare2)
                  sFilter = "Descriptions Like #*" & sCompare1 & "*# AND " & _
                            "Descriptions Like #*" & sCompare2 & "*# AND " & _
                            "Descriptions Like #*" & sCompare3 & "*# AND " & _
                            "Descriptions Like #*" & sCompare4 & "*# "
                            
              Else
                  sFilter = "Descriptions Like #*" & sCompare1 & "*# AND " & _
                            "Descriptions Like #*" & sCompare2 & "*# AND " & _
                            "Descriptions Like #*" & sCompare3 & "*# "
                            
              End If
   
          ElseIf iPos1 > 0 And iPos2 > 0 And iPos3 = 0 Then
              sCompare1 = Mid(txtFilter.Text, 1, iPos1 - 1): sCompare1 = Trim(sCompare1)
              sCompare2 = Mid(txtFilter.Text, iPos1 + 1, iPos2 - iPos1 - 1): sCompare2 = Trim(sCompare2)
              If Len(txtFilter.Text) > iPos2 Then
                  sCompare3 = Mid(txtFilter.Text, iPos2 + 1, Len(txtFilter.Text) - iPos2): sCompare3 = Trim(sCompare3)
                  sFilter = "Descriptions Like #*" & sCompare1 & "*# AND " & _
                            "Descriptions Like #*" & sCompare2 & "*# AND " & _
                            "Descriptions Like #*" & sCompare3 & "*# "
                            
              Else
                  sFilter = "Descriptions Like #*" & sCompare1 & "*# AND " & _
                            "Descriptions Like #*" & sCompare2 & "*# "
                            
              End If
          ElseIf iPos1 > 0 And iPos2 = 0 And iPos3 = 0 Then
              sCompare1 = Mid(txtFilter.Text, 1, iPos1 - 1): sCompare1 = Trim(sCompare1)
              If Len(txtFilter.Text) > iPos1 Then
                  sCompare2 = Mid(txtFilter.Text, iPos1 + 1, Len(txtFilter.Text) - iPos1): sCompare2 = Trim(sCompare2)
   
                  sFilter = "Descriptions Like #*" & sCompare1 & "*# AND " & _
                            "Descriptions Like #*" & sCompare2 & "*# "
                      
              Else
                  sFilter = "Descriptions Like #*" & sCompare1 & "*# "
                            
              End If
   
          ElseIf iPos1 = 0 And iPos2 = 0 And iPos3 = 0 And txtFilter.Text <> "" Then
              sCompare1 = Mid(txtFilter.Text, 1, Len(txtFilter.Text)): sCompare1 = Trim(sCompare1)
              sFilter = "Descriptions Like #*" & sCompare1 & "*# "
                        
          End If
          'Release before filter
          sFilter = sFilter & _
          "AND SLoc='" & cbbSL.Text & "'"
          Debug.Print sFilter
          Debug.Print "Pos 1 " & iPos1 & ":" & sCompare1
          Debug.Print "Pos 2 " & iPos2 & ":" & sCompare2
          Debug.Print "Pos 3 " & iPos3 & ":" & sCompare3
          Debug.Print "String 4:" & sCompare4
          [COLOR=red]rsData.Filter = sFilter[/COLOR]
          rsData.Sort = "Descriptions"
          lRecordCount = rsData.RecordCount
          Debug.Print sFilter & vbCrLf & lRecordCount
          If lRecordCount > 0 Then
              'Update the value
              'Tính tổng
              Do Until rsData.EOF
                  sngQty = sngQty + Val(rsData.Fields("UnrestQty").Value)
                  rsData.MoveNext
              Loop
              txtTotal.Text = Format(sngQty, "##,##0.00")
          Else
              txtTotal.Text = Format(0, "##,##0.00")
          End If
      Else
          rsData.Filter = adFilterNone
      End If
   
  ErrorExit:
      With Application
          .Calculation = xlCalculationManual
          .ScreenUpdating = True
          .DisplayAlerts = True
      End With
      Exit Sub
  txtFilter_Change_Error:
      If bCentralErrorHandler("frmQuery", "txtFilter_Change", , False) Then
          Stop
          Resume
      Else
          Resume ErrorExit
      End If
  End Sub

Thủ thuật chính ở đây là dựa vào những gì người dùng nhập vào để thiết lập chuổi lọc sFilter. Ví dụ: người dùng gõ vào textbox này như sau: Matt*190*91*25*

Có nghĩa là người dùng cần tìm các chuỗi : Matt, 190, 91, 25 trong chuỗi cần tìm. Nếu các bạn để ý, chương trình xử lý rất nhanh. Và các bạn sẽ có kết quả tìm kiếm trong chốc lát.
Sau đó dựa vào kết quả lọc được các bạn có thể xuất ra ngoài.

  Private Sub cmdExport_Click()
  Dim lRecordCount As Long, i As Long, j As Integer
  Dim rngRange As Range
      On Error GoTo cmdExport_Click_Error
      With Application
          .Calculation = xlCalculationManual
          .ScreenUpdating = False
          .DisplayAlerts = False
      End With
      i = 2
      lRecordCount = rsData.RecordCount
      If lRecordCount > 0 Then
          Set rngRange = Range("tbStock_Fig_Del")
          rngRange.ClearContents
          For j = 0 To rsData.Fields.Count - 1
              With Application.ThisWorkbook.Worksheets("STOCK_FIG").Range("A1")
                  .Offset(0, j) = rsData.Fields(j).Name
              End With
          Next j
          rsData.MoveFirst
          Do Until rsData.EOF
              With Application.ThisWorkbook.Worksheets("STOCK_FIG").Range("A1")
                  .Offset(i, 0) = rsData.Fields("MaterialNumber").Value
                  .Offset(i, 1) = rsData.Fields("Descriptions").Value
                  .Offset(i, 2) = rsData.Fields("Plnt").Value
                  .Offset(i, 3) = rsData.Fields("SLoc").Value
                  .Offset(i, 4) = rsData.Fields("UoM").Value
                  .Offset(i, 5) = rsData.Fields("UnrestQty").Value
                  .Offset(i, 6) = rsData.Fields("TransQty").Value
                  .Offset(i, 7) = rsData.Fields("QIQty").Value
                  .Offset(i, 8) = rsData.Fields("RestrictedQty").Value
                  .Offset(i, 9) = rsData.Fields("BlockedQty").Value
                  .Offset(i, 10) = rsData.Fields("ReturnsQty").Value
              End With
              rsData.MoveNext
              i = i + 1
          Loop
          rngRange.Columns.AutoFit
          ' Application.ThisWorkbook.Worksheets("SUMMARY").Range("A1").Offset(1, 0).CopyFromRecordset rsData
          ' This Method can not do when the Filter was applied to recordset
      End If
      Set rngRange = Nothing
   
  ErrorExit:
      With Application
          .Calculation = xlCalculationManual
          .ScreenUpdating = True
          .DisplayAlerts = True
      End With
      Exit Sub
   
  cmdExport_Click_Error:
      If bCentralErrorHandler("frmQuery", "cmdExport_Click", , False) Then
          Stop
          Resume
      Else
          Resume ErrorExit
      End If
  End Sub

Vâng, như vậy là một ví dụ tương đối đầy đủ về việc đưa dữ liệu từ Excel sang Access. Và từ đó trích rút dữ liệu ra trở lại Excel.
Các bạn có thể phát triển từ ví dụ này sang nhiều ứng dụng khác.

Chúc các bạn thành công.

Lê Thanh Nhân

 

[lethanhnhan]

Bảng trong Access tbStock, các trường có kiểu dữ liệu như sau:

Lê Thanh Nhân

 

[lethanhnhan]

Tham khảo code của IBM

Tôi xin giới thiệu một đọan code của IBM để các bạn tham khảo.
Ở đây hầu như giới thiệu với các bạn các thao tác cơ bản với cơ sở dữ liệu
Các bạn hãy từ từ xem và nghiền ngẫm nha, nhớ đọc thêm các tài liệu về ADO.
(Thật sự ra tôi muốn giới thiệu với các bạn về ADO.NET nhưng nghĩ rồi thôi. Chắc hãy thao tác với cái ADO này cái đã )

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' (c) Copyright IBM Corp. 2003  All rights reserved.
'
' This sample program is owned by International Business Machines
' Corporation or one of its subsidiaries ("IBM") and is copyrighted
' and licensed, not sold.
'
' You may copy, modify, and distribute this sample program in any
' form without payment to IBM,  for any purpose including developing,
' using, marketing or distributing programs that include or are
' derivative works of the sample program.
'
' The sample program is provided to you on an "AS IS" basis, without
' warranty of any kind.  IBM HEREBY  EXPRESSLY DISCLAIMS ALL
' WARRANTIES EITHER EXPRESS OR IMPLIED, INCLUDING, BUT NOT LIMITED TO
' THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTIC-
' ULAR PURPOSE. Some jurisdictions do not allow for the exclusion or
' limitation of implied warranties, so the above limitations or
' exclusions may not apply to you.  IBM shall not be liable for any
' damages you suffer as a result of using, modifying or distributing
' the sample program or its derivatives.
'
' Each copy of any portion of this sample program or any derivative
' work,  must include a the above copyright notice and disclaimer of
' warranty.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Option Explicit


' Create and return ADO Connection Object.
Public Function GetConnection( _
        strDBName As String, _
        Optional strUserName As String = "", _
        Optional strPassword As String = "") As ADODB.Connection
    On Error GoTo GetConnection_ErrHandler

    Dim strConnectionString As String
    strConnectionString = "Provider=IBMDADB2; DSN=" & strDBName
    If strUserName <> "" And strPassword <> "" Then
        strConnectionString = strConnectionString & "; User ID=" & strUserName _
                 & "; Password=" & strPassword
    End If
    
    'Create new ADO connection object
    Dim adoConnection As New ADODB.Connection
    With adoConnection
        .CursorLocation = adUseClient
        .ConnectionString = strConnectionString
    End With

    'Return new ADO connection object
    Set GetConnection = adoConnection
    Set adoConnection = Nothing
    Exit Function

GetConnection_ErrHandler:
    MsgBox "Error Code: " & err.Number & vbNewLine & _
            "Description: " & err.Description & vbNewLine & _
            "Source: " & err.Source, _
            vbOKOnly + vbCritical
    err.Clear
    Set GetConnection = Nothing
End Function


Sub ShowAllErrors(ByRef adoConnection As ADODB.Connection)
    If adoConnection.Errors.Count > 0 Then
        MsgBox "Error code:  " & adoConnection.Errors(0).Number & vbNewLine & _
                "Description: " & adoConnection.Errors(0).Description & vbNewLine & _
                "Source:      " & adoConnection.Errors(0).Source, _
                vbOKOnly + vbCritical
        adoConnection.Errors.Clear
    Else
        MsgBox "Error code:  " & err.Number & vbNewLine & _
                "Description: " & err.Description & vbNewLine & _
                "Source:      " & err.Source, _
                vbOKOnly + vbCritical
        err.Clear
    End If
End Sub


Sub InsertUsingInsert(ByRef adoConnection As ADODB.Connection)
    'Create ADO objects
    Dim adoCommand As ADODB.Command

    On Error GoTo InsertUsingInsert_ErrHandler

    Set adoCommand = New ADODB.Command

    With adoCommand
        .CommandType = adCmdText
        .ActiveConnection = adoConnection
        .CommandText = "INSERT INTO BASICADO (tINT, tVARCHAR, tDATE, tTIME, tDECIMAL) VALUES(?,?,?,?,?)"
    End With

    'Add Parameters to the Command object
    Dim adoParm_tINT As Parameter
    Set adoParm_tINT = adoCommand.CreateParameter("tINT", _
                    adInteger, _
                    adParamInput)
    Call adoCommand.Parameters.Append(adoParm_tINT)
    
    Dim adoParm_tVARCHAR As Parameter
    Set adoParm_tVARCHAR = adoCommand.CreateParameter("tVARCHAR", _
                    adVarChar, _
                    adParamInput, _
                    256)
    Call adoCommand.Parameters.Append(adoParm_tVARCHAR)
    
    Dim adoParm_tDATE As Parameter
    Set adoParm_tDATE = adoCommand.CreateParameter("tDATE", _
                    adDBDate, _
                    adParamInput)
    Call adoCommand.Parameters.Append(adoParm_tDATE)
    
    Dim adoParm_tTIME As Parameter
    Set adoParm_tTIME = adoCommand.CreateParameter("tTIME", _
                    adDBTime, _
                    adParamInput)
    Call adoCommand.Parameters.Append(adoParm_tTIME)
    
    Dim adoParm_tDECIMAL As Parameter
    Set adoParm_tDECIMAL = adoCommand.CreateParameter("tDECIMAL", _
                    adDecimal, _
                    adParamInput)
    Call adoCommand.Parameters.Append(adoParm_tDECIMAL)
    
    'Set the values and execute the 1st insert
    adoParm_tINT.Value = 1
    adoParm_tVARCHAR.Value = "Hello world at 1!"
    adoParm_tDATE.Value = "21/02/1997"
    adoParm_tTIME.Value = "12:00:01"
    adoParm_tDECIMAL.Value = "1111.11"
    Call adoCommand.Execute
    
    'Set the values and execute the 2nd insert
    adoParm_tINT.Value = 2
    adoParm_tVARCHAR.Value = "Hello world at 2!"
    adoParm_tDATE.Value = "01/03/1999"
    adoParm_tTIME.Value = "12:00:02"
    adoParm_tDECIMAL.Value = "2222.22"
    Call adoCommand.Execute

    Set adoCommand = Nothing
    Exit Sub

InsertUsingInsert_ErrHandler:
    Call ShowAllErrors(adoConnection)
End Sub


Sub InsertUsingRecordset(ByRef adoConnection As ADODB.Connection)
    
    'Create ADO objects
    Dim adoCommand As ADODB.Command
    Dim adoRecordSet As ADODB.Recordset

    On Error GoTo InsertUsingRecordset_ErrHandler

    Set adoCommand = New ADODB.Command

    With adoCommand
        .CommandType = adCmdText
        .ActiveConnection = adoConnection
        .CommandText = "SELECT tINT, tVARCHAR, tDATE, tTIME, tDECIMAL FROM BASICADO WHERE tINT = 0"
    End With

    'Create record set
    Set adoRecordSet = New ADODB.Recordset
    adoRecordSet.Open adoCommand, , adOpenStatic, adLockOptimistic
    
    'Update values for row 1
    adoRecordSet.AddNew
    adoRecordSet!tINT = 1
    adoRecordSet!tVARCHAR = "Hello world at 1!"
    adoRecordSet!tDATE = "21/02/1997"
    adoRecordSet!tTIME = "12:00:01"
    adoRecordSet!tDECIMAL = "1111.11"
    
    'Update values for row 2
    adoRecordSet.AddNew
    adoRecordSet!tINT = 2
    adoRecordSet!tVARCHAR.Value = "Hello world at 2!"
    adoRecordSet!tDATE = "01/03/1999"
    adoRecordSet!tTIME = "12:00:02"
    adoRecordSet!tDECIMAL = "2222.22"
    
    'Execute all inserts
    Call adoRecordSet.Update
    
    Set adoRecordSet = Nothing
    Set adoCommand = Nothing
    Exit Sub

InsertUsingRecordset_ErrHandler:
    Call ShowAllErrors(adoConnection)
End Sub


Sub UpdateUsingUpdate(ByRef adoConnection As ADODB.Connection)
    
    'Create ADO objects
    Dim adoCommand As ADODB.Command

    On Error GoTo UpdateUsingUpdate_ErrHandler

    Set adoCommand = New ADODB.Command

    With adoCommand
        .CommandType = adCmdText
        .ActiveConnection = adoConnection
        .CommandText = "UPDATE BASICADO " & _
                       "SET tVARCHAR = 'Bye world!' " & _
                       "WHERE tINT = ?"
    End With

    'Add Parameters to the Command object
    Dim adoParm_tINT As Parameter
    Set adoParm_tINT = adoCommand.CreateParameter("tINT", _
                    adInteger, _
                    adParamInput)
    Call adoCommand.Parameters.Append(adoParm_tINT)
    
    'Update all records having tINT = 1
    adoParm_tINT.Value = 1
    Call adoCommand.Execute
    
    Set adoCommand = Nothing
    Exit Sub

UpdateUsingUpdate_ErrHandler:
    Call ShowAllErrors(adoConnection)
End Sub

Lê Thanh Nhân

 

[lethanhnhan]

Sub UpdateUsingRecordset(ByRef adoConnection As ADODB.Connection)
    
    'Create ADO objects
    Dim adoCommand As ADODB.Command
    Dim adoRecordSet As ADODB.Recordset

    On Error GoTo UpdateUsingRecordset_ErrHandler

    Set adoCommand = New ADODB.Command

    With adoCommand
        .CommandType = adCmdText
        .ActiveConnection = adoConnection
        'Update requires primary key, so need to select tKEY
        .CommandText = "SELECT tKEY, tINT, tVARCHAR, tDATE, tTIME, tDECIMAL FROM BASICADO"
    End With

    'Create record set
    Set adoRecordSet = New ADODB.Recordset
    adoRecordSet.Open adoCommand, , adOpenStatic, adLockOptimistic
    
    'Update all records having tINT = 2 (requires primary key)
    Call adoRecordSet.Find("tINT = 2")
    While Not adoRecordSet.EOF()
        adoRecordSet!tVARCHAR = "Bye world!"
        adoRecordSet.MoveNext
        Call adoRecordSet.Find("tINT = 2")
    Wend
    
    'Workaround for EOF ADO bug!
    If adoRecordSet.RecordCount > 0 Then
        adoRecordSet.MoveFirst
    End If
    
    'Execute the update
    Call adoRecordSet.Update

    Set adoRecordSet = Nothing
    Set adoCommand = Nothing
    Exit Sub

UpdateUsingRecordset_ErrHandler:
    Call ShowAllErrors(adoConnection)
End Sub


Sub DeleteUsingDelete(ByRef adoConnection As ADODB.Connection)
    
    'Create ADO objects
    Dim adoCommand As ADODB.Command

    On Error GoTo DeleteUsingDelete_ErrHandler

    Set adoCommand = New ADODB.Command

    With adoCommand
        .CommandType = adCmdText
        .ActiveConnection = adoConnection
        .CommandText = "DELETE FROM BASICADO WHERE tINT = ?"
    End With

    'Add Parameters to the Command object
    Dim adoParm_tINT As Parameter
    Set adoParm_tINT = adoCommand.CreateParameter("tINT", _
                    adInteger, _
                    adParamInput)
    Call adoCommand.Parameters.Append(adoParm_tINT)
    
    'Delete all records having tINT = 1
    adoParm_tINT.Value = 1
    Call adoCommand.Execute
    
    Set adoCommand = Nothing
    Exit Sub

DeleteUsingDelete_ErrHandler:
    Call ShowAllErrors(adoConnection)
End Sub


Sub DeleteUsingRecordset(ByRef adoConnection As ADODB.Connection)
    
    'Create ADO objects
    Dim adoCommand As ADODB.Command
    Dim adoRecordSet As ADODB.Recordset

    On Error GoTo DeleteUsingRecordset_ErrHandler

    Set adoCommand = New ADODB.Command

    With adoCommand
        .CommandType = adCmdText
        .ActiveConnection = adoConnection
        'Delete requires primary key, so need to select tKEY
        .CommandText = "SELECT tKEY, tINT, tVARCHAR, tDATE, tTIME, tDECIMAL FROM BASICADO"
    End With

    'Create record set
    Set adoRecordSet = New ADODB.Recordset
    adoRecordSet.Open adoCommand, , adOpenStatic, adLockOptimistic
    
    'Delete all records having tINT = 2 (requires primary key)
    Call adoRecordSet.Find("tINT = 2")
    While Not adoRecordSet.EOF()
        adoRecordSet.Delete
        adoRecordSet.MoveNext
        Call adoRecordSet.Find("tINT = 2")
    Wend
    
    'Workaround for EOF ADO bug!
    If adoRecordSet.RecordCount > 0 Then
        adoRecordSet.MoveFirst
    End If
    
    'Execute the delete
    Call adoRecordSet.Update

    Set adoRecordSet = Nothing
    Set adoCommand = Nothing
    Exit Sub

DeleteUsingRecordset_ErrHandler:
    Call ShowAllErrors(adoConnection)
End Sub


Public Function GetDateValue(ByRef strDate As String) As String
    If strDate <> "" Then
        GetDateValue = Format(DateValue(strDate), "mm/dd/yyyy")
        'GetDateValue = FormatDateTime(DateValue(strDate), vbGeneralDate)
    Else
        GetDateValue = ""
    End If
End Function


Public Function GetTimeValue(ByRef strTime As String) As String
    If strTime <> "" Then
        GetTimeValue = Format(TimeValue(strTime), "hh:nn:ss")
        'GetTimeValue = FormatDateTime(TimeValue(strTime), vbLongTime)
    Else
        GetTimeValue = ""
    End If
End Function



Function QueryRecords(ByRef adoConnection As ADODB.Connection) As ADODB.Recordset
    'Create ADO objects
    Dim adoCommand As ADODB.Command
    Dim adoRecordSet As ADODB.Recordset

    On Error GoTo QueryRecords_ErrHandler

    Set adoCommand = New ADODB.Command

    With adoCommand
        .CommandType = adCmdText
        .ActiveConnection = adoConnection
        .CommandText = "SELECT tINT, tVARCHAR, tDATE, tTIME, tDECIMAL FROM BASICADO"
    End With

    'Create record set
    Set adoRecordSet = New ADODB.Recordset
    adoRecordSet.Open adoCommand, , adOpenStatic, adLockOptimistic
    
    Set QueryRecords = adoRecordSet
    
    Set adoRecordSet = Nothing
    Set adoCommand = Nothing
    Exit Function

QueryRecords_ErrHandler:
    Call ShowAllErrors(adoConnection)
    Set QueryRecords = Nothing
End Function

Lê Thanh Nhân

 

[levanduyet]

Khảo sát thủ tục ADOFromExcelToAccess()

Chào các bạn,
Hôm nay chúng ta sẽ bàn về việc thiết kế bảng dữ liệu trong MS Access, và việc xuất dữ liệu ra bảng này.
Các bạn có nhớ rằng trước đây chúng ta dùng thủ tục Sub ADOFromExcelToAccess()
Thủ tục này là thủ tục chính cho việc đưa dữ liệu từ Excel-> Access.
Có thể nói thủ tục này gồm các bước như sau:

_Kiểm tra kết nối CSDL(Cơ sở dữ liệu), kết nối với CSDL. Nếu không kết nối được thì thông báo thoát.
_Dùng Recordset để đưa dữ liệu vào Access.

If gcnAccess.State = ObjectStateEnum.adStateClosed Then
          Call ConnectToDatabase
          If gcnAccess.State = ObjectStateEnum.adStateClosed Then
              gcnAccess.Open
          End If
          Set rs = New ADODB.Recordset
          rs.Open sTableInDBName, gcnAccess, adOpenKeyset, adLockOptimistic, adCmdTable
....
End If

Các bạn có thấy đoạn code ở trên có gì không ổn không?
Nếu kết nối đang mở

gcnAccess.State=ObjectStateEnum.adStateOpen

Thì việc xuất dữ liệu ra Access sẽ không thực hiện được.
Vậy các bạn phải sửa lại như sau:

If gcnAccess.State = ObjectStateEnum.adStateClosed Then
        Call ConnectToDatabase
    End If
    If gcnAccess.State = ObjectStateEnum.adStateClosed Then
        gcnAccess.Open
    End If
    [COLOR="Blue"]Set rs = New ADODB.Recordset[/COLOR]
    [COLOR="Blue"]rs.Open sTableInDBName, gcnAccess, adOpenKeyset, adLockOptimistic, adCmdTable[/COLOR]
...

Lê Văn Duyệt

 

[levanduyet]

Sau khi Recordset được Open thì chúng ta bắt đầu đưa dữ liệu vào như sau:

r = 2    ' Hàng bắt đầu để xuất dữ liệu
    Do While
'Kiểm tra có dữ liệu hay không tại cột A.
'Chú ý cột này phải là cột chứa dữ liệu liên tục
 Len(Application.Workbooks(sTenWorkbookThaoTac).Worksheets(sTenWorksheetThaoTac).Range("A" & r).Formula) > 0
        ' Thực hiện liên tục cho tới khi ô không có dữ liệu tại cột A
        With rs
            .AddNew    ' Đưa vào dữ liệu mới
            ' Đưa các giá trị vào trường dữ liệu
            ' Ở đây chúng ta đưa vào trường [COLOR=Blue][B]Payer[/B][/COLOR]
            .Fields("Payer") = Application.Workbooks(sTenWorkbookThaoTac).Worksheets(sTenWorksheetThaoTac).Range("A" & r).Value
            
            ' Các bạn có thể thêm các trường khác
            .Update    ' Cập nhật Recordset. Chú ý, nếu không cập nhật thì coi như "công toi"
        End With
        r = r + 1    ' tăng hàng quét dữ liệu lên 1
    Loop
'Kết thúc vòng lập 
'Đặt biến bImportSucced = True, để xác nhận dữ liệu xuất là thành công
    bImportSucced = True
    rs.Close

Các bạn thấy đoạn code trên có gì không ổn không?
Có đấy, nếu việc xuất không thành công? Thì có trời mới biết dữ liệu nào không xuất được.
Vậy chúng ta có thể thêm vào một đoạn mã để khi xuất không được dữ liệu sẽ được đưa ra một worksheet: ERRORS

r = 2    ' Hàng bắt đầu để xuất dữ liệu
    Do While
'Kiểm tra có dữ liệu hay không tại cột A.
'Chú ý cột này phải là cột chứa dữ liệu liên tục
 Len(Application.Workbooks(sTenWorkbookThaoTac).Worksheets(sTenWorksheetThaoTac).Range("A" & r).Formula) > 0
On Error Resume Next
        ' Thực hiện liên tục cho tới khi ô không có dữ liệu tại cột A
        With rs
            .AddNew    ' Đưa vào dữ liệu mới
            ' Đưa các giá trị vào trường dữ liệu
            ' Ở đây chúng ta đưa vào trường [COLOR=Blue][B]Payer[/B][/COLOR]
            .Fields("Payer") =                      Application.Workbooks(sTenWorkbookThaoTac).Worksheets(sTenWorksheetThaoTac).Range("A" & r).Value
            
            ' Các bạn có thể thêm các trường khác
            .Update    ' Cập nhật Recordset. Chú ý, nếu không cập nhật thì coi như "công toi"
            If Err.Number<>0 Then
            'Trong trường hợp có lỗi xãy ra 
            'Đưa dữ liệu ra một worksheet nhằm tham khảo
         With Application.Workbooks(sTenWorkbookThaoTac).Worksheets("ERRORS").Range("A1")
        .Offset(k, 1) = Application.Workbooks(sTenWorkbookThaoTac).Worksheets(sTenWorksheetThaoTac).Range("A" & r).Value
                 k = k + 1
                 'Đặt lại Err
                 Err.Number=0
                 End With
            End If
        End With
        r = r + 1    ' tăng hàng quét dữ liệu lên 1
    Loop
'Kết thúc vòng lập 
'Đặt biến bImportSucced = True, để xác nhận dữ liệu xuất là thành công
    bImportSucced = True
    rs.Close

Như vậy sau khi xuất dữ liệu chúng ta có thể biết được bao nhiêu dữ liệu chúng ta không thế xuất được.
_Đóng kết nối và giải phóng biến

Lê Văn Duyệt

 

[levanduyet]

Tạo bảng trong MS Access

Sau bước đầu tiên là "khảo sát" dữ liệu muốn xuất ra xem nó thuộc dạng nào?
Bạn bắt đầu mở MS Access

Tạo cơ sở dữ liệu mới.

Đặt tên cho cơ sở dữ liệu mới này.

Tạo bảng dữ liệu mới.

Tạo trường dữ liệu, ở đây các bạn có thể chọn các trường dữ liệu sau:

_Text.
_Memo.
_Number.
_Date/Time.
_Currency.
_Autonumber.
_Yes/No.
_OLE Object.
_Hyperlink.

Đối với các trường dữ liệu là mã sản phẩm nên dùng là Text (lấy chiều dài là 10 ký tự, tôi sẽ nói thêm sau)
Mỗi bảng dữ liệu nên có một trường Autonumber, để truy vấn sửa chữa, cập nhật sau này (áp dụng cho doanh nghiệp vừa và nhỏ thôi)
Theo tôi để tránh "phiền toái" đối với trường dữ lệu Date, tôi dùng kiểu Text, nhưng ta phải vết thêm một số hàm để xử lý.

Thiết lập các thuộc tính cho trường dữ liệu:
_Primary: cột sẽ làm làm khóa chính; Unique; Ignore Nulls...

Và cuối cùng và lưu lại.

Lê Văn Duyệt

 

[levanduyet]

Sql

Để xây dựng ứng dụng kết hợp chúng ta cần phải biết căn bản SQL.
Các bạn có thể tham khảo tại http://www.levanduyetexcel.netfirms.com/Sql_for_beginners.htm
Ở đây tôi xin giới thiệu một ít về SQL.
SQL là gì? SQL là một ngôn ngũ máy tính chuẩn để truy nhập và thao tác xử lý hầu hết mọi hệ CSDL.

SQL (Structured Quẻy Language)

• SQL cho phép bạn truy nhập xử lý cơ sở dữ liệu.
• SQL là một ngôn ngữ máy tính theo chuẩn ANSI
• SQL có thể thực thi những truy vấn trên CSDL
• SQL có thể dùng trích rút dữ liệu từ các bảng
• SQL có thể chèn những mẫu tin hay dòng dữ liệu mới vào trong một bảng CSDL
• SQL có thể xóa những dòng mẫu tin từ một bảng CSDL

Một bảng dữ liệu bao gồm

• Trường dữ liệu (cột trong Excel)
• Một một hàng dữ liệu bao gồm nhiều cột chúng ta gọi là một record (hàng trong Excel

Tập họp tất cả các hàng dữ liệu chúng ta gọi là bảng dữ liệu.
Vậy trong Excel khi ta thực hiện việc lọc dữ liệu bằng Auto Filter/Advanced Filter, điều này cũng giống như việc chúng ta lọc dữ liệu trong bảng dữ liệu của MS Access.

Đối với một dữ liệu lớn trong Excel (Ví dụ trên 10,000 dòng) thì việc lọc dữ liệu đã gặp khó khăn về tốc độ. Đó cũng là một trong lý do chúng ta Xây dựng ứng dụng kết hợp .

Lệnh SELECT

SELECT [DISTINCT] cột dữ liệu
FROM tên bảng dữ liệu
WHERE điều kiện (*)
GROUP BY cột dữ liệu
ORDER BY cột dữ liệu [ASC] hoặc [DESC]

(*)Điều kiện chúng ta có thể dùng các toán tử sau:

=           Bằng nhau
<>       Không bằng nhau
>          Lớn hơn
<          Nhỏ hơn
>=        Lớn hơn hoặc bằng
<=         Nhỏ hơn hoặc bằng
BETWEEN    Giữa một phạm vi giá trị
LIKE       Tìm kiếm so khớp theo mẫu
AND/OR

Chú ý: Trong một số phiên bản SQL, toán tử <> có thể được viết như sau: !=

Ví dụ tôi có một bảng dữ liệu tên tbSanLuongSX gồm các trường:
Mã sản phẩm (MSP), Mô tả (MoTa), Số lượng (SL), Nhập xuât (NX), Ngày sản xuất (NgaySX), Ca sản xuất (CaSX)

Bây giờ tôi muốn lọc sản phẩm từ ngày A đến ngày B thì chúng ta làm sao?
Chúng ta viết câu lệnh SQL sau:

SELECT MSP, MoTa, SL, NgaySX
FROM tbSanLuongSX
WHERE NgaySX BETWEEN #A# AND #B#
ORDER BY NgaySX;

Giải thích: chọn Mã sản phẩm, Mô tả, Số lượng, Ngày sản xuất từ bảng tbSanLuongSX, nếu Ngày sản xuất trong khoảng A và B, sắp xếp theo NgaySX.

Bây giờ tôi muốn tính tổng sản phẩm sản xuất từ ngày A đến ngày B thì chúng ta làm sao?
Chúng ta viết câu lệnh SQL sau:

SELECT MSP, MoTa, SUM(SL) AS [TONG]
FROM tbSanLuongSX
WHERE NgaySX BETWEEN #A# AND #B#
GROUP BY MSP, MoTa
ORDER BY NgaySX;

Chú ý: SUM(SL) AS [TONG] có nghĩa trường SUM(SL) có tên bí danh (alias) là TONG.
Chúng ta có thể sử dụng các hàm khác như Avg, Min, Max, Count

Giải thích: chọn Mã sản phẩm, Mô tả, Tổng(Số lượng) từ bảng tbSanLuongSX, nếu Ngày sản xuất trong khoảng A và B, sắp xếp theo NgaySX.

Giả sử các bạn muốn chọn ra chỉ các mã sản phẩm không trùng nhau, các bạn phải dùng câu lệnh như thế nào?

SELECT DISTINCT MSP, MoTa
FROM tbSanLuongSX;

SELECT DISTINCT: có nghĩa là chỉ chọn unique record mà thôi.

Giả sử tôi có một bảng khác là tbMaSanPham gồm các trường: Mã sản phẩm (MSP), Mô tả sản phẩm (MoTa), Đơn vị tính (DVT)

Bây giờ tôi muốn tính tổng các sản phẩm sản xuất chỉ có trong bảng tbMaSanPham thì sao?
Chúng ta viết câu lệnh SQL sau:

SELECT MSP, MoTa, SUM(SL) AS [TONG]
FROM tbSanLuongSX
WHERE MSP IN (SELECT DISTINCT MSP FROM tbMaSanPham)
GROUP BY MSP, MoTa
ORDER BY NgaySX;

Các bạn thấy câu lệnh SELECT DISTINCT MSP FROM tbMaSanPham
Trả về các giá trị unique của mã sản phẩm. Như vậy chúng ta có thể dùng các câu lệnh SELECT lồng nhau như trên.


Lê Văn Duyệt

 

[levanduyet]

Chèn dòng dữ liệu
Chúng ta dùng câu lệnh SQL sau:

INSERT INTO tên bảng dữ liệu(cột dữ liệu 1, cột dữ liệu 2,...)
VALUES (giá trị 1, giá trị 2,...)

Giả sử tôi muốn chèn một dòng vào bảng tbMaSanPham thì chúng ta dùng câu lệnh SQL sau:

INSERT INTO tbMaSanPham(MSP, MoTa, DVT)
VALUES('2200001245','Hàng đặc biệt', 'Cái');

Câp nhật dữ liệu
Chúng ta dùng câu lệnh SQL sau:

UPDATE tên bảng dữ liệu
SET tên cột dữ liệu 1= giá trị mới
WHERE tên cột dữ liệu = giá trị điều kiện lọc

Bây giờ tôi muốn cập nhật mã 2200001245, với đơn vị tính là hộp
Chúng ta dùng câu lệnh SQL sau:

UPDATE tbMaSanPham
SET DVT = 'hộp'
WHERE MSP = '2200001245'

Xóa dữ liệu
Chúng ta dùng câu lệnh SQL sau:

DELETE tên bảng dữ liệu
WHERE tên cột dữ liệu = giá trị điều kiện lọc

Bây giờ tôi muốn xóa mã 2200001245
Chúng ta dùng câu lệnh SQL sau:

DELETE tbMaSanPham
WHERE MSP = '2200001245'

Lê Văn Duyệt

 

[levanduyet]

Các hàm SQL
SQL cung cấp rất nhiều hàm nội tại cho phép đếm, tính tổng, thống kê

Cú pháp hàm:

SELECT hàm(cột)
FROM tên bảng dữ liệu

Các loại hàm:
Các loại hàm trong SQL có thể phân loại theo nhóm như sau:
_Hàm tổng (Aggregate function): đây là các hàm tính tổng trên tập hợp và trả về một giá trị đơn duy nhất. Việc tính tổng có thể là phép đếm COUNT, phép cộng SUM, trung bình AVG
Chú ý: Nếu sử dụng giữa nhiều biểu thức khác trong danh sách của lệnh SELECT, lệnh SELECT phải có mệnh đề nhóm GROUP BY kèm theo (Giống ví dụ trên tôi đã đề cập).
_Hàm vô hướng (scalar functions): hàm vô hướng thường dùng tính toán trên một giá trị đơn. Ví dụ NOW(), LEN()

Mỗi hệ quản trị CSDL đề có những hàm cài đặt cụ thể và có thể khác nhau.

Danh sách các hàm tổng của SQL

Hàm               Mô tả
AVG(cột)          Trả về trị trung bình của các giá trị cột
COUNT(cột)        Đếm số dòng (không tính giá trị NULL) của cột
COUNT(*)          Trả về số dòng được chọn từ SELECT
MAX(cột)          Trả về giá trị lớn nhất
MIN(cột)          Trả về giá trị nhỏ nhất
SUM(cột)          Trả về tổng các giá trị cột

Danh sách các hàm vô hướng trong MS Access và SQL Server

Hàm                       Mô tả
UCASE(c)                  Chuyển chữ thường thành chữ hoa
LCASE(c)                  Chuyển chuổi thành chữ thường
MID(c,bắt đầu, kết thúc)  Copy chuổi con trong một chuổi
LEN(c)                    Trả về chiều dài chuổi
INSTR(c)                  Xác định vị trí ký tự trong chuổi
LEFT(c,số ký tự)          Cắt chuổi từ bên trái
RIGHT(c, số ký tự)        Cắt chuổi từ bên phải
ROUND(c, decimals)        Hàm làm tròn
MOD(x,y)                  Hàm chia lấy phần dư
NOW(x,y)                  Hàm trả về ngày tháng hiện hành
FORMAT(c, format)         Hàm định dạng
DATEDIFF(d, ngày1, ngày2) Hàm so sánh ngày tháng và thời gian

Lê Văn Duyệt

 

[levanduyet]

Như trên tôi đã giới thiệu về GROUP BY
Nay tôi xin giới thiệu về HAVING.
Do mệnh đề WHERE không thể sử dụng trong các hàm tổng, nên HAVING được thêm vào cấu trúc lệnh SQL. Nếu không có HAVING chúng ta không thể nào kiểm tra các kết quả trong từng nhóm.

Cú pháp HAVING như sau:

SELECT cột dữ liệu 1, SUM(cột dữ liệu 2)
FROM tên bảng dữ liệu
GROUP BY cột dữ liệu
HAVING SUM(cột dữ liệu 2) Giá trị điều kiện

Giả sử tôi muốn kiểm tra xem sản lượng sản xuất của một nhóm sản phẩm nào đó lớn hơn 2000 của bảng sau:

tbSanLuongSanXuat: Mã sản phẩm (MSP), Mô tả (MoTa), Số lượng (SL), Ngày sản xuất (NSX), Nhóm sản phẩm

Câu lệnh SQL sẽ như sau:

SELECT MSP, MoTa, SUM(SL)
FROM tbSanLuongSanXuat
GROUP BY MSP, MoTa
HAVING SUM(SL)>2000

Lê Văn Duyệt

 

[levanduyet]

Trở về với ứng dụng xem tồn kho.

Thông thường sau khi xem tồn kho, chúng ta muốn in ra một danh sách các vật tư yêu cầu cho một ca làm việc. Nếu kết hợp được việc này thì sẽ tốt hơn.

Các bạn xem hình sau:

Nhắc lại, sau khi các bạn xem tồn kho, các bạn muốn in nhiều mục vật tư và đưa danh sách này cho nhân viên kho có trách nhiệm xuất vật tư.
Mẫu yêu cầu như sau:

Các bạn có để ý rằng thông thường định dạng của các báo cáo người viết thường dùng font có độ rộng bằng nhau ví dụ như font: Courier (hoặc new courier).
Vậy yêu cầu thêm của chúng ta là khi người dùng Double-Click vào MSHFlexGrid thì sẽ hỏi người dùng muốn đề nghị xuất bao nhiêu. Sau khi người dùng trả lời mục này sẽ được đưa vào một ListBox bên dưới.
Chúng ta cũng muốn rằng khi người dùng Double_Click vào một mục của Listbox thì mục này sẽ bị loại ra khỏi ListBox.

Đoạn code thêm vào sẽ như sau:

Private Sub MSHFlexGridDB_DblClick()
 Dim faIndex As Variant, Ans As Variant
    Dim sMaterialNumber As String * 11, sMaterialDes As String * 41, sUoM As String * 5
    Dim sCombine As String
On Error GoTo MSHFlexGridDB_DblClick_Error
   With Application
      .Calculation = xlCalculationManual
      .ScreenUpdating = False
   End With
    faIndex = (Me.MSHFlexGridDB.RowSel) * Me.MSHFlexGridDB.Cols
    sMaterialNumber = Me.MSHFlexGridDB.TextArray(faIndex + 1)
    sMaterialDes = Me.MSHFlexGridDB.TextArray(faIndex + 2)
    sUoM = Me.MSHFlexGridDB.TextArray(faIndex + 5)
    Ans = Application.InputBox("Ban muon de nghi xuat vat tu " & vbNewLine & _
                               sMaterialNumber & "| " & sMaterialDes & vbNewLine & _
                               "Voi so luong: ", "So luong can", 10, , , , 1)
                               
    If IsNumeric(Ans) And Ans <> "False" Then
        sCombine = sMaterialNumber & "| " & sMaterialDes & "| " & sUoM & "| " & Ans
        Me.LstRmRequirement.AddItem sCombine
    End If
ErrorExit:
   With Application
      .Calculation = xlCalculationManual
      .ScreenUpdating = True
   End With
   Exit Sub
MSHFlexGridDB_DblClick_Error:
If bCentralErrorHandler("frmQuery", "MSHFlexGridDB_DblClick", , False) Then
     Stop
     Resume
Else
     Resume ErrorExit
End If
End Sub

Đối với đoạn code khi người dùng double click vào Listbox sẽ như sau:

Private Sub LstRmRequirement_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
'Delete the item when
'user double click on to ListBox
    Dim lIndex As Long
    On Error GoTo LstRmRequirement_DblClick_Error
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    If Me.LstRmRequirement.ListIndex <> -1 Then
        lIndex = Me.LstRmRequirement.ListIndex
        Me.LstRmRequirement.RemoveItem lIndex
    End If
ErrorExit:
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = True
    End With
    Exit Sub

LstRmRequirement_DblClick_Error:
    If bCentralErrorHandler("frmQuery", "LstRmRequirement_DblClick", , False) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If

End Sub

Chúng ta cũng tạo một nút lệnh để khi người dùng click vào đó nó sẽ hiện file text đã được định dạng theo mẫu báo cáo yêu cầu.

Private Sub cmdPrint_Click()
    Dim vPrint As Variant
    On Error GoTo cmdPrint_Click_Error
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    If Me.LstRmRequirement.ListCount > 0 Then
        With Me.LstRmRequirement
            .AddItem "**************************************************************"
            .AddItem " "
            .AddItem " "
            .AddItem " "
            .AddItem " "
            .AddItem "          YEU CAU BOI/REQUIRED BY"
        End With
        ListBoxUtils.SaveListBoxToFile Me.LstRmRequirement, "RawMaterialRequirement.txt", False
        MainMod.StartDoc GetLocalDirectory & "\" & "RawMaterialRequirement.txt"
    End If
ErrorExit:
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = True
    End With
    Exit Sub

cmdPrint_Click_Error:
    If bCentralErrorHandler("frmQuery", "cmdPrint_Click", , False) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If
End Sub

Như vậy các bạn sẽ có phiếu yêu cầu vật tư theo ý muốn của bạn.
Chúc các bạn thành công.

Lê Văn Duyệt

 

[levanduyet]

Các bạn chú ý:
Nếu các bạn không cho người dùng xóa từ hàng số 1 đến số 4 thì các bạn phải chỉnh lại đoạn code sau:

If Me.LstRmRequirement.ListIndex <> -1 And Me.LstRmRequirement.ListIndex>3 Then
        lIndex = Me.LstRmRequirement.ListIndex
        Me.LstRmRequirement.RemoveItem lIndex
End If

Chúc các bạn thành công.

Lê Văn Duyệt

 

[levanduyet]

Xây dựng form log-in

Thông thường đối với một phần mềm, ứng dụng người dùng đều phải log-in vào rồi mới được sử dụng.
Dựa vào việc log-in vào hệ thống sẽ:
_ Phân quyền.
_ Ghi chép lại các thao tác của người dùng.

Tôi xin giới thiệu với các bạn một ví dụ tương tự:
Đầu tiên chúng ta sẽ thiết kế một bảng đơn giản trong MS Access như sau:

Các bạn có thể thiết kế thêm các trường khác tùy mục đích của mình. Tôi chỉ xin giới thiệu một ví dụ đơn giản nhất.

Sau đó mỗi khi người dùng mở file Ms Excel của bạn, bạn yêu cầu người dùng phải truy nhập vào trước. Sau khi người dùng truy nhập vào, chúng ta sẽ lưu lại trong một ô của một worksheet ẩn. Dựa vào tên người dùng chúng ta sẽ kiểm tra hoặc cho phép người dùng sử dụng một số chức năng của chương trình.

Private Sub Workbook_Open()

    On Error GoTo Workbook_Open_Error
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    Call ConnectToDatabase
    Call CreateMenuAll(False, True, True)
    frmLogIn.Show

ErrorExit:
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = True
    End With
    Exit Sub

Workbook_Open_Error:
    If bCentralErrorHandler("ThisWorkbook", "Workbook_Open", , False) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If
End Sub

Trong đoạn code trên mỗi khi workbook mở chúng ta:
_Kết nối vào CSDL
_Tạo Menu
_Hiện form yêu cầu người dùng nhập vào. Nếu người dùng không truy nhập vào thì không thể dùng file ứng dụng của chúng ta.
Form truy nhập

Thông báo sau khi người dùng truy nhập vào

Các bạn cũng có thể viết thủ tục Autpen() để thực hiện việc này.

Code của form như sau:

Option Explicit
Dim iCount     As Long    'To count the error Log-In
Private Sub cmdLogIn_Click()
Dim sUserName As String, sUserSoSanh As String
Dim sPass As String, sPassSoSanh As String
Dim sRight     As String
Dim rngRange   As Range
    On Error GoTo cmdLogIn_Click_Error
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    If iCount > 3 Then
        MsgBoxUni VNI("You have enter more than " & iCount & " times!" & vbCrLf & _
                      "Pls, contact your Administrator." & vbCrLf & _
                      "Baïn ñaõ truy caäp hôn 3 laàn" & vbCrLf & _
                      "Xin lieân heä vôùi Administrator."), vbOKOnly, VNI("Thoâng baùo")
        End
    End If
    sUserName = txtTenTruyCap.Text
    sUserSoSanh = UserExist(sUserName)
    'Check the user name
    If Len(Trim(sUserSoSanh)) = 0 Then
        MsgBoxUni VNI("This user does not exist!" & vbCrLf & _
                      "Teân naøy khoâng toàn taïi!"), vbOKOnly, VNI("Thoâng baùo")
        txtTenTruyCap.Text = ""
        txtPass.Text = ""
        txtTenTruyCap.SetFocus
        iCount = iCount + 1
    End If
    sPass = txtPass.Text
    'Get Password
    sPassSoSanh = GetUserPassword(sUserName)
    'Get right of User
    sRight = GetUserRight(sUserName)
    If sPass = sPassSoSanh And Len(Trim(sUserSoSanh)) > 0 Then
        If Len(Trim(sRight)) > 0 Then
            MsgBoxUni VNI("Chaøo möøng baïn ñeán vôùi    " & vbCrLf & _
                          "COÂNG CUÏ QL KHO              " & vbCrLf & _
                          "Taùc giaû: Leâ Vaên Duyeät" & vbCrLf & _
                          "Baïn ñaõ truy caäp vôùi quyeàn " & sRight), vbOKOnly, VNI("Thoâng baùo")
            Application.Range("UserName").Value = sUserSoSanh
        Else
            MsgBoxUni VNI("Chaøo möøng baïn ñeán vôùi    " & vbCrLf & _
                          "COÂNG CUÏ QL KHO              " & vbCrLf & _
                          "Taùc giaû: Leâ Vaên Duyeät" & vbCrLf & _
                          "Baïn ñaõ truy caäp vôùi quyeàn " & sRight), vbOKOnly, VNI("Thoâng baùo")
            iCount = iCount + 1
            Application.Range("UserName").Value = sUserSoSanh
        End If
    ElseIf Len(Trim(sUserSoSanh)) > 0 Then
        MsgBoxUni VNI("Wrong Password !" & vbCrLf & _
                      "Pls enter again." & vbCrLf & _
                      "Sai Password ! Xin kieåm tra laïi."), vbOKOnly, VNI("Thoâng baùo")
        txtPass.Text = ""
        txtPass.SetFocus
        iCount = iCount + 1
        Exit Sub
    End If
    If sRight = "Admin" And Len(Trim(sUserSoSanh)) > 0 Then
        txtPass.Text = ""
        txtTenTruyCap.Text = ""
        Me.Hide
    ElseIf Len(Trim(sUserSoSanh)) > 0 Then
        MsgBoxUni VNI("You can only enter data!" & vbCrLf & _
                      "Baïn chæ coù theå nhaäp lieäu maø thoâi."), vbOKOnly, VNI("Thoâng baùo")
        txtPass.Text = ""
        txtTenTruyCap.Text = ""
        Me.Hide
    End If

ErrorExit:
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = True
    End With
    Exit Sub

cmdLogIn_Click_Error:
    If bCentralErrorHandler("frmLogIn", "cmdLogIn_Click", , False) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If
End Sub

Private Sub cmdThoat_Click()
    End
End Sub

Private Sub UserForm_Initialize()
    On Error GoTo UserForm_Initialize_Error
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    Me.Caption = VNI("Truy caâp vaøo CSDL")
    If Application.ActiveWorkbook.Name <> sWorkbookName Then
        MsgBoxUni VNI("This tool is active only" & vbNewLine & _
                      "The active workbook is StockCountHelper.xls" & vbNewLine & _
                      "Chöùc naêng naøy chæ cho workbook" & vbNewLine & _
                      sWorkbookName), vbOKOnly, VNI("Thoâng baùo")
        With Application
            .Calculation = xlCalculationManual
            .ScreenUpdating = True
        End With
        End    'Do not show form
    End If
    If gcnAccess.state = ObjectStateEnum.adStateClosed Then
        Call ConnectToDatabase
    End If
    If bConnected = False Then
        MsgBoxUni VNI("Can not connect to database." & vbNewLine & _
                      "Please contact administrator." & vbNewLine & _
                      "Khoâng theå keát noái vôùi CSDL!" & vbCrLf & _
                      "Xin baïn kieåm tra laïi!"), vbOKOnly, VNI("Thoâng baùo")
        With Application
            .Calculation = xlCalculationManual
            .ScreenUpdating = True
        End With
        End    'Do not show form
    End If
ErrorExit:
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = True
    End With
    Exit Sub

UserForm_Initialize_Error:
    If bCentralErrorHandler("frmLogIn", "UserForm_Initialize", , False) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If

End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
'Do not allow the user close the form by clicking the X button
    If CloseMode = vbFormControlMenu Then
        Cancel = True
    End If
End Sub

_Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Không cho người dùng đóng form bằng việc click vào nút "X"
_Private Sub UserForm_Initialize()
Các thao tác khi khởi tạo form như:
+Kiểm tra nếu ứng dụng không phải tên theo yêu cầu thì thoát.
+Kiểm tra kết nối CSDL, nếu không được thì cũng không hiện form.
_Private Sub cmdLogIn_Click()
Thực hiện khi người dùng click vào nút cmdLogIn
_Private Sub cmdThoat_Click()
Thực hiện khi người dùng click vào nút cmdThoat

Lê Văn Duyệt

 

[levanduyet]

Xây dựng form log-in

Trong ví dụ trên tôi có dùng MsgboxUni của Tuân và hàm VNI của Bình OverAC.
Nếu bảng dữ liệu trong Ms Access bạn thiết kế đầy đủ thì các bạn có thể phân quyền ở đây.

Tôi xin giới thiệu các hàm hổ trợ:

_Hàm lấy quyền của người dùng

Public Function GetUserRight(ByVal UserName As String) As String
Dim rs         As ADODB.Recordset
Dim strSQL     As String
    On Error GoTo GetUserRight_Error
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    If gcnAccess.state = ObjectStateEnum.adStateClosed Then
        Call ConnectToDatabase
    End If
    'Then get the data
    If gcnAccess.state = ObjectStateEnum.adStateClosed Then
        gcnAccess.Open
    End If
    strSQL = "SELECT Right " & _
             "FROM TB_Users " & _
             "WHERE User = '" & UserName & "';"
    Set rs = New ADODB.Recordset
    rs.CursorType = adOpenStatic
    rs.Open strSQL, gcnAccess

    If rs.RecordCount = 0 Then
        GetUserRight = ""
    Else
        GetUserRight = rs.Fields(0)
    End If

ErrorExit:
    If gcnAccess.state = ObjectStateEnum.adStateOpen Then
        gcnAccess.Close
    End If
    If IsNull(rs) Then
        If rs.state = adStateOpen Then
            rs.Close
            Set rs = Nothing
        End If
    End If
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = True
    End With
    Exit Function

GetUserRight_Error:
    If bCentralErrorHandler("DataUltilities", "GetUserRight", , False) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If
End Function

Chú ý: các bạn có thể hoàn chỉnh hàm này.

_Hàm kiểm tra tên người dùng có tồn tại hay không?

Public Function UserExist(UserName As String) As String
Dim rs         As ADODB.Recordset
Dim strSQL     As String

    On Error GoTo UserExist_Error
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    If gcnAccess.state = ObjectStateEnum.adStateClosed Then
        Call ConnectToDatabase
    End If
    'Then get the data
    If gcnAccess.state = ObjectStateEnum.adStateClosed Then
        gcnAccess.Open
End if
        strSQL = "SELECT User " & _
                 "FROM TB_Users " & _
                 "WHERE User = '" & UserName & "';"
        Set rs = New ADODB.Recordset
        rs.CursorType = adOpenStatic
        rs.Open strSQL, gcnAccess

        If rs.RecordCount = 0 Then
            UserExist = ""
        Else
            UserExist = rs.Fields(0)
        End If
  
ErrorExit:
    If gcnAccess.state = ObjectStateEnum.adStateOpen Then
        gcnAccess.Close
    End If
    If IsNull(rs) Then
        If rs.state = adStateOpen Then
            rs.Close
            Set rs = Nothing
        End If
    End If
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = True

    End With
    Exit Function

UserExist_Error:
    If bCentralErrorHandler("DataUltilities", "UserExist", , False) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If
End Function

Lê Văn Duyệt

 

[levanduyet]

Xây dựng form thay đổi mật khẩu

Bây giờ chúng ta xây dựng một form nhằm giúp người dùng có thể tự thay đổi mật khẩu.

Code của form như sau:

Option Explicit

Private Sub cmdCancel_Click()
End
End Sub

Private Sub cmdChangePw_Click()
Dim sUserName  As String
Dim sPass As String, sPassComp As String, sNewPass As String
Dim rs As ADODB.Recordset, sSQL As String
    On Error GoTo cmdChangePw_Click_Error
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    sUserName = Me.txtUserName.Text
    If UserExist(sUserName) = "" Then
        MsgBoxUni VNI("Teân truy caäp khoâng ñuùng." & vbCrLf & _
                      "Baïn phaûi truy caäp tröôùc khi" & vbCrLf & _
                      "söû duïng coâng cuï naøy."), vbOKOnly, VNI("Thoâng baùo")
        With Application
            .Calculation = xlCalculationManual
            .ScreenUpdating = True
        End With
        Exit Sub
    End If

    Call ConnectToDatabase
    If bConnected = False Then
        MsgBoxUni VNI("Can not connect to database." & vbNewLine & _
                      "Please contact administrator." & vbNewLine & _
                      "Khoâng theå keát noái vôùi CSDL!" & vbCrLf & _
                      "Xin baïn kieåm tra laïi!"), vbOKOnly, VNI("Thoâng baùo")
        With Application
            .Calculation = xlCalculationManual
            .ScreenUpdating = True
        End With
        End    'Do not show form
    End If
    sNewPass = Me.txtNewPass.Text
    sPassComp = Me.txtOldPass.Text
    sPass = GetUserPassword(sUserName)
    If sPass = sPassComp Then
        sSQL = "UPDATE TB_Users " & _
               "SET  Pass='" & sNewPass & "' " & _
               "WHERE User='" & sUserName & "' ;"
        Set rs = New ADODB.Recordset
        If gcnAccess.state = ObjectStateEnum.adStateClosed Then
            gcnAccess.Open
        End If
        rs.Open sSQL, gcnAccess, adOpenKeyset, adLockOptimistic
        MsgBoxUni VNI("Baïn ñaõ caäp nhaät maät khaåu thaønh coâng."), vbOKOnly, VNI("Thoâng baùo")
        Set rs = Nothing
        With Application
            .Calculation = xlCalculationManual
            .ScreenUpdating = True
        End With
        End
    Else
        MsgBoxUni VNI("Xin nhaäp laïi maät khaåu."), vbOKOnly, VNI("Thoâng baùo")
        Me.txtOldPass.Text = ""
        Me.txtNewPass.Text = ""
        Me.txtOldPass.SetFocus
    End If

ErrorExit:
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = True
    End With
    Exit Sub

cmdChangePw_Click_Error:
    MsgBoxUni VNI("Baïn ñaõ caäp nhaät maät khaåu khoâng thaønh coâng." & vbCrLf & _
                  "Xin kieåm tra laïi!"), vbOKOnly, VNI("Thoâng baùo")
    If bCentralErrorHandler("frmChangePw", "cmdChangePw_Click", , False) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If

End Sub

Private Sub UserForm_Initialize()
Dim sUserName  As String
    On Error GoTo UserForm_Initialize_Error
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    Me.Caption = VNI("Thay ñoåi maät khaåu")
    If Application.ActiveWorkbook.Name <> sWorkbookName Then
        MsgBoxUni VNI("This tool is active only" & vbNewLine & _
                      "The active workbook is " & sWorkbookName & vbNewLine & _
                      "Chöùc naêng naøy chæ cho workbook" & vbNewLine & _
                      sWorkbookName), vbOKOnly, VNI("Thoâng baùo")
        With Application
            .Calculation = xlCalculationManual
            .ScreenUpdating = True
        End With
        End    'Do not show form
    End If
    Call ConnectToDatabase
    If bConnected = False Then
        MsgBoxUni VNI("Can not connect to database." & vbNewLine & _
                      "Please contact administrator." & vbNewLine & _
                      "Khoâng theå keát noái vôùi CSDL!" & vbCrLf & _
                      "Xin baïn kieåm tra laïi!"), vbOKOnly, VNI("Thoâng baùo")
        With Application
            .Calculation = xlCalculationManual
            .ScreenUpdating = True
        End With
        End    'Do not show form
    End If

    sUserName = Application.Range("UserName").Value
    If Len(Trim(sUserName)) = 0 Then
        MsgBoxUni VNI("Baïn phaûi nhaäp tröôùc khi söû duïng."), vbOKOnly, VNI("Thoâng baùo")
        With Application
            .Calculation = xlCalculationManual
            .ScreenUpdating = True
        End With
        End    'Do not show form
    End If
    Me.txtUserName.Text = sUserName
ErrorExit:
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = True
    End With
    Exit Sub

UserForm_Initialize_Error:
    If bCentralErrorHandler("frmChangePw", "UserForm_Initialize", , False) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If

End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
'Do not allow the user close the form by clicking the X button
    If CloseMode = vbFormControlMenu Then
        Cancel = True
    End If
End Sub

Chúng ta có các thủ tục sau:
_Private Sub cmdCancel_Click()
Khi người dùng chọn nút này thì đóng form và thoát
_Private Sub cmdChangePw_Click()
Thủ tục này nhằm:
+Kiểm tra nếu tên người dùng không tồn tại thì cũng thoát.
+Kết nối với CSDL: nếu không kết nối được thì cũng thoát.
+So sánh Password cũ với password trong hệ thống. Nếu trùng thì chúng ta mới tiến hành cập nhật password mới. Password mới cho phép là chuổi rổng.

_Private Sub UserForm_Initialize()
Tương tự như phần giải thích đối với form truy nhập CSDL.
_Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

Như vậy ứng dụng của chúng ta sẽ linh động hơn.

Lê Văn Duyệt