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

Liên hệ QC

lethanhnhan

Thành viên chính thức
Tham gia
27/5/07
Bài viết
76
Được thích
249
Chào các bạn,
Sử dụng Excel, cũng lắm lúc các bạn cảm thấy chán ! Tại sao? Chắc có lẻ vì:
_ File Excel càng ngày lại càng lớn.
_ Xử lý thông tin với số lượng nhiều record thì lại quá lâu.
_ Bảo mật cũng...không tốt lắm.
_ Phân quyền thì cũng ... chán.
Vâng và các bạn có thể liệt kê nhiều nguyên nhân nữa.
Còn Access thì sao?
Vấn đề này đã khiến một số người dùng Access chán cái thằng cha Excel.
Vậy tại sao chúng ta không phối hợp dùng Excel và Access để tận dụng thế mạnh lẫn nhau?

Tôi xin giới thiệu giải pháp của tôi cho vấn đề này.
1. Dựa trên dữ liệu tôi cần lưu trữ tôi sẽ thiết kế file database trên Access.
2. Dùng kỹ thuật ADO để kết nối với dữ liệu.
3. Thiết kế các form nhập liệu, các thủ tục cần thiết cho công việc.
4. Các công cụ nâng cao liên quan đến cơ sở dữ liệu.

Vài bước mạn phép cùng các Lập trình viên

Đầu tiên tôi sử dụng một module để sử lý lỗi:
Mã:
Option Explicit
'Source code from Professional Excel Development
Public Const gbDEBUG_MODE As Boolean = False
Public Const glHANDLED_ERROR As Long = 9999
Public Const glUSER_CANCEL As Long = 18

Private Const msSILENT_ERROR As String = "UserCancel"
Private Const msFILE_ERROR_LOG As String = "Error.log"
Private Const gsAPP_TITLE As String = "NOTICE"

Public Function [B]bCentralErrorHandler[/B]( _
       ByVal sModule As String, _
       ByVal sProc As String, _
       Optional ByVal sFile As String, _
       Optional ByVal bEntryPoint As Boolean) As Boolean

    Static sErrMsg As String

    Dim iFile As Integer
    Dim lErrNum As Long
    Dim sFullSource As String
    Dim sPath As String
    Dim sLogText As String

    ' Grab the error info before it's cleared by
    ' On Error Resume Next below.
    lErrNum = err.Number
    ' If this is a user cancel, set the silent error flag
    ' message. This will cause the error to be ignored.
    If lErrNum = glUSER_CANCEL Then sErrMsg = msSILENT_ERROR
    ' If this is the originating error, the static error
    ' message variable will be empty. In that case, store
    ' the originating error message in the static variable.
    If Len(sErrMsg) = 0 Then
        sErrMsg = err.Description
        sErrMsg = err.Number & "| " & sErrMsg
    End If
    ' We cannot allow errors in the central error handler.
    On Error Resume Next

    ' Load the default filename if required.
    If Len(sFile) = 0 Then sFile = ThisWorkbook.Name

    ' Get the application directory.
    sPath = ThisWorkbook.Path
    If Right$(sPath, 1) <> "\" Then sPath = sPath & "\"

    ' Construct the fully-qualified error source name.
    sFullSource = "[" & sFile & "]" & sModule & "." & sProc

    ' Create the error text to be logged.
    sLogText = "  " & sFullSource & ", Error " & _
               CStr(lErrNum) & ": " & sErrMsg

    ' Open the log file, write out the error information and
    ' close the log file.
    iFile = FreeFile()
    Open sPath & msFILE_ERROR_LOG For Append As #iFile
    Print #iFile, Format$(Now(), "mm/dd/yy hh:mm:ss"); sLogText
    If bEntryPoint Then Print #iFile,
    Close #iFile

    ' Do not display silent errors.
    If sErrMsg <> msSILENT_ERROR Then

        ' Show the error message when we reach the entry point
        ' procedure or immediately if we are in debug mode.
        If bEntryPoint Or gbDEBUG_MODE Then
            Application.ScreenUpdating = True
            MsgBox sErrMsg, vbCritical, gsAPP_TITLE
            ' Clear the static error message variable once
            ' we've reached the entry point so that we're ready
            ' to handle the next error.
            sErrMsg = vbNullString
        End If

        ' The return value is the debug mode status.
        bCentralErrorHandler = gbDEBUG_MODE

    Else
        ' If this is a silent error, clear the static error
        ' message variable when we reach the entry point.
        If bEntryPoint Then sErrMsg = vbNullString
        bCentralErrorHandler = False
    End If

End Function
Tôi sẽ giới thiệu tiếp trong bài sau.

Lê Thanh Nhân
 
Dùng MZTool trợ giúp bạn

Bài 2.
Trong lập trình VBA, việc sử dụng code và chia sẻ code xem ra khó khăn.
Tôi xin giới thiệu sơ lược việc sử dụng công cụ MZTool này nhằm giúp cho công việc lập trình của bạn "dễ thở " hơn.
Đầu tiên bạn cần download MzTool cho VBA (miễn phí) từ trang:
http://www.mztools.com/index.htm
Tại đây còn có công cụ miễn phí MzTool cho Visual Basic 6.0
Khi download về các bạn cài đặt vào máy. Cứ theo hướng dẫn mà cài đặt. Sau khi công việc cài đặt kết thúc, bạn có thể dùng công cụ này trong VBE được rồi.

Mở một file Excel, nhấn tổ hợp phím Alt + F11 để vào màn hình VBE. Bạn sẽ thấy menu của công cụ này. Hoặc bạn có thể Click phải chuột vào màn hình sọan thảo code.

Menu.jpg

Shorcut_Menu.jpg


Chúng ta sẽ khám phá các thành phần cơ bản của Mztool.

Lê Thanh Nhân
 
Các công cụ của MzTool có thể liệt kê như sau:

_Find: tìm kiếm (tương tự như khi bạn nhấn tổ hợp phím Crlt + F)
_Procedure caller: gọi hàm hay thủ tục.
--------------------------------------
_Add Procedure: thêm vào procedure
_Add Code Template: thêm vào đọan mã bạn đã lưu lại
--------------------------------------
_Add Module Header: thêm vào tiêu đề cho module. Ví dụ như ngày tạo ra module. Chức năng của module, Ngày sửa, Giải thích về module này.
_Add Procedure Header: tương tự như ở trên nhưng cho Procedure.
_Add Error Hander: đưa vào bẫy lỗi.
_Add Both: đưa vào cả hai
--------------------------------------
_Add Line Numbers: nhằm giúp cho việc đọc mã được dễ dàng hơn bằng việc đánh số thứ tự vào trước mỗi hàng đọan mã của bạn.
_Remove Line Numbers: ngược lại với phần trên
--------------------------------------
_Split Lines: tách các dòng ra
_Combine Lines: kết hợp các dòng lại
--------------------------------------
_Add Current Procedure To Favourites: thêm procedure hiện tại vào Favourite
_Go To Favourite Procedure: đi đến Procedure bạn đã thêm vào ở trên
--------------------------------------
Những chức năng khác các bạn tham khảo hình vẽ.
ProcedureCaller.jpg


Các bạn có thể Click vào biểu tượng hình "cây búa và đinh vít" để sọan thảo trước khi sử dụng.
Tools.jpg

Các bạn hãy tự khám phá. Tôi chỉ xin giới thiệu một vài chức năng chính.


Lê Thanh Nhân
 
_Tab Error Hander:
Ở tab này các bạn sẽ thíêt kế mẫu bẫy lỗi mà bạn sẽ sử dụng.
TabErrorhander.jpg

Như hình trên bạn có thể thêm vào mẫu bẫy lỗi của mình.

Mã:
On Error GoTo {PROCEDURE_NAME}_Error
   With Application
      .Calculation = xlCalculationManual
      .ScreenUpdating = False
   End With
    {PROCEDURE_BODY}

ErrorExit:
   With Application
      .Calculation = xlCalculationManual
      .ScreenUpdating = True
   End With   
   Exit {PROCEDURE_TYPE}

{PROCEDURE_NAME}_Error:
If bCentralErrorHandler("{MODULE_NAME}","{PROCEDURE_NAME}" , , False) Then
     Stop
     Resume
Else
     Resume ErrorExit
End If
Tôi sẽ lần lượt nhập vào
Mã:
On Error GoTo
và click chọn combobox variables chọn Module Name, sau đó Click nút Add
bạn sẽ thấy như đọan mã sau:
Mã:
On Error GoTo {PROCEDURE_NAME}
bạn nhập tiếp "_Error", sau đó xuống hàng.
Bạn để ý PROCEDURE_NAME được bao bọc bởi {}, điều này có nghĩa chương trình sẽ thêm tự động tên của Procedure name hiện tại vào.
Trong combobox variables có các biến sau:
_Module name
_Module type
_Procedure body
_Procedure type
_Procedure Return Type Name
_Procedure Return Type Prefix
_Procedure Type
_Project Name
Sau khi bạn định nghĩa ở đây, khi cần đưa vào bẫy lỗi bạn chỉ cần Click vào toolbar button hay click phải vào menu MZTool và chọn Add Error Hander
Tương tự các bạn có thể khám phá ở các Tab khác.

