Dec 4 2009 10:20PM GMT

Asking for It

Craig Hatmaker Profile: Craig Hatmaker

frmPrompt

In the last two posts I provided two support forms, frmSearch_Multiple and frmDatePicker, for the form I’m going to show you now: frmPrompt (shown right). frmPrompt asks your customers for the parameters required to extract only the data they need for their reports. frmPrompt is very versatile and can probably handle about 90% of the requests you might receive. But think of frmPrompt as a template because there will be times when check boxes, radio buttons, drop down lists, and other form controls are better suited for your purposes. The nice thing is, you have all of the source code right here. You can change frmPrompt to whatever you want.

In this version of frmPrompt, we are asking for three parameters:

A date range – In this case, a range between which products were ordered. If the user prefers selecting dates from a calendar, they just click the calendar icon button beside the date text box to bring up last posts frmDatePicker.
Customer IDs – The user can narrow down orders based on who ordered them. Assuming the user doesn’t know all codes, they can select customer codes from frmSelect_Multipleby clicking the appropriate ellipse button.
Product Codes – The user can further narrow the list based on what products were ordered. The user can select product codes from frmSelect_Multipleby clicking the appropriate ellipse button.

To recreate this version of frmPrompt, get to the VBE (Alt-F11) and create a form with these controls:

Name	Type	Properties
frmPrompt	UserForm	Caption:=“Search Prompt”
lblDate	Label	Caption:=”Ordered Between:”
lblID1	Label	“Customer(s)”
lblID2	Label	“Product Code(s)”
lblMsg	Label	BorderStyle:=1 – frmBorderStyleSingle
txtFrom	TextBox
txtTo	TextBox
txtID1	TextBox
txtID2	TextBox
cmdFrom	CommandButton	Width:=18 Height:=18 Picture:= (copy this picture to your library and select it)
cmdTo	CommandButton	(Same as cmdFrom)
cmdID1	CommandButton	Width:=18 Height:=18 Caption:=”…”
cmdID2	CommandButton	(Same as cmdID1)
cmdExit	CommandButton	Caption:=”OK”, Default:=True, TabStop:=True
cmdOK	CommandButton	Caption:=”Exit”, Cancel:=True, TabStop:=True

By now you’ve noticed that I like to have forms expose properties so they can be reused without modification. This allows me to concentrate those things I have to modify in only a very few places, and for now, that would be Macro1(). You’ll see lots of properties from frmPrompt in this code:

' Version 12/04/09

Option Explicit

'   Name: frmPrompt

'   Purpose: Ask the user for what they want to load

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

'   Example (How to use this form):

'Public Sub TestForm()

'   Dim i As Integer    'Generic Integer Variable

'   With frmPrompt

'        .pID1Visible = True
'        .pID1Lbl = "Customers(s)"
'        If .pID1 = "" Then .pID1 = "*ALL"
'        .pConnect1 = ConnectionString
'        .pLblCode1 = "Code"
'        .pLblDesc1 = "Customer Name"
'        .pTitle1 = "Select Customer(s)"
'        .pSQLCode1 = "Select   CUCODE as CODE, CUNAME as NAME " & _
'                     "From     CUSTMAST " & _
'                     "Where    Trim(UCase(CUCODE)) Like '?%' " & _
'                     "Order by CUCODE "
'        .pSQLDesc1 = "Select   CUCODE as CODE, CUNAME as NAME " & _
'                     "From     CUSTMAST " & _
'                     "Where    Trim(UCase(CUNAME)) Like '%?%' " & _
'                     "Order by CUNAME " '

'        .pID2Visible = False
'        .pFromVisible = True

'        .pDateLbl = "Last activity >:"
'        If .pFrom = "" Then .pFrom = Format(Int(Now() - 365), "mm/dd/yy")
'        .pToVisible = False
'      .Show                        'Display the Prompt
'       Do While .Visible           'Just pass time while the form is displayed
'           DoEvents
'       Loop
'       If .pOK Then                'The OK button was used to exit
'           Debug.Print .pFrom, .pTo, .pID1, .pID2
'       End If
'   End With

'End Sub

    Dim bOK As Boolean        'OK button pressed flag

'   frmSelect_Multiple settings for ID1
    Dim sConnect1 As String   'Connection String
    Dim sTitle1   As String   'Form Title
    Dim sLblCode1 As String   'ID column label
    Dim sSQLCode1 As String   'SQL string for searching by ID
    Dim sLblDesc1 As String   'Description column label
    Dim sSQLDesc1 As String   'SQL String for searching by Description

