Beyond Excel: VBA and Database Manipulation

Nov 30 2009   5:02PM GMT

Searching for Codes

Craig Hatmaker Craig Hatmaker Profile: Craig Hatmaker

frmPrompt Dates and IDs

frmPrompt Dates and IDs

Last post we built a simple date prompt.  Eventually we want to get to a form that allows entry of codes, transaction numbers, identifiers, account numbers, etc.  See at right what that form looks like.  It is called frmPrompt.

Before we can implement frmPrompt, we need to create a “Code Search” form.  The “Code Search” form responds to the ellipse (…) buttons at right of our text input boxes for Customers, and Products.  The ellipse buttons are not needed if the list of codes is small; in-which-case, a simple drop down list box works great.  However, most codes in large databases are far too numerous to be practical in a drop down list box.  Instead, we need to offer users a way to search for codes by what the user is likely to know.  Most often, it is a name, a description, or a partial code.  The form to do that is show below.  It is called frmSelect_Multiple.



frmSelect_Multiple is the most complicated form in our bag of forms.  Fortunately, once created, frmSelect_Multiple won’t need changes or adaptations.  It works for just about any table that has a unique identifier and a name or description (I haven’t found one it hasn’t worked for). 

The User Experience
When our customers don’t know the code they need, they press the ellipse button on the frmPrompt and frmSelect_Multiple appears populated with the code table’s first few hundred entries.  If the user sees what they want, they can double click it, or put a check mark next to it and click OK.  If they want several codes, they can select them and press Add to Selections, and continue searching for more codes.  If they don’t see what they want right off, they can enter a partial code or a partial description (Product Name in this example) and click OK to bring up a list of codes matching the partial entries.

Creating frmSelect_Multiple
Use the VBE form tools to create a frmSelect_Multiple and add these controls to it.

Name Type Properties
frmSelect_Multiple UserForm Caption:=“Search Product(s)”
lblID Label Caption:=”Code”
lblDescription Label Caption:=”Product Name”
lblSelections Label Caption:=”Selections”
txtID txtBox TabStop:=True, TabIndex:=0
txtDescription txtBox TabStop:=True, TabIndex:=1
lstList ListBox ColumnCount:=2, ListStle:=1 – frmListStyleOption,
MultiSelect:=1 – frmMultiSelectMulti,
TabStop:=True, TabIndex:=2
txtSelections txtBox TabStop:=True, TabIndex:=3
cmdClear CommandButton Caption:=”Clear Selections”, Cancel:=True,
TabStop:=True, TabIndex:=4
cmdAdd CommandButton Caption:=”Add Selections”, Cancel:=True,
TabStop:=True, TabIndex:=5
cmdExit CommandButton Caption:=”OK”, Default:=True,
TabStop:=True, TabIndex:=6
cmdOK CommandButton Caption:=”Exit”, Cancel:=True,
TabStop:=True, TabIndex:=7
lblMessages Label BorderStyle:=1 – frmBorderStyleSingle

Add this code

'Version: 01/01/2000
Option Explicit
'   Name:   frmSelect_Multiple
'   Purpose:Help the user find something by ID (primary key) or Description
'   Notes:  Nothing in this module should require modifications to use
'     Date   Init Modification
'   01/12/06 CWH  Initial Programming
'   Example (How to use this form):
'Private Sub cmdID1_Click()
'   With frmSelect_Multiple
'      .pConnect = sConnect1
'      .pLabelID = sLabelID1
'      .pLabelDesc = sLabelDesc1
'      .pTitle = sTitle1
'      .pSelections = IIf(UCase(txtID1) = "*ALL", "", txtID1)
'      .pSQLID = sSQLID1
'      .pSQLDesc = sSQLDesc1
'      .Show
'       Do While .Visible
'           DoEvents
'       Loop
'       If .pOK Then   'The OK button was used to exit
'            If UCase(txtID1) = "*ALL" Then txtID1 = ""
'            txtID1 = .pSelections
'            txtID1.ForeColor = RGB(0, 0, 0)
'            txtID1.BackColor = RGB(256, 256, 256)
'       End If
'   End With
'End Sub
    Dim sConnect As String
    Dim sSQLID As String
    Dim sID As String
    Dim sSQLDesc As String
    Dim sDesc As String
    Dim bOK As Boolean
'   Properties
'   Title
Public Property Let pTitle(sString As String)
    Me.Caption = sString
End Property
'    ID
Public Property Let pLabelID(sString As String)
    lblID.Caption = sString
End Property
Public Property Let pDefaultID(sString As String)
    txtID.Text = sString
End Property
Public Property Let pSQLID(sString As String)
'   The String must contain a valid SQL select statement with a "?"
'   to indicate where to substitute the txtID.text
    sSQLID = sString
End Property
'   Description
Public Property Let pLabelDesc(sString As String)
    lblDescription.Caption = sString
End Property
Public Property Let pDefaultDesc(sString As String)
    txtDescription.Text = sString
End Property
Public Property Let pSQLDesc(sString As String)
'   The String must contain a valid SQL select statement with a "?"
'   to indicate where to substitute the txtDesc.text
    sSQLDesc = sString