Ở đây chúng ta có một Tab quan "hay hay" là tab "Code Templates"
Với tab này nó sẽ giúp ích cho bạn rất nhiều trong việc tiết kiệm thời gian viết mã.
Ở tab này bạn có thể:
_Add: thêm vào đọan mã trong "thư viện"
_Edit: sửa đọan mã trong "thư viện"
_Remove: xóa đọan mã "thư viện"
Muốn thêm đọan mã vào thư viện bạn chỉ việc click vào nút Add bên dưới. Khi bạn click Add, một form sẽ hiện ra giúp bạn thao tác để tạo ra đọan mã như: đặt tên, shortcut.
TabCodeTemplate.jpg

Bạn có thể copy và paste vào textbox text. Cuối cùng công việc bạn cần làm là click OK.
CodeTemFill.jpg


Các bạn thao tác tương tự với hai chức năng còn lại.
Một khi bạn đã thêm mã vào thư viện, bạn có thể gọi chúng ra cho các dự án khác của bạn bằng việc click phải ở màn hình VBE vào menu MZTool và chọn Add Code Template. Một form sẽ hiện ra giúp bạn chọn code template và đưa vào dự án của mình.

Lê Thanh Nhân
 
Nói thêm: MXTool sẽ lưu trữ đọan mã của bạn trong File
C:\Program Files\MZTools3VBA\MZTools3vba.ini
Các bạn có thể mở file này xem cách bố trí, lưu trữ của MZTool.
Các bạn cũng có thể xây dựng công cụ nhằm chia sẻ các đọan mã với nhau thông qua công cụ MZTool này.
Bây giờ chúng ta hãy trở về với việc xây dựng ứng dụng của mình.
Nhằm làm cho chương trình "giả lập" phân cấp người dùng chúng ta sẽ bắt buộc người dùng log-in vào mỗi khi mở file Excel. Nếu người dùng không đồng ý log-in vào thì...he he he...thóat. Với việc bắt buộc này bạn có thể phân cấp người dùng với những transaction cần thiết và ghi nhận việc thao tác với cơ sở dữ liệu. Chúng ta cũng có thể biết được ai đang truy cập vào cơ sở dữ liệu và đang thực hiện transaction gì. Việc phân cấp chúng ta sẽ để trong một bảng của Access.
Đọan mã của frmLogIn như sau:
Mã:
Option Explicit
Dim iCount As Long
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
        MsgBox "You have enter more than " & iCount & " times!" & vbCrLf & _
               "Pls, contact your Administrator.", vbOKOnly, "Inf"
        End
    End If
    sUserName = txtTenTruyCap.Text
    sUserSoSanh = UserExist(sUserName)
    'Check the user name
    If Len(Trim(sUserSoSanh)) = 0 Then
        MsgBox "This user does not exist!", vbOKOnly, "Inf"
        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
            MsgBox "Welcome to             " & vbCrLf & _
                   "STOCK COUNT HELPER TOOL " & vbCrLf & _
                   "Author: Le Van Duyet" & vbCrLf & _
                   "You have accessed with " & sRight & " right.", vbOKOnly, "Inf"
            Application.Range("UserName").Value = sUserSoSanh
        Else
            MsgBox "Welcome to             " & vbCrLf & _
                   "STOCK COUNT HELPER TOOL " & vbCrLf & _
                   "Author: Le Van Duyet" & vbCrLf & _
                   "You have accessed with " & "?" & " right.", vbOKOnly, "Inf"
            iCount = iCount + 1
            Application.Range("UserName").Value = sUserSoSanh
        End If
    ElseIf Len(Trim(sUserSoSanh)) > 0 Then
        MsgBox "Wrong Password !" & vbCrLf & _
               "Pls enter again.", vbOKOnly, "Inf"
        txtPass.Text = ""
        txtPass.SetFocus
        iCount = iCount + 1
        Exit Sub

    End If

    If sRight = "Admin" And Len(Trim(sUserSoSanh)) > 0 Then
        'Neu quyen la admin thi se mo cac sheet
        'de cap nhat du lieu
        Call ActionB4CloseOpen("ACCESSDATA")
        Me.Hide
    ElseIf Len(Trim(sUserSoSanh)) > 0 Then
        MsgBox "You can only enter data!", vbOKOnly, "Inf"
        Call ActionB4CloseOpen("OPEN")
        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_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
Trên form này chúng ta có hai textbox là txtPass:ghi nhận pass người dùng nhập vào. txtTenTruyCap: ghi nhận tên truy cập. Với textbox txtPass bạn chú ý thiết lập thuộc tính PassWordChar là True.
Login.jpg



Một thao tác để xử lý dữ liệu có thể nói đơn giản như sau:
_Kết nối cơ sở dữ liệu nếu được thì hiện Form giúp người dùng nhập liệu hay thao tác với dữ liệu. Nếu không sẽ thông báo và thóat. Như vậy bảo đảm rằng khi không kết nối với cơ sở dữ liệu thì người dùng sẽ không thể làm gì được.
_Bẫy lỗi trên form khi người dùng nhập dữ liệu vào. Việc bẫy lỗi này là quan trọng nhằm tránh lỗi xẫy ra khi bạn Thêm/Cập nhật hay Xóa.
_Thêm/Cập nhật/Xóa record.

Lê Thanh Nhân
 
Xây dựng các thủ tục kết nối với cơ sở dữ liệu.
Ở đây tôi xin lấy ví dụ dùng DSN trong chuỗi kết nối của connection để kết nối.
Thủ tục kết nối
Mã:
Public Sub ConnectToDatabase()
    Const msMODULE As String = "MainModule"        '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
Chú ý rằng để sử dụng đối tượng connection cho tòan bộ dự án của bạn, bạn nên khai báo Public như đọan mã sau:
Mã:
Option Explicit

'Declare the Public variance
Public gcnAccess As New ADODB.Connection    'Global connection Access
Public bConnected As Boolean    'To let's you know the status of the connection
Thủ tục trên sẽ kết nối với cơ sở dữ liệu có DNS: WareHouseDB, với quyền Admin, không có Password.
Nếu kết nối thành công thì biến bConnected sẽ được đặt là TRUE, hoặc ngược lại. Biến này sẽ giúp ta trong việc kiểm tra kết nối trước khi thực hiện các giao dịch.
Hàm GetUserPassword dưới đây sẽ giúp bạn lấy password của người dùng khi họ nhập vào tên truy cập. Chú ý, tên truy cập và Password được đặt trong bảng tbUsers. Tương tự bạn có thể viết một hàm để lấy về quyền truy cập đối với một form, hoặc transaction.
Mã:
Public Function GetUserPassword(UserName As String) As String
    Dim rs As ADODB.Recordset
    Dim strSQL As String

    On Error GoTo GetUserPassword_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
        strSQL = "SELECT Pass " & _
                 "FROM tbUsers " & _
                 "WHERE User = '" & UserName & "';"
        Set rs = New ADODB.Recordset
        rs.CursorType = adOpenStatic
        rs.Open strSQL, gcnAccess

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

ErrorExit:
    If gcnAccess.state = ObjectStateEnum.adStateOpen Then
        gcnAccess.Close
        bConnected = False
    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

GetUserPassword_Error:

    If bCentralErrorHandler("MainModule", "GetUserPassword", , False) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If
End Function

Lê Thanh Nhân
 
Bây giờ chúng ta hãy bắt đầu thiết kế một form nhập liệu.
NhapLieu.jpg


Trên form nhập liệu này tôi không muốn người dùng thóat bằng cách nhấn nút Close, tôi dùng đọan mã sau:
Mã:
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
'The purpose that Do not allow the user close the application
'by Click the X button on the Form
'Muc dich khong cho nguoi dung dong Form theo cach nay
    If CloseMode = vbFormControlMenu Then
        Cancel = True
    End If
End Sub

Mã:
Private Sub UserForm_Initialize()
Dim sDate As String
'Kiem tra xem co the connect vao file du lieu khong
'Neu khong duoc thi thong bao va Thoat
'Check the connection to the database first before doing anything

    On Error GoTo UserForm_Initialize_Error
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = 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
    sDate = Format$(Day(Now()) & "/" & Month(Now()) & "/" & Year(Now()), "dd/MM/yyyy")
    txtDate.Text = sDate
    'Chu y gia tri thuoc tinh Style cua Combobox la 2-fmStyleDropDownList
    'nham chi cho phep nguoi dung chon gia tri trong Combobox nay thoi
    cbbStoreLocation.ListIndex = 0
    cbbGoodsCond.ListIndex = 0
    Call InitialTheArrayColHeader    'Khoi tao chuoi ky tu cho Column Header
    Call RangeToListView(Me.LvMaSanPham, "tbMaterialsNumber", arrColHeaderTxt)
    'Close the Connection
    If gcnAccess.state = ObjectStateEnum.adStateOpen Then
        gcnAccess.Close
    End If
