Have you ever wondered how to move items between listboxes in Microsoft Access using VBA? How about filtering listbox items as you type?

 

Using VBA in Microsoft Access, the objectives of this article are (Watch the following YouTube movie to see it in action http://www.youtube.com/watch?v=n0ykubD6e8g or check the bottom part of the article) :

 

·         Clear a listbox in Microsoft Access

·         Move items between  two listboxes in Microsoft Access

·         Filter listbox as you type

·         Move listbox items with double click

 

Before you continue, you will need the following setup:

 

·         Add VBA reference to Microsoft ActiveX Objects X.x (Where X.x is the version registered in your machine)

·         Add a table (name it tblNames) with the following fields:

o   IDName

o   FullName

o   ShowYesNoFilter (set the default value to “Yes”)

·         Create two queries and name them as follows

o   tblNames QueryNo (set the filter criteria to “No” and order ascending)

o   tblNames QueryYes(set the filter criteria to “Yes” and order ascending)

·         Create a form and the following controls

o   Textbox (name it “txtFilter”)

o   Listbox 1

§  Name it “ListNoItems”

§  Set its Row Source to tblNames QueryNo

§  Set its Row Source type to Table/Query

o   Listbox 2

§  Name it “ListYesItems”

§  Set its Row Source to tblNames QueryYes

§  Set its Row Source type to Table/Query

o   Button 1

§  Name it “cmdAddOne”

§  Caption: >

o   Button 2

§  Name it “cmdAddAll”

§  Caption: >>

o   Button 3

§  Name: “cmdRemoveOne”

§  Caption: <

o   Button 4

§  Name: “cmdRemoveAll”

§  Caption: <<

 

Once you have done that, your setup will look like this:

Now, you can add the code as follows:

Option Compare Database
Option Explicit

'*********************************************************************************************************************
'CONSTANTS
Private Const mstr_MsgBoxTitle                  As String = "Meu projeto Access 2007"
Private Const mstr_MsgNoItemToMove              As String = "Não há item para mover ou item não foi selecionado..."
Private Const mstr_Yes                          As String = "Yes"
Private Const mstr_No                           As String = "No"
Private Const mstr_Filtered                     As String = "Filtered"

'*********************************************************************************************************************
'STRINGS
Private mstr_SQLInstruction                     As String

'*********************************************************************************************************************
'OBJECTS
Private mobj_ADODBRecordset                     As ADODB.Recordset

Sub ExecuteCommand(ByVal strExecuteSQL, ByVal strShowYesNoFilter As String)
   
    Set mobj_ADODBRecordset = New ADODB.Recordset
   
    With mobj_ADODBRecordset
        .Open strExecuteSQL, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
        If Not .BOF Then .MoveFirst
       
        Do While Not .EOF
            .Fields("ShowYesNoFilter").Value = strShowYesNoFilter
            .Update
            .MoveNext
        Loop
    End With
       
    Me.ListYesItems.Requery
    Me.ListNoItems.Requery
   
    mstr_SQLInstruction = ""
    Set mobj_ADODBRecordset = Nothing

End Sub

Private Sub cmdAddAll_Click()
    mstr_SQLInstruction = "SELECT tblNames.IDName, tblNames.FullName, tblNames.ShowYesNoFilter, "
    mstr_SQLInstruction = mstr_SQLInstruction & "tblNames.ShowYesNoFilter FROM tblNames "
    mstr_SQLInstruction = mstr_SQLInstruction & "WHERE (((tblNames.ShowYesNoFilter)='" & mstr_Yes & "'));"

    ExecuteCommand mstr_SQLInstruction, "No"
   
End Sub

Private Sub cmdAddOne_Click()
    Dim strSelectedItem                 As String
    Dim lngSelectedItemIndex            As Long
   
    On Error Resume Next
    If Me.ListYesItems.ListIndex = -1 Then
        MsgBox mstr_MsgNoItemToMove, vbInformation, mstr_MsgBoxTitle
        Exit Sub
    End If
   
    lngSelectedItemIndex = Me.ListYesItems.ListIndex
    strSelectedItem = Me.ListYesItems.ItemData(lngSelectedItemIndex)

    If Len(Me.ListYesItems.ItemData(lngSelectedItemIndex)) < 1 Then
        MsgBox mstr_MsgNoItemToMove, vbInformation, mstr_MsgBoxTitle
        Exit Sub
    End If
   
   
    mstr_SQLInstruction = "SELECT tblNames.IDName, tblNames.FullName, tblNames.ShowYesNoFilter, "
    mstr_SQLInstruction = mstr_SQLInstruction & "tblNames.ShowYesNoFilter FROM tblNames "
    mstr_SQLInstruction = mstr_SQLInstruction & "WHERE (((tblNames.FullName)='" & strSelectedItem & "'));"

    ExecuteCommand mstr_SQLInstruction, mstr_No

End Sub

Private Sub cmdRemoveAll_Click()
    mstr_SQLInstruction = "SELECT tblNames.IDName, tblNames.FullName, tblNames.ShowYesNoFilter, "
    mstr_SQLInstruction = mstr_SQLInstruction & "tblNames.ShowYesNoFilter FROM tblNames "
    mstr_SQLInstruction = mstr_SQLInstruction & "WHERE (((tblNames.ShowYesNoFilter)='" & mstr_No & "'));"

    ExecuteCommand mstr_SQLInstruction, mstr_Yes

End Sub

Private Sub cmdRemoveOne_Click()
    Dim strSelectedItem                 As String
    Dim lngSelectedItemIndex            As Long
   
    'On Error Resume Next
   
    If Me.ListNoItems.ListIndex = -1 Then
        MsgBox mstr_MsgNoItemToMove, vbInformation, mstr_MsgBoxTitle
        Exit Sub
    End If
   
    lngSelectedItemIndex = Me.ListNoItems.ListIndex
    strSelectedItem = Me.ListNoItems.ItemData(lngSelectedItemIndex)

    If Len(Me.ListNoItems.ItemData(lngSelectedItemIndex)) < 1 Then
        MsgBox mstr_MsgNoItemToMove, vbInformation, mstr_MsgBoxTitle
        Exit Sub
    End If
   
    mstr_SQLInstruction = "SELECT tblNames.IDName, tblNames.FullName, tblNames.ShowYesNoFilter, "
    mstr_SQLInstruction = mstr_SQLInstruction & "tblNames.ShowYesNoFilter FROM tblNames "
    mstr_SQLInstruction = mstr_SQLInstruction & "WHERE (((tblNames.FullName)='" & strSelectedItem & "'));"

    ExecuteCommand mstr_SQLInstruction, mstr_Yes
End Sub

Private Sub Form_Open(Cancel As Integer)
   
    mstr_SQLInstruction = "SELECT tblNames.IDName, tblNames.FullName, tblNames.ShowYesNoFilter, "
    mstr_SQLInstruction = mstr_SQLInstruction & "tblNames.ShowYesNoFilter FROM tblNames "
    mstr_SQLInstruction = mstr_SQLInstruction & "WHERE (((tblNames.ShowYesNoFilter)='" & mstr_No & "')) "
    mstr_SQLInstruction = mstr_SQLInstruction & "OR (((tblNames.ShowYesNoFilter)='" & mstr_Filtered & "'));"
   
    ExecuteCommand mstr_SQLInstruction, mstr_Yes
   
End Sub

Private Sub ListNoItems_DblClick(Cancel As Integer)
    cmdRemoveOne_Click
End Sub

Private Sub ListYesItems_DblClick(Cancel As Integer)
    cmdAddOne_Click
End Sub

Private Sub txtFilter_KeyUp(KeyCode As Integer, Shift As Integer)
    Dim strFilter                   As String

    strFilter = Me.txtFilter.Text
   
    Select Case KeyCode
        Case 8, 46

            mstr_SQLInstruction = "SELECT tblNames.FullName, tblNames.ShowYesNoFilter FROM tblNames "
            mstr_SQLInstruction = mstr_SQLInstruction & "WHERE (((tblNames.FullName) Not Like '%" & strFilter & "%') "
            mstr_SQLInstruction = mstr_SQLInstruction & "Or ((tblNames.ShowYesNoFilter) = '" & mstr_Filtered & "'));"
           
            ExecuteCommand mstr_SQLInstruction, mstr_Yes

            mstr_SQLInstruction = "SELECT tblNames.FullName, tblNames.ShowYesNoFilter FROM tblNames "
            mstr_SQLInstruction = mstr_SQLInstruction & "WHERE (((tblNames.FullName) Not Like '%" & strFilter & "%') "
            mstr_SQLInstruction = mstr_SQLInstruction & "And ((tblNames.ShowYesNoFilter) = '" & mstr_Yes & "'));"

            ExecuteCommand mstr_SQLInstruction, mstr_Filtered
       
        Case Else
            mstr_SQLInstruction = "SELECT tblNames.FullName, tblNames.ShowYesNoFilter FROM tblNames "
            mstr_SQLInstruction = mstr_SQLInstruction & "WHERE (((tblNames.FullName) Not Like '%" & strFilter & "%') "
            mstr_SQLInstruction = mstr_SQLInstruction & "And ((tblNames.ShowYesNoFilter) = '" & mstr_Yes & "'));"
           
            ExecuteCommand mstr_SQLInstruction, mstr_Filtered
    End Select
   
End Sub

 

 

This article is the third part of the series on building custom toolbar in MS Access.

In this article I will show to execute actions and keyboard shortcuts using the OnAction property and the Execute method. Furthermore, I will show how to create shortcuts in Access.

The difference between OnAction and Execute is that OnAction executes a command that we determined through a procedure whereas Execute executes an internal command such as print. However, Execute is activated when we create the button, thus, we will use the button ID to execute the command. In other words, we will define the button such that it acts as if we had clicked on the Relationships button under the Tools menu.

Firstly, let us create the code that will build our menu:

Public Const MENUACCESS As String = "Menu Bar"

Sub executeMenus()    Dim mnu     As CommandBarPopup    Dim btn     As CommandBarButton        On Error Resume Next    CommandBars(MENUACCESS).Controls("Execute Commands").Delete    Set mnu = CommandBars(MENUACCESS).Controls.Add _     (Type:=msoControlPopup, before:=1)     mnu.Caption = "Execute Commands"    Set btn = mnu.Controls.Add(Type:=msoControlButton)     With btn      .Caption = "Example OnAction"      .FaceId = 1018      'Refers to the procedure to be executed      .OnAction = "Message"     End With    Set btn = mnu.Controls.Add(Type:=msoControlButton, ID:=523)     With btn      .Caption = "Example Execute"      .FaceId = 523      'This option is commented as we will use its ID to execute      'the command we want      '.Execute     End With End Sub

The new menu should look like this:

Figure 1 – OnAction property and Execute method

The FaceID choice is up to the reader.

Note that for the OnAction we put the name of the procedure to be executed when the button is clicked. However, on the Execute instance we refer to the command to be executed by using its ID. Given that the OnAction property needs a procedure, we shall use the example below as a simple way to get the button up-and-running:

Sub Message()    MsgBox "There is nothing under this button to be executed.", _     vbInformation End Sub

When we click the button the message below is shown to the user:

Figure 2 – MsgBox called by the OnAction property

As for the second button, when we click it, the Relationships window is open:

Figure 3 – Relationships windows opened through the Execute method

Once we have defined the ID of the command, the Execute method becomes redundant, as when we click on the button the command is executed. However, there may be situations when you wish to have the command executed immediately.

The above commands are executed through cliks, however, we can also add keyboard shortcuts. These shortcuts will require that you only press a few key combinations to execute the command you want.

This will be discussed in my next article.

This tip shows you how to use VBA to alternate the row color of an Access report. Many times, when creating a report, we find it hard to read the details. By alternating the row color we can make life much simpler...

Private rowCount As Long     Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer)       rowCount = rowCount + 1       If rowCount / 2 = CLng(rowCount / 2) Then       Me.Detail.BackColor = 16777215     Else       Me.Detail.BackColor = 15263976     End If   End Sub

