Asking for It

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:
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)
End Sub
In the next post we will integrate this form into Macro1(). See you then.
 Comment on this Post