ErrorExit:
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = True
    End With
    Exit Sub

UserForm_Initialize_Error:
    If bCentralErrorHandler("frmNhapLieu", "UserForm_Initialize", , False) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If
End Sub
Ở sự kiện UserForm_Initialize, tôi sẽ kiểm tra kết nối cơ sở dữ liệu. Nếu kết nối không được sẽ thông báo vào thóat.
Trên form tôi có dùng Listview để thể hiện dữ liệu giúp người dùng nhập dữ liệu nhanh và tránh sai xót. (Dĩ nhiên tương đối thôi, nếu ngừơi dùng nhập vào 2,000 thay vì 200 thì ta cũng bó tay luôn :) )

Lê Thanh Nhân
 
Đọan mã đầy đủ của Form nhập liệu như sau:
Mã:
Option Explicit
Option Base 1
Private Sub cbbGoodsCond_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    If KeyAscii = vbKeyReturn Then
        txtGhiChu.SetFocus
    End If
End Sub

Private Sub cmdAbout_Click()
    frmabout.Show
End Sub

Private Sub cmdIntruction_Click()
    Call ShowIntroduction
End Sub

'You need to Ref to:
'MSCOMCT.OCX, MSCOMCT2.OCX

Private Sub cmdNhap_Click()
    Dim rsData As ADODB.Recordset
    Dim rsDataCount As Long
    Dim i As Long
    Dim It As ListItem
    Dim sPeriod As String, sDate As String, sItemCode As String, sDes As String
    Dim sQty As String, sStockCardNo As String, sRemarks As String, sStoreLoc As String
    Dim sUoM As String
    Dim bUpdateOK As Boolean
    Dim iGoodsCond As Variant
    Dim sDataEntryBy As String
    Dim sLock As String
    On Error GoTo cmdNhap_Click_Error
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    If Me.lvSanPhamNhap.ListItems.Count > 0 Then
        'Neu co san pham thi moi dua vao Co so du lieu
        sLock = GetDataLockStatus
        If UCase(sLock) = "TRUE" Then
            MsgBox "Database da bi khoa boi Administrator" & vbCrLf & _
                   "Xin cho mot ty !" & vbCrLf & _
                   "The data was locked by Administrator" & vbCrLf & _
                   "Please wait a minutes!", vbOKOnly, "Inf"
            Exit Sub
        Else
            If gcnAccess.state = ObjectStateEnum.adStateClosed Then
                Call ConnectToDatabase
                If gcnAccess.state = ObjectStateEnum.adStateClosed Then
                    gcnAccess.Open
                End If
                Set rsData = New ADODB.Recordset
                sTableInDBName = "tbMain"
                'The most common way to modify the contents of a record
                'is to open the recordset using these arguments
                'CursorType = adOpenKeySet
                'LockType   = adLockOptimistic
                rsData.Open sTableInDBName, gcnAccess, adOpenKeyset, adLockOptimistic, adCmdTable
                rsDataCount = Me.lvSanPhamNhap.ListItems.Count
                For i = 1 To rsDataCount
                    Set It = Me.lvSanPhamNhap.ListItems(i)
                    sDate = It.Text
                    With It
                        sItemCode = .SubItems(1)
                        sUoM = .SubItems(2)
                        sDes = .SubItems(3)
                        sQty = .SubItems(4)
                        sStockCardNo = .SubItems(5)
                        sRemarks = .SubItems(6)
                        sStoreLoc = .SubItems(7)
                        iGoodsCond = .SubItems(8)
                        sDataEntryBy = .SubItems(9)
                    End With
                    With rsData
                        .AddNew
                        .Fields("Date") = sDate
                        .Fields("ItemCode") = sItemCode
                        .Fields("UoM") = sUoM
                        .Fields("Descriptions") = sDes
                        .Fields("CountQty") = Val(sQty)
                        .Fields("StockCardNo") = sStockCardNo
                        .Fields("Location") = sStoreLoc
                        .Fields("Remarks") = sRemarks
                        .Fields("GoodsCondition") = iGoodsCond
                        .Fields("DataEntryBy") = sDataEntryBy
                        .Update
                    End With
                Next i
                lvSanPhamNhap.ListItems.Clear
                bUpdateOK = True
            End If
        End If
    Else
        MsgBox "Khong co gi de xuat, xin kiem lai!" & vbCrLf & _
               "There are nothing to export!" & vbCrLf & _
               "Please check !", vbOKOnly, "Inf"
    End If
    If bUpdateOK Then

        MsgBox "Xuat so lieu thanh cong!" & vbCrLf & _
               "Data was exported!", vbOKOnly, "Inf"
        txtMaSanPham.SetFocus
        txtMaSanPham.Text = IIf(bteMaterialDes = 1, txtDefTxt.Text, "")
        txtDvt.Text = ""
        txtSoTheKho.Text = ""
        txtMoTa.Text = ""
        txtGhiChu.Text = ""
    End If
    If gcnAccess.state = ObjectStateEnum.adStateOpen Then
        gcnAccess.Close
    End If

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

cmdNhap_Click_Error:
    If bCentralErrorHandler("frmNhapLieu", "cmdNhap_Click", , False) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If
End Sub

Private Sub cmdNhapTam_Click()
    Dim It As ListItem
    Dim sDate As String, sItemCode As String, sDes As String, sUoM As String
    Dim sQty As String, sStockCardNo As String, sRemarks As String, sStoreLoc As String
    Dim Ans As Variant, sA1 As String
    Dim iGoodsCond As Integer, sDataEntryBy As String
On Error GoTo cmdNhapTam_Click_Error
   With Application
      .Calculation = xlCalculationManual
      .ScreenUpdating = False
   End With
    sDate = Format$(Day(Now()) & "/" & Month(Now()) & "/" & Year(Now()), "dd/MM/yyyy")   'Get the value of the Data Picker Control
    sItemCode = txtMaSanPham.Text
    sUoM = txtDvt.Text
    sDes = txtMoTa.Text
    sQty = txtSoLuong.Text
    sStockCardNo = txtSoTheKho.Text
    sRemarks = txtGhiChu.Text
    sStoreLoc = cbbStoreLocation.Text
    iGoodsCond = IIf(cbbGoodsCond.ListIndex = 0, 1, IIf(cbbGoodsCond.ListIndex = 1, 2, 4))
    sDataEntryBy = Application.Range("UserName")
    If Len(Trim(sUoM)) = 0 Or Len(Trim(sDate)) = 0 Or _
       Len(Trim(sItemCode)) <> 10 Or Val(sQty) = 0 Or _
       Len(Trim(sStoreLoc)) = 0 Or Len(Trim(sStockCardNo)) = 0 Or _
       Len(Trim(sDataEntryBy)) = 0 Then
        'Trong truong hop can thiet
        'ban co the them vao viec kiem tra sStockCardNo
        MsgBox "Pls check your data!", vbOKOnly, "Info"
        Exit Sub
    End If
    Set It = lvSanPhamNhap.ListItems.ADD
    With It
        .Text = sDate
        .SubItems(1) = sItemCode
        .SubItems(2) = sUoM
        .SubItems(3) = sDes
        .SubItems(4) = sQty
        .SubItems(5) = sStockCardNo
        .SubItems(6) = sRemarks
        .SubItems(7) = sStoreLoc
        .SubItems(8) = iGoodsCond
        .SubItems(9) = sDataEntryBy
    End With

    txtMaSanPham.SetFocus
    txtMaSanPham.Text = IIf(bteMaterialDes = 1, txtDefTxt.Text, "")
    txtDvt.Text = ""
    txtMoTa.Text = ""
    txtSoLuong.Text = ""
    Ans = MsgBox("Do you want to keep" & vbCrLf & _
                 " Stock Card Number", vbOKCancel, "Inf")

    If Ans <> vbOK Then
        txtSoTheKho.Text = ""
        txtGhiChu.Text = ""
    End If
    

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

cmdNhapTam_Click_Error:
If bCentralErrorHandler("frmNhapLieu", "cmdNhapTam_Click", , False) Then
     Stop
     Resume
Else
     Resume ErrorExit
End If


End Sub

Private Sub cmdThoat_Click()
    On Error GoTo cmdThoat_Click_Error
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False

    End With
    'Close the Connection before Close the Form
    If gcnAccess.state = ObjectStateEnum.adStateOpen Then
        gcnAccess.Close
    End If

ErrorExit:
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = True
        .StatusBar = False
    End With
    End

cmdThoat_Click_Error:
    If bCentralErrorHandler("frmNhapLieu", "cmdThoat_Click", , False) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If