'   frmSelect_Multiple settings for ID2
    Dim sConnect2 As String   'Connection String
    Dim sTitle2   As String   'Form Title
    Dim sLblCode2 As String   'ID column label
    Dim sSQLCode2 As String   'SQL string for searching by ID
    Dim sLblDesc2 As String   'Description column label
    Dim sSQLDesc2 As String   'SQL String for searching by Description

'   Properties

'   Dates
Public Property Let pDateLbl(sString As String)
     lblDate.Caption = sString
End Property

'   From Date
Public Property Let pFromVisible(bFlag As Boolean)
    lblDate.Visible = bFlag
    txtFrom.Visible = bFlag
    cmdFrom.Visible = bFlag
End Property
Public Property Let pFrom(sString As String)
    txtFrom.Text = sString
End Property
Public Property Get pFrom() As String 
   pFrom = txtFrom.Text
End Property

'   To Date
Public Property Let pToVisible(bFlag As Boolean)
    txtTo.Visible = bFlag
    cmdTo.Visible = bFlag
End Property
Public Property Let pTo(sString As String)
    txtTo.Text = sString
End Property
Public Property Get pTo() As String 
   pTo = txtTo.Text
End Property

'   ID1
Public Property Let pID1Visible(bFlag As Boolean)
    lblID1.Visible = bFlag
    txtID1.Visible = bFlag
    cmdID1.Visible = bFlag
End Property
Public Property Let pID1Lbl(sString As String)
    lblID1.Caption = sString
End Property
Public Property Let pID1(sString As String)
    txtID1.Text = sString
End Property
Public Property Get pID1() As String
    pID1 = txtID1.Text
End Property
Public Property Let pConnect1(sString As String)
    sConnect1 = sString
    cmdID1.Visible = Trim(sString) <> ""
End Property
Public Property Let pTitle1(sString As String)
    sTitle1 = sString
End Property
Public Property Let pLblCode1(sString As String)
    sLblCode1 = sString
End Property
Public Property Let pSQLCode1(sString As String)
    sSQLCode1 = sString
End Property
Public Property Let pLblDesc1(sString As String)
    sLblDesc1 = sString
End Property
Public Property Let pSQLDesc1(sString As String)
    sSQLDesc1 = sString
End Property

'   ID2
Public Property Let pID2Visible(bFlag As Boolean)
    lblID2.Visible = bFlag
    txtID2.Visible = bFlag
End Property
Public Property Let pID2Lbl(sString As String)
    lblID2.Caption = sString
End Property
Public Property Let pID2(sString As String)
    txtID2.Text = sString
End Property
Public Property Get pID2() As String
    pID2 = txtID2.Text
End Property
Public Property Let pConnect2(sString As String)
    sConnect2 = sString
    cmdID2.Visible = Trim(sString) <> ""
End Property
Public Property Let pTitle2(sString As String)
    sTitle2 = sString
End Property
Public Property Let pLblCode2(sString As String)
    sLblCode2 = sString
End Property
Public Property Let pSQLCode2(sString As String)
    sSQLCode2 = sString
End Property
Public Property Let pLblDesc2(sString As String)
    sLblDesc2 = sString
End Property
Public Property Let pSQLDesc2(sString As String)
    sSQLDesc2 = sString
End Property

'   OK button
Public Property Get pOK() As Boolean 
   pOK = bOK
End Property

'   Event Handlers

'   From Date Picker
Private Sub cmdFrom_Click()

    On Error GoTo ErrorHandler

        With frmDatePicker
            .Top = Me.Top + cmdFrom.Top + 20
            .Left = Me.Left + cmdFrom.Left + cmdFrom.Width + 8
            .pDate = IIf(IsDate(txtFrom), txtFrom, Format(Now(), "mm/dd/yy"))
            .Show
            Do While .Visible
                DoEvents
            Loop
            If.pOK Then txtFrom = .pDate
        End With

ErrorHandler:

    On Error GoTo 0

End Sub

'   To Date Picker
Private Sub cmdTo_Click()

    On Error GoTo ErrorHandler

    With frmDatePicker
        .Top = Me.Top + cmdTo.Top + 20
        .Left = Me.Left + cmdTo.Left + cmdTo.Width + 8
        .pDate = IIf(IsDate(txtTo), txtTo, Format(Now(), "mm/dd/yy"))
        .Show
        Do While .Visible
            DoEvents
        Loop
        If .pOK Then txtTo = .pDate
    End With

ErrorHandler:

    On Error GoTo 0

End Sub