This tip shows how to count characters in a table field using VBA. The sample database uses three tables: tblASCII (for the ASCII characters), tblCount (to store the count) and tblText (which contains the text for which we want to count the characters). Download the sample file to have a better idea of the tip...

IN A MODULE ENTER THE CODE ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 'RUN THIS ONE FIRST '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Sub insertCount()     Dim cn          As ADODB.Connection     Dim rsAscii     As ADODB.Recordset     Dim rsCount     As ADODB.Recordset     Dim rsText      As ADODB.Recordset     Set cn = CurrentProject.Connection     Set rsAscii = New ADODB.Recordset     Set rsCount = New ADODB.Recordset     Set rsText = New ADODB.Recordset     SQLAscii = "tblAscii"     SQLCount = "tblCount"     SQLText = "tblText"        rsAscii.Open SQLAscii, cn, adOpenKeyset, adLockOptimistic, _          adCmdTable     rsCount.Open SQLCount, cn, adOpenKeyset, adLockOptimistic, _          adCmdTable     rsText.Open SQLText, cn, adOpenKeyset, adLockOptimistic, adCmdTable     If Not rsText.BOF Then rsText.MoveFirst     While Not rsText.EOF         IDText = rsText.Fields("IDText").Value         rsAscii.MoveFirst         While Not rsAscii.EOF             total = countChar(rsText.Fields("Text").Value, _                 rsAscii.Fields("Character"))             If total > 0 Then                 With rsCount                     .AddNew                     .Fields("IDText").Value = IDText                     .Fields("countChar").Value = _                        rsAscii.Fields("Character")                     .Fields("Count").Value = total                     .Update                 End With             End If             rsAscii.MoveNext         Wend         rsText.MoveNext     Wend     rsText.Close     rsAscii.Close     rsCount.Close     Set rsCount = Nothing     Set rsText = Nothing     Set rsAscii = Nothing     cn.Close     Set cn = Nothing End Sub   Sub insertAscii()     Dim cn As ADODB.Connection     Dim rs As ADODB.Recordset     Set cn = CurrentProject.Connection     Set rs = New ADODB.Recordset     Sql = "tblASCII"     rs.Open Sql, cn, adOpenKeyset, adLockOptimistic, adCmdTable     For i = 33 To 126         With rs             .AddNew             .Fields("Character") = Chr(i)             .Update         End With     Next End Sub Function countChar(txt As String, Character As String) As Long     For i = 1 To Len(txt)         letter = Mid(txt, i, 1)         If Asc(letter) <> Asc(Character) Then              newText = newText & letter         End If     Next     countChar = Len(txt) - Len(newText) End Function

DOWNLOAD SAMPLE FILES HERE