End Sub

Private Sub LvMaSanPham_Click()
'Moi khi Click vao ListView thi
'se dua muc duoc chon vao Textbox
    On Error Resume Next
    If bteMaterialDes = 1 Then

        With Me.LvMaSanPham
            txtMaSanPham.Text = .SelectedItem.Text
            txtDvt.Text = .SelectedItem.ListSubItems(1)
            txtMoTa.Text = .SelectedItem.ListSubItems(2)
        End With
    Else
        With Me.LvMaSanPham
            txtMaSanPham.Text = .SelectedItem.ListSubItems(2)
            txtDvt.Text = .SelectedItem.ListSubItems(1)
            txtMoTa.Text = .SelectedItem.Text
        End With
    End If
    Me.LvMaSanPham.Sorted = True
End Sub

Private Sub LvMaSanPham_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
    If ColumnHeader.Index <> 1 And ColumnHeader.Index <> 3 Then
        frmFilter.LvMaSanPham.ListItems.Clear
        'Set the value for the array of column header text
        Call InitialTheArrayColHeader(bteMaterialDes)
        Call RangeToListView(frmFilter.LvMaSanPham, "tbMaterialsNumber", arrColHeaderTxt)
        frmFilter.Show
    Else
        bteMaterialDes = IIf(bteMaterialDes = 1, 2, 1)
        Call TransposeItemcodeAndDes(Me.LvMaSanPham)
    End If

End Sub

Private Sub LvMaSanPham_KeyUp(KeyCode As Integer, ByVal Shift As Integer)
    On Error Resume Next
    If bteMaterialDes = 1 Then
        With Me.LvMaSanPham
            txtMaSanPham.Text = .SelectedItem.Text
            txtDvt.Text = .SelectedItem.ListSubItems(1)
            txtMoTa.Text = .SelectedItem.ListSubItems(2)
        End With
    Else
        With Me.LvMaSanPham
            txtMaSanPham.Text = .SelectedItem.ListSubItems(2)
            txtDvt.Text = .SelectedItem.ListSubItems(1)
            txtMoTa.Text = .SelectedItem.Text
        End With
    End If
    If KeyCode = vbKeyReturn Then
        txtSoLuong.SetFocus
    End If
End Sub

Lê Thanh Nhân
 
Mã:
Private Sub lvSanPhamNhap_Click()
    On Error Resume Next
    If Me.lvSanPhamNhap.SelectedItem.Index <> -1 Then
        'In the case selected then action

        With Me.lvSanPhamNhap
            txtMaSanPham.Text = .SelectedItem.ListSubItems(1)
            txtDvt.Text = .SelectedItem.ListSubItems(2)
            txtMoTa.Text = .SelectedItem.ListSubItems(3)
        End With

    End If
End Sub

Private Sub lvSanPhamNhap_DblClick()
    On Error Resume Next
    If Me.lvSanPhamNhap.SelectedItem.Index <> -1 Then
        'In the case selected then action
        Me.lvSanPhamNhap.ListItems.Remove lvSanPhamNhap.SelectedItem.Index
    End If
End Sub

Private Sub txtCounter_AfterUpdate()
    txtCounter.Text = UCase(txtCounter.Text)
End Sub

Private Sub txtCounter_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
'Tuc la khong cho nhap so
    If KeyAscii >= 48 And KeyAscii <= 57 Then
        KeyAscii = 0
    End If
End Sub

Private Sub txtDefTxt_AfterUpdate()
Dim sDefText As String, sItemCode As String
sItemCode = Me.txtMaSanPham.Text
sDefText = Me.txtDefTxt.Text
If Len(sItemCode) > Len(sDefText) Then
    Me.txtMaSanPham.Text = sDefText & Mid(sItemCode, Len(sDefText) + 1, Len(sItemCode) - Len(sDefText))
Else
    Me.txtMaSanPham.Text = sDefText
End If

End Sub

Private Sub txtDefTxt_Change()
Dim sDefText As String, sItemCode As String
sItemCode = Me.txtMaSanPham.Text
sDefText = Me.txtDefTxt.Text
If Len(sItemCode) > Len(sDefText) Then
    Me.txtMaSanPham.Text = sDefText & Mid(sItemCode, Len(sDefText) + 1, Len(sItemCode) - Len(sDefText))
Else
    Me.txtMaSanPham.Text = sDefText
End If

End Sub

Private Sub txtDefTxt_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Dim sDefText As String
sDefText = Me.txtDefTxt.Text
If Len(sDefText) < 9 Then
    Select Case KeyAscii
    Case Asc("0") To Asc("9")
        'Chang lam gi ca

    Case Else
        'Cac ky tu khac thi khong cho phep nhap
        KeyAscii = 0
    End Select
Else
    KeyAscii = 0
End If
End Sub

Private Sub txtMaSanPham_AfterUpdate()
    Dim sItemCode As String, sItemCodeComparision As String
    Dim Ans As Variant
    On Error Resume Next
    sItemCode = Me.txtMaSanPham.Text

    If bteMaterialDes = 1 Then
        With Me.LvMaSanPham
            sItemCodeComparision = .SelectedItem.Text
            If sItemCode <> Left(sItemCodeComparision, Len(sItemCode)) Then
                Ans = MsgBox("Your material code is " & sItemCode & vbCrLf & _
                             "is diff from " & sItemCodeComparision & vbCrLf & _
                             "Please take note", vbOKOnly, "Inf")
                If Ans = vbOK Then
                    txtMaSanPham.Text = .SelectedItem.Text
                    txtMoTa.Text = .SelectedItem.ListSubItems(2)
                    txtDvt.Text = .SelectedItem.ListSubItems(1)
                End If
            Else
                txtMaSanPham.Text = .SelectedItem.Text
                txtMoTa.Text = .SelectedItem.ListSubItems(2)
                txtDvt.Text = .SelectedItem.ListSubItems(1)
            End If
        End With
    Else
        With Me.LvMaSanPham
            sItemCodeComparision = .SelectedItem.ListSubItems(2)
            If sItemCode <> Left(sItemCodeComparision, Len(sItemCode)) Then
                Ans = MsgBox("Your material code is " & sItemCode & vbCrLf & _
                             "is diff from " & sItemCodeComparision & vbCrLf & _
                             "Please take note", vbOKOnly, "Inf")
                If Ans = vbOK Then
                    txtMaSanPham.Text = .SelectedItem.ListSubItems(2)
                    txtDvt.Text = .SelectedItem.ListSubItems(1)
                    txtMoTa.Text = .SelectedItem.Text

                End If
            Else
                txtMaSanPham.Text = .SelectedItem.ListSubItems(2)
                txtDvt.Text = .SelectedItem.ListSubItems(1)
                txtMoTa.Text = .SelectedItem.Text

            End If
        End With
    End If
End Sub



Private Sub txtMaSanPham_Change()
    Dim sItemCode As String
    Dim It As ListItem
    On Error Resume Next
    Set It = ListViewFindItem(txtMaSanPham.Text, LvMaSanPham, elvSearchText)
End Sub

Private Sub txtMaSanPham_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    If bteMaterialDes = 1 Then
        'Set the length of the Material Number
        If Len(txtMaSanPham) < 10 Then
            Select Case KeyAscii
            Case Asc("0") To Asc("9")
                'Chang lam gi ca/Do nothing
            Case Else
                'Cac ky tu khac thi khong cho phep nhap/Do not allow for entering other
                KeyAscii = 0
            End Select
        Else
            KeyAscii = 0
        End If
    End If
End Sub

Private Sub txtSoLuong_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    Select Case KeyAscii
    Case Asc("0") To Asc("9")
        'Chang lam gi ca
    Case Asc("-")
        If InStr(1, Me.txtSoLuong.Text, "-") > 0 Or Me.txtSoLuong.SelStart > 0 Then
            'Neu dau tru khong nam o dau chuoi thi khong nhap
            KeyAscii = 0
        End If
    Case Asc(".")
        If InStr(1, Me.txtSoLuong.Text, ".") > 0 Then
            'Neu co dau cham thu hai thi khong nhap
            KeyAscii = 0
        End If
    Case Else
        'Cac ky tu khac thi khong cho phep nhap
        KeyAscii = 0
    End Select
End Sub

Private Sub txtSoTheKho_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
'Tuc la chi cho nhap so ma thoi
    If KeyAscii < 48 Or KeyAscii > 57 Then
        KeyAscii = 0
    End If
End Sub