End Property
'   Connect - ODBC connection string (Required)
Public Property Let pConnect(sString As String)
    sConnect = sString
End Property
'   Current Selections
Public Property Let pSelections(sString As String)
    txtSelections = sString
End Property
Public Property Get pSelections() As String
    pSelections = txtSelections
End Property
'   True if the OK button was clicked
Public Property Get pOK() As Boolean
    pOK = bOK
End Property
'   Event Handlers
'   Add to Selections Button
Private Sub cmdAdd_Click()
    Dim i As Integer
    For i = 0 To lstList.ListCount - 1
        If lstList.Selected(i) Then
            txtSelections.Text = txtSelections.Text & _
                IIf(Len(txtSelections) > 0, ",", "") & _
                    lstList.List(i, 0)
            lstList.Selected(i) = False
        End If
    Next i
End Sub
'   Clear Selections Button
Private Sub cmdClear_Click()
    txtSelections.Text = ""
End Sub
'   Exit Button
Private Sub cmdExit_Click() 'Exit Click
End Sub
'   OK Button
Private Sub cmdOK_Click()   'OK Click
    On Error GoTo ErrHandler:
    Dim i As Integer
    Dim sSQL As String
    Dim cn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim iTimeOut As Integer
    Dim errLoop As Error
'   Initialize variables used in this routine
    sSQL = ""
'   Create SQL search string if ID changed
    If txtID <> sID Then
        sID = txtID
        txtDescription = ""
        sDesc = ""
        sSQL = InsertSQLVariable(sSQLID, Trim(UCase(sID)))
    End If
'   Create SQL search string if description changed
'   (this overrides ID changes)
    If txtDescription <> sDesc Then
        sDesc = txtDescription
        txtID = ""
        sID = ""
        sSQL = InsertSQLVariable(sSQLDesc, Trim(UCase(sDesc)))
    End If
'   Search database if SQL string created
    If sSQL > "" Then
        Debug.Print "Start:", Time, sSQL
        Set cn = New ADODB.Connection
        cn.Properties("Prompt") = adPromptComplete
        cn.Open sConnect, "", ""
        Set rs = New ADODB.Recordset
        If iTimeOut > 0 Then
            cn.CommandTimeout = iTimeOut
        End If
        rs.CacheSize = 500
        rs.Open sSQL, cn, , , adAsyncFetch
        Debug.Print "End:", Time
        If rs.EOF Then
            lblMessage = "No records found"
            lblMessage = ""
            i = 0
            Do While Not rs.EOF And i < 500
                lstList.AddItem rs(0)
                lstList.List(i, 1) = IIf(IsNull(rs(1)), " ", rs(1))
                i = i + 1
            lstList.Visible = True
        End If
    Else    'No SQL string created
'       If anything was selected, were done!
        If txtSelections > "" Then
            bOK = True
        End If
    End If
    If Err.Number <> 0 Then
        MsgBox "cmdOK_Click - Error#" & Err.Number & vbCrLf & Err.Description, _
            vbCritical, "Error", Err.HelpFile, Err.HelpContext
    End If
    If Not cn Is Nothing Then
        If cn.Errors.Count > 0 Then
            Dim errLoop As ADODB.Error
            For Each errLoop In cn.Errors
                MsgBox "cmdOK_Click-Error number: " & errLoop.Number & vbCr & _
                    errLoop.Description, vbCritical, "Error", _
                    errLoop.HelpFile, errLoop.HelpContext
            Next errLoop
        End If
    End If
    On Error Resume Next
    If rs.State > 0 Then rs.Close    'Close the record set
    If cn.State > 0 Then cn.Close
    On Error GoTo 0
End Sub
'   Double click on the list
Private Sub lstList_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
End Sub
'   Activate the form
Private Sub UserForm_Activate()
    Me.Left = Application.Left + Application.Width / 2 - Me.Width / 2
    bOK = False
    lstList.Visible = False
    lstList.ColumnWidths = txtID.Width & ";" & txtDescription.Width
    sID = "%"
    sDesc = ""
    lblMessage = "Wildcard characters: '_'(underscore) replaces " & _
                 "just 1 characater  '%' replaces many"
End Sub
'   Functions
'   Replaces a "?" in an SQL string with something else
Private Function InsertSQLVariable(sSQL As String, sVariable As String)
    Dim i As Integer        'Generic integer
    i = InStr(1, sSQL, "?")
    InsertSQLVariable = Left(sSQL, i - 1) & sVariable & _
                        Right(sSQL, Len(sSQL) - i)
End Function

In the next post we will create frmPrompt and connect frmSelect_Multiple to it.

1  Comment on this Post

There was an error processing your information. Please try again later.
Thanks. We'll let you know when a new response is added.
Send me notifications when other members comment.
  • bipin1950
    Excellent > working on the same very useful to create Data Base also
    10 pointsBadges:

Forgot Password

No problem! Submit your e-mail address below. We'll send you an e-mail containing your password.

Your password has been sent to:

Share this item with your network: