Check Entry – Form Select – Code

Today we add the code to frmSelect (See: frmSelect Visual Elements for what this form looks like, or frmSelect Theory to see how it works).  This code must be added to the form.  If you’re not sure how to do that, watch the video in frmSelect Visual Elements and at the tale end is where, in the Project Explorer you’ll see me right clicking on frmSelect and left clicking on “View Code.”  In the Code View Window is where you paste all the code provided. 

There’s a good bit of code but all you have to do is copy and paste it (with perhaps a tweak or two because this blog doesn’t always paste code nicely into the VBE).  And the really good news is that once you’ve saved this form, you’ll never have to change it again.  It has worked well over all master files or code files I’ve seen without any modifications. 

When finished, be sure to save your work.  You may also want to save the form as a separate object so you can import it into other Excel spreadsheets easily.  To export the form, in the Project Explorer right click on frmSelect and left clicked on “Export File…”  Here is the code:

Option Explicit

'   Name:   frmSelect

'   Purpose:Help user pick something by Code/ID/# or Description

'     Date   Init Modification
'   01/12/06 CWH  Initial Programming

'   Examples:

'   Pick State from an XL "Code" table
'   vResult = frmSelect.Pick_Code("States")

'   Pick Account from an XL "Type" table
'   vResult = frmSelect.Pick_Type("Accounts", "Credit")

'   See Methods Pick_Code and Pick_Type at the end of this form. _
    These can be used as is or copied and customized in a module

'   Set (Write Only) Property Variables
    Dim sConnect As String  'See property pConnect

    Dim sSQLCode As String  'See property pSQLCode
    Dim sSQLDesc As String  'See property pSQLDesc
   
    Dim sDesc As String     'See property pDftDesc
    Dim sCode As String     'See property pDftCode
   
'   Get(Read Only) Property Variables
    Dim bOK As Boolean      'See property pOK

'Begin Properties

'   Title Bar Text (Optional)
Public Property Let pTitle(sString As String)
    Me.Caption = sString
End Property

'   Connect - ODBC connection string (Required)
Public Property Let pConnect(sString As String)
    sConnect = sString
End Property

'   Code: These properties relate to the "Code" value
Public Property Let pCode(sString As String)    'Set value
    sCode = sString
End Property
Public Property Get pCode() As String           'Get value
    pCode = sCode
End Property
Public Property Let pLblCode(sString As String) 'Label for entry box
    lblCode.Caption = sString
End Property
Public Property Let pDftCode(sString As String) 'Default value
    txtCode.Text = sString
End Property
Public Property Let pSQLCode(sString As String) 'SQL Search String
'   The String must contain a valid SQL select statement with a "?"
'   to indicate where to substitute the txtID.text
    sSQLCode = sString
End Property

'   Description: These properties relate to teh "Description" value
Public Property Let pDesc(sString As String)    'Set value
    sDesc = sString
End Property
Public Property Get pDesc() As String           'Get value
    pDesc = sDesc
End Property
Public Property Let pLblDesc(sString As String) 'Label for entry box
    lblDesc.Caption = sString
End Property
Public Property Let pDftDesc(sString As String) 'Default value
    txtDesc.Text = sString
End Property
Public Property Let pSQLDesc(sString As String) 'SQL search string
'   The String must contain a valid SQL select statement with a "?"
'   to indicate where to substitute the txtDesc.text
    sSQLDesc = sString
End Property

'   True if the OK button was clicked
Public Property Get pOK() As Boolean
    pOK = bOK
End Property

'Begin Event Handlers

'   Exit Button
Private Sub cmdExit_Click() 'Exit Click

    Me.Hide

End Sub

'   OK Button
Private Sub cmdOK_Click()   'OK Click

    Dim i As Integer
    Dim sSQL As String
    Dim bfound As Boolean
   
    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 = ""
      
'   If the user changed the ID then create the SQL search string
    If txtCode <> sCode Then
        bfound = False
        If lstList.Visible Then
            For i = 0 To lstList.ListCount - 1
                If Trim(UCase(txtCode)) = _
                   Trim(UCase(lstList.List(i, 0))) Then
                    lstList.ListIndex = i
                    bfound = True
                    Exit For
                End If
            Next i
        End If
        If Not bfound Then
            sCode = txtCode
            txtDesc = ""
            sDesc = ""
            sSQL = InsertSQLVariable(sSQLCode, Trim(UCase(sCode)))
            txtCode.SetFocus
        End If
    End If

'   If user changed Description then create  SQL search string _
    (this overrides ID changes)
    If txtDesc <> sDesc Then
        sDesc = txtDesc
        txtCode = ""
        sCode = ""
        sSQL = InsertSQLVariable(sSQLDesc, Trim(UCase(sDesc)))
        txtDesc.SetFocus
    End If

'   If an SQL string was created above then search database
    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.Open sSQL, cn
   
        Debug.Print "End:", Time
        lstList.Clear
        If rs.EOF Then
            lblMessage = "No records found"
        Else
            lblMessage = ""
            rs.MoveFirst
            i = 0
            Do While Not rs.EOF
                lstList.AddItem rs(0)
                lstList.List(i, 1) = IIf(IsNull(rs(1)), " ", rs(1))
                rs.MoveNext
                i = i + 1
            Loop
            lstList.Visible = True
            lstList.SetFocus
        End If
        rs.Close
        cn.Close
       