Private Sub UserForm_Initialize()
Dim sDate As String
'Kiem tra xem co the connect vao file du lieu khong
'Neu khong duoc thi thong bao va Thoat
'Check the connection to the database first before doing anything

    On Error GoTo UserForm_Initialize_Error
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = 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
    sDate = Format$(Day(Now()) & "/" & Month(Now()) & "/" & Year(Now()), "dd/MM/yyyy")
    txtDate.Text = sDate
    'Chu y gia tri thuoc tinh Style cua Combobox la 2-fmStyleDropDownList
    'nham chi cho phep nguoi dung chon gia tri trong Combobox nay thoi
    cbbStoreLocation.ListIndex = 0
    cbbGoodsCond.ListIndex = 0
    Call InitialTheArrayColHeader    'Khoi tao chuoi ky tu cho Column Header
    Call RangeToListView(Me.LvMaSanPham, "tbMaterialsNumber", arrColHeaderTxt)
    'Close the Connection
    If gcnAccess.state = ObjectStateEnum.adStateOpen Then
        gcnAccess.Close
    End If
ErrorExit:
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = True
    End With
    Exit Sub

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

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
'The purpose that Do not allow the user close the application
'by Click the X button on the Form
'Muc dich khong cho nguoi dung dong Form theo cach nay
    If CloseMode = vbFormControlMenu Then
        Cancel = True
    End If
End Sub
Khi đóng form, sẽ đóng luôn kết nối, giải phóng tài nguyên.

Lê Thanh Nhân
 
Cũng như Excel, file database của Access sau một thời gian sử dụng, dung lượng cũng rất lớn bạn cần phải compact dữ liệu lại. Làm thế nào để làm từ Excel?
Các bạn hãy sử dụng đọan code sau:
Mã:
'---------------------------------------------------------------------------------------
' Procedure : CompactAccDB
' DateTime  : 13/05/2007 11:07
' Author    : levanduyet
' Purpose   : Compact the Access Database
' References: Microsoft Access 11.0 Object Library
'             C:\Program Files\Microsoft Office\OFFICE11\MSACC.OLB
'---------------------------------------------------------------------------------------
'
Public Sub CompactAccDB()
    Dim sFilePath As Variant
    Dim sOldName As String, sNewName As String
    Dim sPathOnly As String
    On Error GoTo CompactAccDB_Error

    sFilePath = Application.GetOpenFilename("Access Files,*.mdb,All Files,*.*", 1, "Pls chose the file", , False)
    If Len(sFilePath) < 6 Then
        If sFilePath = False Then
            MsgBox "You have chose Cancel.", vbOKOnly, "Inf"
        Else
            MsgBox "Pls, re-check your file!", vbOKOnly, "Inf"
            Exit Sub
        End If
    Else
        sPathOnly = PathOnly(sFilePath)
        If Right$(sPathOnly, 1) <> "\" Then sPathOnly = sPathOnly & "\"
        sOldName = sPathOnly & FileNameOnly(sFilePath)
        sNewName = sPathOnly & "DB2.mdb"
        'Start to compact
        If sOldName <> "" Then
            DoEvents 'Let other process
            DBEngine.CompactDatabase sOldName, sNewName
            Kill sOldName
            Name sNewName As sOldName
            MsgBox "You have compressed the database file", vbOKOnly, "Inf"
        End If
    End If
    Exit Sub

ErrorExit:
    MsgBox "Can not compact the file!" & vbCrLf & _
           "Database file is openning or" & vbCrLf & _
           "Check the reference to " & vbCrLf & _
           "Microsoft Access 11.0 Object Library(MSACC.OLB)", vbOKOnly, "Inf"

    Exit Sub

CompactAccDB_Error:
    If bCentralErrorHandler("DataUltilities", "CompactAccDB", , False) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If
End Sub

Lê Thanh Nhân
 
Vậy thì một ứng dụng của bạn trong việc kết hợp Access (hoặc các database khác) và Excel đã xong.
Bạn có thể viết một file help một cách chuyên nghiệp. Hoặc đơn giản bạn chỉ cần viết một file HuongDan.doc và đưa vào cùng thư mục với file Excel của bạn. Các bạn để ý, trong Window Explorer một khi bạn double click vào một file thì file đó sẽ mở ra đúng không? Tôi xin giới thiệu với các bạn đọan code để làm việc đó.

Mã:
Option Explicit
 
'   Khai bao nham mo mot File giong nhu khi ban Double Click vao File
'   khi muon mo mot File trong Window explorer
#If Win32 Then
    Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
    Private Declare Function GetDesktopWindow Lib "user32" () As Long
 
#Else
    Declare Function ShellExecute Lib "SHELL" (ByVal hWnd%, _
                                               ByVal lpszOp$, ByVal lpszFile$, ByVal lpszParams$, _
                                               ByVal lpszDir$, ByVal fsShowCmd%) As Integer
    Declare Function GetDesktopWindow Lib "User" () As Integer
#End If
'   Bien nay se mo tap tin, xem o dang toan bo man hinh
 
Private Const SW_SHOWNORMAL = 3
 
Function StartDoc(ByVal DocName As String) As Long
'   Ham nay nham mo mot File
'   Chi viec goi ten File do
    Dim Scr_hDC As Long
    Scr_hDC = GetDesktopWindow()
    StartDoc = ShellExecute(Scr_hDC, "Open", _
                            DocName, "", "C:\", SW_SHOWNORMAL)
    'Note: If (StartDoc<0 or StartDoc>32): Open succeed
    '      Else Failed to Open
End Function
Để sử dụng trong ứng dụng của bạn, bạn tạo một nút lệnh vào gọi hàm như sau:
Mã:
Private Sub cmdIntruction_Click()
    Call ShowIntroduction
End Sub
các code liên quan
Mã:
Sub ShowIntroduction()
    Dim sFilePath As String
    Dim lX As Long
    sFilePath = GetLocalDirectory & "GioiThieu.doc"
    lX = StartDoc(sFilePath)
End Sub
Function GetLocalDirectory() As String
' Lay thu muc cua tap tin Excel dang mo
    Dim TStr
    TStr = Application.ActiveWorkbook.Path
    ' Append the backslash character if necessary
    If Right(TStr, 1) <> "\" Then TStr = TStr & "\"
    GetLocalDirectory = TStr
End Function

Lê Thanh Nhân
 
Làm cho ứng dụng của bạn có vẻ chuyên nghiệp hơn:
_Thông thường một ứng dụng có form About để giới thiệu về tác giả. Có chữ chạy lên chạy xuống, có chữ chạy ngang qua lại, có hình ảnh, có thể click rồi gởi mail cho tác giả. Các bạn hãy xem hình sau:
frmAbout.jpg


Bạn có thể tham khảo đọan code sau:

Mã:
Option Explicit
Dim iLy As Long
Dim iPic As Integer

Private Sub cmdExit_Click()
    Me.Hide
End Sub

Private Sub IMG1_Click()
    Dim iPicMax
    iPicMax = Me.ImageList1.ListImages.Count
    If iPic = iPicMax Then
        iPic = 1
    Else
        iPic = iPic + 1
    End If
    Me.IMG1.Picture = Me.ImageList1.ListImages(iPic).Picture
    Me.Repaint
End Sub

Private Sub lbltacgia_Click()
    Dim ActWin As Window
    Dim sLink As String
    On Error Resume Next
    Unload Me
    Set ActWin = ActiveWindow
    sLink = "mailto:le.van.duyet@dunlopillo.com.vn"
    ActiveWorkbook.FollowHyperlink Address:=Link, NewWindow:=True
    ActWin.Visible = True
    End
End Sub

Private Sub UserForm_Activate()
    Dim PauseTime As Variant, Start As Variant
    Dim lLen As Integer
    On Error Resume Next
Label1:
    PauseTime = 0.2    ' Set duration.
    Start = Timer    ' Set start time.
    Do While Timer < Start + PauseTime
        DoEvents    ' Yield to other processes.
    Loop
    If iLy <= -Me.lblduyet.Height Then
        iLy = Me.Height
    Else
        iLy = iLy - 2
    End If
    Me.lblduyet.Move 0, iLy
    lLen = Len(lbltacgia.Caption)
    lbltacgia.Caption = Right(lbltacgia.Caption, lLen - 1) + Left(lbltacgia.Caption, 1)
    GoTo Label1    ' Set end time.

End Sub
Private Sub UserForm_Initialize()
    Dim iLy As Integer
    Me.Caption = "About"
    iLy = Me.lblduyet.Height
    Me.IMG1.Picture = Me.ImageList1.ListImages(1).Picture
    iPic = 1
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = vbFormControlMenu Then
        Cancel = True
    End If
End Sub

_Thủ thuật để chữ chạy từ phải qua trái : cắt phần đầu chữ bên trái, dán vào bên phải của chuỗi.
_Thủ thuật để cho chữ chạy lên trên: bạn dùng phương thức Move.
_Thủ thuật để gởi mail đến tác giả:
bạn dùng thuộc tính FollowHyperlink Address:=Link, NewWindow:=True

Các bạn hãy cùng nhau khám phá thế giới của Excel nha !


Lê Thành Nhân
 
Với các bước ở trên bạn chỉ mới giúp người dùng nhập liệu mà thôi. Như thế thì ứng dụng của bạn thật là chán.
Chúng ta hãy cùng nhau xây dựng ứng dụng trích rút dữ liệu.
Các bạn hãy xem form trích rút như sau:

TrichRutDuLieu.jpg

Khi mở form chương trình sẽ tự động thể hiện thông tin bạn đã nhập vào. Ở đây chú ý rằng với kỹ thuật dùng con trỏ adUseClient công việc truy vấn sẽ nhanh hơn rất nhiều. (Thông thường chỉ xem dữ liệu thôi thì chắc có lẻ dùng kỹ thuật này thì tốt)
Mã:
With rsData
        .CursorLocation = adUseClient
        .Open sSQL, gcnAccess, adOpenKeyset, adLockOptimistic
        lRecordCount = .RecordCount
End With
Đọan mã đầy đủ của form trên như sau:
Mã:
Option Explicit
Dim rsData As New ADODB.Recordset
Private Sub cbbSL_Change()
    Dim sFilter As String
    Dim lRecordCount As Long, sngQty As Single

    sFilter = cbbSL.Text
    sFilter = "Location='" & sFilter & "' "
    rsData.Filter = sFilter
    lRecordCount = rsData.RecordCount
    If lRecordCount > 0 Then
        'Update the value
        Do Until rsData.EOF
            sngQty = sngQty + Val(rsData.Fields("CountQty").Value)
            rsData.MoveNext
        Loop
        txtTotalCountQty.Text = Format(sngQty, "##,##0.00")
    Else
        txtTotalCountQty.Text = Format(0, "##,##0.00")
    End If
End Sub

Private Sub cmdExit_Click()
    On Error GoTo cmdExit_Click_Error
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    Set rsData = Nothing
    If gcnAccess.state = ObjectStateEnum.adStateOpen Then
        gcnAccess.Close
    End If
    End

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

cmdExit_Click_Error:
    If bCentralErrorHandler("frmEditData", "cmdExit_Click", , False) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If



End Sub

Private Sub cmdExpand_Click()

    If Me.cmdExpand.Caption = ">>" Then
        Me.cmdExpand.Caption = "<<"
        Me.Height = 450
    Else
        Me.cmdExpand.Caption = ">>"
        Me.Height = 331
    End If
End Sub

Private Sub cmdExport_Click()
    Dim lRecordCount As Long, i As Long, j As Long
    Dim rngRange As Range

    '    sSQL = "SELECT ItemCode, UoM, Descriptions, CountQty, StockCardNo, Location, " & _
         "GoodsCondition, Remarks, DataEntryBy, AutoNumber " & _
         "FROM tbMain " & _
         "ORDER BY ItemCode ; "
On Error GoTo cmdExport_Click_Error
   With Application
      .Calculation = xlCalculationManual
      .ScreenUpdating = False
   End With
    i = 2
    lRecordCount = rsData.RecordCount
    If lRecordCount > 0 Then
        Set rngRange = Range("tbSummaryDel")
        rngRange.ClearContents
        rsData.MoveFirst
        For j = 0 To rsData.Fields.Count - 1
            With Application.ThisWorkbook.Worksheets("SHO_SUMMARY").Range("A1")
                .Offset(1, j) = rsData.Fields(j).Name
            End With
        Next j
        Do Until rsData.EOF
            With Application.ThisWorkbook.Worksheets("SHO_SUMMARY").Range("A1")
                .Offset(i, 0) = rsData.Fields("ItemCode").Value
                .Offset(i, 1) = rsData.Fields("UoM").Value
                .Offset(i, 2) = rsData.Fields("Descriptions").Value
                .Offset(i, 3) = rsData.Fields("CountQty").Value
                .Offset(i, 4) = rsData.Fields("StockCardNo").Value
                .Offset(i, 5) = rsData.Fields("Location").Value
                .Offset(i, 6) = rsData.Fields("GoodsCondition").Value
                .Offset(i, 7) = rsData.Fields("Remarks").Value
                .Offset(i, 8) = rsData.Fields("DataEntryBy").Value
                .Offset(i, 9) = Round(rsData.Fields("AutoNumber").Value, 0)

            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
    Else
        MsgBox "There are no record" & vbCrLf & _
               "Khong co item nao!", vbOKOnly, "Inf"
    End If
    Set rngRange = Nothing

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

cmdExport_Click_Error:
If bCentralErrorHandler("frmEditData", "cmdExport_Click", , False) Then
     Stop
     Resume
Else
     Resume ErrorExit
End If


End Sub

Private Sub cmdUpdate_Click()
    Dim sAutoNumber As String
    Dim sMaterial As String, sStockCountQty As String
    Dim sStockCardNo As String, sSLocation As String, sUoM As String, sDes As String
    Dim sGoodsCond As String
    Dim rsUpdate As New ADODB.Recordset, lrsUpdateCount As Long, sSQL As String
    Dim bUpdateSucceed As Boolean
    On Error GoTo cmdUpdate_Click_Error
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    sAutoNumber = txtAutoNumber.Text
    If Len(Trim(sAutoNumber)) > 0 And sAutoNumber <> "AutoNumber" Then
        'Edit the record
        'First have to check
        sMaterial = txt1.Text
        sDes = txtDes.Text
        sUoM = txtUoM.Text
        sStockCountQty = txt2.Text
        sStockCardNo = txt3.Text
        sSLocation = txt4.Text
        sGoodsCond = txt5.Text
        bUpdateSucceed = False
        'Built the sSQL
        If Len(Trim(sMaterial)) > 0 Then
            sSQL = "UPDATE tbMain " & _
                   "SET ItemCode='" & sMaterial & "' , Descriptions='" & sDes & "' , UoM='" & sUoM & "' " & _
                   "WHERE Autonumber=" & Val(sAutoNumber) & "; "
            rsUpdate.Open sSQL, gcnAccess, adOpenKeyset, adLockOptimistic
            bUpdateSucceed = True
        ElseIf Len(Trim(sStockCountQty)) > 0 Then
            sSQL = "UPDATE tbMain " & _
                   "SET CountQty=" & Val(sStockCountQty) & " " & _
                   "WHERE Autonumber=" & Val(sAutoNumber) & "; "
            rsUpdate.Open sSQL, gcnAccess, adOpenKeyset, adLockOptimistic
            bUpdateSucceed = True
        ElseIf Len(Trim(sStockCardNo)) > 0 Then
            sSQL = "UPDATE tbMain " & _
                   "SET StockCardNo=" & Val(sStockCardNo) & " " & _
                   "WHERE Autonumber=" & Val(sAutoNumber) & "; "
            rsUpdate.Open sSQL, gcnAccess, adOpenKeyset, adLockOptimistic
            bUpdateSucceed = True
        ElseIf Len(Trim(sSLocation)) > 0 Then
            sSQL = "UPDATE tbMain " & _
                   "SET Location='" & sSLocation & "' " & _
                   "WHERE Autonumber=" & Val(sAutoNumber) & "; "
            rsUpdate.Open sSQL, gcnAccess, adOpenKeyset, adLockOptimistic
            bUpdateSucceed = True
        ElseIf Len(Trim(sGoodsCond)) > 0 Then
            sSQL = "UPDATE tbMain " & _
                   "SET GoodsCondition=" & Val(sGoodsCond) & " " & _
                   "WHERE Autonumber=" & Val(sAutoNumber) & "; "
            rsUpdate.Open sSQL, gcnAccess, adOpenKeyset, adLockOptimistic
            bUpdateSucceed = True
        Else
            MsgBox "There are nothing to update!", vbOKOnly, "Inf"
            Exit Sub
        End If
        If bUpdateSucceed Then
            MsgBox "You have updated.", vbOKOnly, "Inf"
            txt1.Text = ""
            txtDes.Text = ""
            txtUoM.Text = ""
            txt2.Text = ""
            txt3.Text = ""
            txt4.Text = ""
            txt5.Text = ""
            txt2.SetFocus
        End If
    End If

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

cmdUpdate_Click_Error:
    If bCentralErrorHandler("frmEditData", "cmdUpdate_Click", , False) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If


End Sub
Lê Thanh Nhân
 
Mã:
Private Sub MSHFlexGridDB_DblClick()
    Dim Ans As Variant
    Dim CellIndex, lRecordCount As Long, sngQty As Variant
    Dim sMaterialNumber As String, sFilter As String
On Error GoTo MSHFlexGridDB_DblClick_Error
   With Application
      .Calculation = xlCalculationManual
      .ScreenUpdating = False
   End With
    With Me.MSHFlexGridDB
        CellIndex = (Me.MSHFlexGridDB.RowSel) * Me.MSHFlexGridDB.Cols  '+ Me.MSHFlexGridDB.ColSel
    End With
    Ans = MsgBox("Do you want to update" & vbCrLf & _
                 "this record?", vbOKCancel, "Inf")
    'Me.Height = 395
    If Ans = vbOK Then
        
        With Me.MSHFlexGridDB
            txt12.Text = .TextArray(CellIndex + 1)
            txt22.Text = .TextArray(CellIndex + 4)
            txt32.Text = .TextArray(CellIndex + 5)
            txt42.Text = .TextArray(CellIndex + 6)
            txt52.Text = .TextArray(CellIndex + 7)
            txtAutoNumber.Text = .TextArray(CellIndex + 10)
        End With
    Else
        With Me.MSHFlexGridDB
            txt12.Text = ""
            txtUoM.Text = ""
            txt22.Text = ""
            txt32.Text = ""
            txt42.Text = ""
            txt52.Text = ""
            txtAutoNumber.Text = ""
        End With
    End If

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

MSHFlexGridDB_DblClick_Error:
If bCentralErrorHandler("frmEditData", "MSHFlexGridDB_DblClick", , False) Then
     Stop
     Resume
Else
     Resume ErrorExit
End If


End Sub

Private Sub txt1_AfterUpdate()
    Dim sItemCode As String, sDes As String, sUoM As String
    Dim sSQL As String, rsCheck As ADODB.Recordset
    Dim lrsCheckCount As Long

    On Error GoTo txt1_AfterUpdate_Error
    With Application
        .Calculation = xlCalculationManual
    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!" & _
               "Can not contact to Database!" & _
               "Please check!", vbOKOnly, "Inf"
    End If
    If gcnAccess.state = ObjectStateEnum.adStateClosed Then
        gcnAccess.Open
    End If
    sItemCode = txt1.Text
    sSQL = "SELECT ItemCode, Descriptions, UoM " & _
           "FROM tbSAP " & _
           "WHERE ItemCode='" & sItemCode & "';"
    Set rsCheck = New ADODB.Recordset
    rsCheck.Open sSQL, gcnAccess, adOpenKeyset, adLockOptimistic
    lrsCheckCount = rsCheck.RecordCount
    If lrsCheckCount = 0 Then
        MsgBox "This material number do no exist" & vbCrLf & _
               "in the material list" & vbCrLf & _
               "Pls, check!", vbOKOnly, "Inf"
        txt1.Text = ""
        txtDes.Text = ""
        txtUoM.Text = ""
    Else
        txtDes.Text = rsCheck.Fields("Descriptions").Value
        txtUoM.Text = rsCheck.Fields("UoM").Value
    End If
    Set rsCheck = Nothing

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

txt1_AfterUpdate_Error:
    If bCentralErrorHandler("frmEditData", "txt1_AfterUpdate", , False) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If


End Sub

Private Sub txt1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
'Set the length of the Material Number
    If Len(txt1.Text) < 10 Then
        Select Case KeyAscii
        Case Asc("0") To Asc("9")
            'Chang lam gi ca/Do nothing
        Case Else
            'Cac ky tu khac thi khong cho phep nhap/Do not allow for entering other
            KeyAscii = 0
        End Select
    Else
        KeyAscii = 0
    End If

End Sub
Private Sub txt2_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Select Case KeyAscii
    Case Asc("0") To Asc("9")
        'Chang lam gi ca
'    Case Asc("-")
'        If InStr(1, Me.txtSoLuong.Text, "-") > 0 Or Me.txtSoLuong.SelStart > 0 Then
'            'Neu dau tru khong nam o dau chuoi thi khong nhap
'            KeyAscii = 0
'        End If
    Case Asc(".")
        If InStr(1, Me.txt2.Text, ".") > 0 Then
            'Neu co dau cham thu hai thi khong nhap
            KeyAscii = 0
        End If
    Case Else
        'Cac ky tu khac thi khong cho phep nhap
        KeyAscii = 0
    End Select
End Sub

Private Sub txt3_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
'Set the length of the Material Number
    If Len(txt2.Text) < 10 Then
        Select Case KeyAscii
        Case Asc("0") To Asc("9")
            'Chang lam gi ca/Do nothing
        Case Else
            'Cac ky tu khac thi khong cho phep nhap/Do not allow for entering other
            KeyAscii = 0
        End Select
    Else
        KeyAscii = 0
    End If

End Sub

Private Sub txt4_AfterUpdate()
    Dim sSLoc As String
    sSLoc = txt4.Text
    sSLoc = Trim(sSLoc)
    If (sSLoc <> "W001") And (sSLoc <> "P001") And (sSLoc <> "R001") Then
        txt4.Text = ""
    End If
End Sub

Private Sub txt4_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    Dim iLen As Integer
    iLen = Len(txt4.Text)
    'Set the length of the Material Number
    If iLen < 4 Then
        Select Case iLen
        Case 0
            Select Case KeyAscii
            Case vbKeyW, vbKeyR, vbKeyP
            Case Else
                KeyAscii = 0
            End Select
        Case iLen = 1 To 2
            Select Case KeyAscii
            Case vbKey0
            Case Else
                KeyAscii = 0
            End Select
        Case 3
            Select Case KeyAscii
            Case vbKey1
            Case Else
                KeyAscii = 0
            End Select
        End Select

    Else
        KeyAscii = 0
    End If
End Sub
Lê Thanh Nhân
 
Mã:
Private Sub txt5_AfterUpdate()
    Dim sGoodsCond As String
    sGoodsCond = txt5.Text
    Select Case sGoodsCond
    Case "1"
        lbl52.Caption = "Good"
    Case "2"
        lbl52.Caption = "QI"
    Case "4"
        lbl52.Caption = "Blocked"
    Case Else
        lbl52.Caption = ""
    End Select
End Sub

Private Sub txt5_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
'Set the length of the Material Number
    If Len(txt5.Text) < 1 Then
        Select Case KeyAscii
        Case Asc("1"), Asc("2"), Asc("4")
            'Chang lam gi ca/Do nothing
        Case Else
            'Cac ky tu khac thi khong cho phep nhap/Do not allow for entering other
            KeyAscii = 0
        End Select
    Else
        KeyAscii = 0
    End If
End Sub

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
    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
        rsData.Filter = sFilter
        rsData.Sort = "Descriptions"
        lRecordCount = rsData.RecordCount
        If lRecordCount > 0 Then
            'Update the value
            Do Until rsData.EOF
                sngQty = sngQty + Val(rsData.Fields("CountQty").Value)
                rsData.MoveNext
            Loop
            txtTotalCountQty.Text = Format(sngQty, "##,##0.00")
        Else
            txtTotalCountQty.Text = Format(0, "##,##0.00")
        End If
    Else
        rsData.Filter = adFilterNone
        lRecordCount = rsData.RecordCount
        If lRecordCount > 0 Then
            'Update the value
            Do Until rsData.EOF
                sngQty = sngQty + Val(rsData.Fields("CountQty").Value)
                rsData.MoveNext
            Loop
            txtTotalCountQty.Text = Format(sngQty, "##,##0.00")
        Else
            txtTotalCountQty.Text = Format(0, "##,##0.00")
        End If

    End If

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

txtFilter_Change_Error:
    If bCentralErrorHandler("frmEditData", "txtFilter_Change", , False) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If
End Sub
Lê Thanh Nhân
 
Mã:
Private Sub txtMaterialNo_Change()
     Dim sFilter As String
     Dim lRecordCount As Long, sngQty As Single
     sFilter = txtMaterialNo.Text
     sFilter = "ItemCode LIKE '" & sFilter & "*'" & " AND Location='" & cbbSL.Text & "' "
     If Len(txtMaterialNo.Text) > 0 Then
         rsData.Filter = sFilter
         lRecordCount = rsData.RecordCount
         If lRecordCount > 0 Then
             'Update the value
             Do Until rsData.EOF
                 sngQty = sngQty + Val(rsData.Fields("CountQty").Value)
                 rsData.MoveNext
             Loop
             txtTotalCountQty.Text = Format(sngQty, "##,##0.00")
         Else
             txtTotalCountQty.Text = Format(0, "##,##0.00")
         End If
     Else
         rsData.Filter = adFilterNone
         lRecordCount = rsData.RecordCount
         If lRecordCount > 0 Then
             'Update the value
             Do Until rsData.EOF
                 sngQty = sngQty + Val(rsData.Fields("CountQty").Value)
                 rsData.MoveNext
             Loop
             txtTotalCountQty.Text = Format(sngQty, "##,##0.00")
         Else
             txtTotalCountQty.Text = Format(0, "##,##0.00")
         End If
     End If
 End Sub
 
 Private Sub txtMaterialNo_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
 
 'Set the length of the Material Number
     If Len(txtMaterialNo.Text) < 10 Then
         Select Case KeyAscii
         Case Asc("0") To Asc("9")
             'Chang lam gi ca/Do nothing
         Case Else
             'Cac ky tu khac thi khong cho phep nhap/Do not allow for entering other
             KeyAscii = 0
         End Select
     Else
         KeyAscii = 0
     End If
 End Sub
 
 Private Sub txtStockCardNo_Change()
     Dim sFilter As String
     Dim lRecordCount As Long, sngQty As Single
     sFilter = txtStockCardNo.Text
     sFilter = "StockCardNo LIKE '" & sFilter & "'" & " AND Location='" & cbbSL.Text & "' "
     If Len(txtStockCardNo.Text) > 0 Then
         rsData.Filter = sFilter
         lRecordCount = rsData.RecordCount
         If lRecordCount > 0 Then
             'Update the value
             Do Until rsData.EOF
                 sngQty = sngQty + Val(rsData.Fields("CountQty").Value)
                 rsData.MoveNext
             Loop
             txtTotalCountQty.Text = Format(sngQty, "##,##0.00")
         Else
             txtTotalCountQty.Text = Format(0, "##,##0.00")
         End If
     Else
         rsData.Filter = adFilterNone
         lRecordCount = rsData.RecordCount
         If lRecordCount > 0 Then
             'Update the value
             Do Until rsData.EOF
                 sngQty = sngQty + Val(rsData.Fields("CountQty").Value)
                 rsData.MoveNext
             Loop
             txtTotalCountQty.Text = Format(sngQty, "##,##0.00")
         Else
             txtTotalCountQty.Text = Format(0, "##,##0.00")
         End If
     End If
 End Sub
 
 Private Sub txtStockCardNo_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
     Select Case KeyAscii
     Case Asc("0") To Asc("9")
         'Chang lam gi ca/Do nothing
     Case Else
         'Cac ky tu khac thi khong cho phep nhap/Do not allow for entering other
         KeyAscii = 0
     End Select
 End Sub
 
 Private Sub UserForm_Initialize()
     Dim sSQL As String, i As Long, lLen As Long
     Dim sngQty As Single, lRecordCount As Long
     On Error GoTo UserForm_Initialize_Error
     With Application
         .Calculation = xlCalculationManual
         .ScreenUpdating = False
     End With
     Me.Height = 331
     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!" & vbCrLf & _
                "Can not connect to DB. Pls, check!", vbOKOnly, "Inf"
         End
     End If
     If gcnAccess.state = ObjectStateEnum.adStateClosed Then
         gcnAccess.Open
     End If
     sSQL = "SELECT ItemCode, UoM, Descriptions, CountQty, StockCardNo, Location, " & _
            "GoodsCondition, Remarks, DataEntryBy, AutoNumber " & _
            "FROM tbMain " & _
            "ORDER BY ItemCode ; "
 
     'When we set this property to adUseClient
     'So you can Sort at the Client
     With rsData
         .CursorLocation = adUseClient
         .Open sSQL, gcnAccess, adOpenKeyset, adLockOptimistic
         lRecordCount = .RecordCount
     End With
     If lRecordCount > 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) = 1200
             .ColWidth(2) = 500
             .ColWidth(3) = 4200
 
             'Set the Grid
             .Gridlines = flexGridDots
             .BackColor = &H80FFFF
         End With
 
     End If
     With Me.cbbSL
         .AddItem "R001"
         .AddItem "P001"
         .AddItem "W001"
         .ListIndex = 0
     End With
 
 ErrorExit:
     With Application
         .Calculation = xlCalculationManual
         .ScreenUpdating = True
 
     End With
     Exit Sub
 
 UserForm_Initialize_Error:
     If bCentralErrorHandler("frmEditData", "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 this way
     If CloseMode = vbFormControlMenu Then
         Cancel = True
     End If
 End Sub
Ở đây chúng ta có dùng kỹ thuật "Lọc"
Các bạn chú ý txtFilter ở sự kiện Change, người dùng có thể lọc dữ liệu rất nhanh.
Ví dụ: tôi muốn tìm mô tả sản phẩm là SPRING VENUS, 200X160X20CM
Tôi có thể nhập vào textbox này như sau: *VENUS*200*160*
Lập tức các bạn có ngay kết quả lọc.
Còn một số mẹo vặt khác, các bạn tham khảo nha.

Hy vọng với bài này, các bạn có một cái nhìn "thân thiện" với cái thằng "Excel".

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

Lê Thanh Nhân

Mọi góp ý xin gởi về: ledothanhnhan@gmail.com
 
Xây dựng một ứng dụng xem tồn kho

Chào các bạn,
Một số bạn được làm việc trong một công ty có sử dụng các phần mềm nỗi tiếng thì thật là tuyệt. Nhưng lắm lúc các bạn cũng chán vì việc "bảo mật" của nó có đúng không?
Chẳng hạn chương trình "SAP" nổi tiếng
http://www.sap.com/solutions/business-suite/erp/index.epx
Công ty của bạn phải làm ba ca, nhưng ca ba người trửơng ca lại không được cấp quyền truy cập (vì tiền trả cho một user nhiều quá!). Vậy thì làm thế nào giúp trưởng ca có thể giải quyết được yêu cầu này mà không phải tốn thêm tiền. :(
Tôi có một giải pháp tạm thời như sau:
_Cần một user ID với phân quyền có thể trích xuất số liệu ra Excel.
_Viết một module đưa dữ liệu vào database.
_Viết một module để thể hiện bảng tồn kho cho người dùng xem xét.
Data.jpg


Bạn phải xem xét định dạng dữ liệu xúat ra của bạn. Định dạng này phải cố định. Ví dụ như hình sau:

Sau đó bạn thíet kế một form nhằm giúp người dùng import dữ liệu.
Chương trình sẽ kiểm tra: Header của khối dữ liệu cố định, kiểm tra dữ liệu trước khi nhập vào database.
Import.jpg


Đọan code đầy đủ của form trên như sau:
Mã:
Option Explicit
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

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


Private Sub cmdExit_Click()

    On Error GoTo cmdExit_Click_Error
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    If gcnAccess.State = ObjectStateEnum.adStateOpen Then
        gcnAccess.Close
    End If
    End
ErrorExit:
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
    Exit Sub

cmdExit_Click_Error:
    If bCentralErrorHandler("frmInputData", "cmdExit_Click", , False) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If


End Sub

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

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
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

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

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    MsgBox "You can not close by this way!Pls,Click Exit button!", vbOKOnly, "Notice"
    Cancel = True
End Sub

Lê Thanh Nhân
 
Lần chỉnh sửa cuối:
Sau khi dữ liệu đã được nhập thành công, bạn dùng kết nối để xem dữ liệu. Nó tương tự như trong lọat bài đầu tiên.
Code như sau:
Mã:
Option Explicit



Private Sub cbbSL_Change()

    rsData.Filter = "SLoc='" & cbbSL.Text & "'"
    rsData.Sort = "Descriptions"
End Sub

Private Sub cmdExit_Click()
    'Close the Connection before Close the Form
On Error GoTo cmdExit_Click_Error
   With Application
      .Calculation = xlCalculationManual
      .ScreenUpdating = False
      .DisplayAlerts = False
   End With
    Set rsData = Nothing
    If gcnAccess.State = ObjectStateEnum.adStateOpen Then
        gcnAccess.Close
    End If
    End
ErrorExit:
   With Application
      .Calculation = xlCalculationManual
      .ScreenUpdating = True
      .DisplayAlerts = True
   End With
   Exit Sub

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

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

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
        rsData.Filter = sFilter
        rsData.Sort = "Descriptions"
        lRecordCount = rsData.RecordCount
        Debug.Print sFilter & vbCrLf & lRecordCount
        If lRecordCount > 0 Then
            'Update the value
            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
Lê Thanh Nhân
 
Mã:
Private Sub UserForm_Activate()
    rsData.Filter = "SLoc='" & cbbSL.Text & "'"
    rsData.Sort = "Descriptions"
End Sub

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
        sSQL = "SELECT * " & _
               "FROM tbStock " & _
               "ORDER BY Descriptions ; "


        '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

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
'The purpose that Do not allow the user close the application
'by Click the X button on the Form
'Muc dich khong cho nguoi dung dong Form theo cach nay
    If CloseMode = vbFormControlMenu Then
        Cancel = True
    End If
End Sub

Private Sub BoxSetting(rsData As Recordset)
Dim col
    Me.MSHFlexGridDB.ColWidth(0) = 1440 * 0.25
    With Me.MSHFlexGridDB
        For col = 0 To rsData.Fields.Count - 1
            .ColWidth(col) = (92 * Len(rsData(col)))
        Next
    End With
End Sub
Hy vọng rằng với kiến thức trên các bạn sẽ phát triển cho mình các công cụ nhằm giúp cho "cuộc sống mưu sinh" được phần nào "thanh thản" hơn.

Lê Thanh Nhân
 
Chú ý trong phần trên có sử dụng hàm kiểm tra tiêu đề
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

Lê Thanh Nhân.

Chú ý: các đọan code trên có một số tôi chưa tối ưu hóa (code chỉ có tính chất tham khảo thôi)
 
Web KT
Back
Top Bottom