'   ID1 Elipse Button
Private Sub cmdID1_Click()

   With frmSelect_Multiple
      .pConnect = sConnect1
      .pTitle = sTitle1
      .pSelections = IIf(UCase(txtID1) = "*ALL", "", txtID1)
      .pLblCode = sLblCode1
      .pSQLCode = sSQLCode1
      .pLblDesc = sLblDesc1
      .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


'   ID2 Elipse Button
Private Sub cmdID2_Click()

   WithfrmSelect_Multiple
      .pConnect = sConnect2
      .pTitle = sTitle2
      .pSelections = IIf(UCase(txtID2) = "*ALL", "", txtID1)
      .pLblCode = sLblCode2
      .pSQLCode = sSQLCode2
      .pLblDesc = sLblDesc2
      .pSQLDesc = sSQLDesc2
      .Show
       Do While .Visible
           DoEvents
       Loop
       If.pOK Then   'The OK button was used to exit
            If UCase(txtID2) = "*ALL" Then txtID2 = ""
            txtID2 = .pSelections
            txtID2.ForeColor = RGB(0, 0, 0)
            txtID2.BackColor = RGB(256, 256, 256)
       End If
   End With

End Sub


'   OK Button
Private Sub cmdOK_Click()

    Dim s As String             'Generic String
    Dim bError As Boolean 
        bError = False

        ResetTextColor

    If txtFrom.Visible Then
        If txtFrom > "" And NotIsDate(txtFrom) Then
            SetError txtFrom, False, "Please check date"
            bError = True
        End If
    End If
    If Not bError And txtTo.Visible Then
        If txtTo > "" And Not IsDate(txtTo) Then 
            SetError txtTo, False, "Please check date"
            bError = True
        End If
    End If
    If Not bError And txtTo.Visible Then
        If DateValue(txtFrom) > DateValue(txtTo) Then 
            s = txtFrom  
            txtFrom = txtTo
            txtTo = s
            SetError txtFrom, True, ""
            SetError txtTo, True, "From & To dates swapped. Click OK."
            bError = True
        End If
    End If
    If NotbError And txtID1.Visible Then
        If(InStr(1, txtID1, "*") > 0 Or_
            InStr(1, txtID1, "?") > 0) And_
            InStr(1, txtID1, ",") > 0 Then 
            SetError txtID1, False, "Cannot mix wildcards w/multiple selections"
            bError = True
        End If
    End If
    If NotbError And txtID2.Visible Then
        If(InStr(1, txtID2, "*") > 0 Or_
            InStr(1, txtID2, "?") > 0) And_
            InStr(1, txtID2, ",") > 0 Then 
            SetError txtID2, False, "Cannot mix wildcards w/multiple selections"
            bError = True
        End If
    End If
   
    If Not bError Then 
        lblMsg.ForeColor = RGB(0, 127, 0)
        lblMsg = "Working - This can take a minute or two."
        bOK = True 
        lblMsg = ""
        Me.Hide
    End If
       
End Sub


'   Exit Button
Private Sub cmdExit_Click()

    Me.Hide

End Sub

'   Activate Form
Private Sub UserForm_Activate()

    ResetTextColor
    cmdID1.Visible = sConnect1 > ""
    cmdID2.Visible = sConnect2 > ""
    Me.Left = Application.Left + Application.Width / 2 - Me.Width / 2
    bOK = False 
    lblMsg = ""

End Sub


'   Sets error communication
Private Sub SetError(ctrl As Control, bWarn As Boolean, sErrMsg As String)

    Beep
    If bWarn Then 
        ctrl.BackColor = RGB(256, 256, 0)   'Yellow
        ctrl.ForeColor = RGB(0, 0, 0)       'Black
    Else
        ctrl.BackColor = RGB(256, 0, 0)     'Red
        ctrl.ForeColor = RGB(256, 256, 0)   'Yellow
    End If 
    lblMsg.ForeColor = RGB(127, 0, 0)       'Dark Red
    lblMsg = sErrMsg

End Sub


'   Clears any error coloring
Private Sub ResetTextColor()

    txtFrom.ForeColor = RGB(0, 0, 0)
    txtFrom.BackColor = RGB(256, 256, 256)
    txtTo.ForeColor = RGB(0, 0, 0)
    txtTo.BackColor = RGB(256, 256, 256)
    txtID1.ForeColor = RGB(0, 0, 0)
    txtID1.BackColor = RGB(256, 256, 256)
    txtID2.ForeColor = RGB(0, 0, 0)
    txtID2.BackColor = RGB(256, 256, 256)