'   If no SQL string was created (because user didn't change anything) _
    then did user select anything?
    Else

'       If anything was selected, were done!
        If lstList.Visible And lstList.Value > "" Then
            sCode = lstList.Value
            sDesc = lstList.List(lstList.ListIndex, 1)
            bOK = True
            Me.Hide
        End If
       
    End If
               
    On Error GoTo 0
    Exit Sub
   
ErrHandler:
               
    If cn.Errors.Count = 0 Then
        MsgBox "cmdOK_Click Error#" & Err.Number & vbCrLf & Err.Description, _
            vbCritical, "Error in cmdOK_Click", Err.HelpFile, Err.HelpContext
    Else
        For i = 0 To cn.Errors.Count - 1
            MsgBox "Error number: " & cn.Errors(i).Number & vbCr & _
               cn.Errors(i).Description, vbCritical, "Error in cmdOK_Click", _
               cn.Errors(i).HelpFile, cn.Errors(i).HelpContext
        Next i
    End If
       
    rs.Close
    cn.Close
  
End Sub

'   Double click on list selects the code and exits
Private Sub lstList_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

    sCode = lstList.Value
    txtCode = sCode
    cmdOK_Click

End Sub

'   Activate form
Private Sub UserForm_Activate()

   'Center form on screen
    Me.Left = Application.Left + Application.Width / 2 - Me.Width / 2
    bOK = False		'Assume the worst
    lstList.Visible = False
   'Set Column Widths of lstList to match the input text boxes
    lstList.ColumnWidths = txtCode.Width & ";" & txtDesc.Width
    sCode = ""		'Clear Text Boxes
    sDesc = ""
   'Give the users some instructions
    lblMessage = "Wildcard characters: '_'(underscore) " & _
                 "replaces just 1 character  '%' replaces many"
    cmdOK_Click		'List whatever is possible to list

End Sub

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

'   Pick a code from an Excel code table in the active spreadsheet

'   Table must have two columns: Code and Description
'   Where:
'       Code        unique identifier (ex. "VA" or "MD")
'       Description expanded text for the Code (ex. "Virginia" or "Maryland")

Public Function Pick_Code(sCodeTable As String) As Variant
  
   Pick_Code = Null
  
   With frmSelect
        .pConnect = _
            "DBQ=" & ActiveWorkbook.Path & "\" & ActiveWorkbook.Name & ";" & _
            "Driver={Microsoft Excel Driver (*.xls)};"
        .pLblCode = "Code"
        .pLblDesc = "Description"
        .pTitle = "Select Code from " & sCodeTable
        .pCode = ""
        .pDftCode = " "
        .pSQLCode = _
            "Select T.Code as CODE, T.Description as NAME " & _
            "From " & sCodeTable & " T " & _
            "Where Ucase(T.Code) Like '?%' " & _
            "Order by T.Code "
        .pSQLDesc = _
            "Select T.Code as CODE, T.Description as NAME " & _
            "From " & sCodeTable & " T " & _
            "Where Ucase(T.Description) Like '%?%' " & _
            "Order by T.Description "
        .Show
        Do While .Visible
            DoEvents
        Loop
        If .pOK Then   'The OK button was used to exit
            Pick_Code = .pCode
        End If
   End With

End Function

'   Pick a Type from an Excel code table in the active spreadsheet

'   Table must have three columns: Code, Type, & Description
'   Where:
'       Type        Major catagory (Country ex. "USA" or "Mexico")
'       Code        Individual element (State w/in Coutnry ex. "VA", or "MD")
'       Description Expanded text for Code (ex. "Virginia" or "Maryland")

Public Function Pick_Type(sCodeTable As String, sType As String) As Variant
  
   Pick_Type = Null
  
    With frmSelect
        .pConnect = _
            "DBQ=" & ActiveWorkbook.Path & "\" & ActiveWorkbook.Name & ";" & _
            "Driver={Microsoft Excel Driver (*.xls)};"
        .pLblCode = "Code"
        .pLblDesc = "Description"
        .pTitle = "Select Code of Type " & Trim(sType) & " from " & sCodeTable
        .pCode = ""
        .pDftCode = " "
        .pSQLCode = _
            "Select T.Code as CODE, T.Description as NAME " & _
            "From " & sCodeTable & " T " & _
            "Where Ucase(T.Code) Like '?%' " & _
            "  And Ucase(T.Type) = '" & UCase(sType) & "' " & _
            "Order by T.Code "
        .pSQLDesc = _
            "Select T.Code as CODE, T.Description as NAME " & _
            "From " & sCodeTable & " T " & _
            "Where Ucase(T.Description) Like '%?%' " & _
            "  And Ucase(T.Type) = '" & UCase(sType) & "' " & _
            "Order by T.Description "
      .Show
       Do While .Visible
           DoEvents
       Loop
       If .pOK Then   'The OK button was used to exit
            Pick_Type = .pCode
       End If
   End With

End Function