home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / CODE_UPLOAD1302012242000.psc / frmParamQuery.frm (.txt) < prev    next >
Encoding:
Visual Basic Form  |  2000-12-24  |  8.5 KB  |  275 lines
  1. VERSION 5.00
  2. Begin VB.Form frmParamQuery 
  3.    BorderStyle     =   3  'Fixed Dialog
  4.    Caption         =   "Get Selected Colors"
  5.    ClientHeight    =   2796
  6.    ClientLeft      =   1092
  7.    ClientTop       =   336
  8.    ClientWidth     =   5400
  9.    LinkTopic       =   "Form3"
  10.    MaxButton       =   0   'False
  11.    MinButton       =   0   'False
  12.    ScaleHeight     =   2796
  13.    ScaleWidth      =   5400
  14.    ShowInTaskbar   =   0   'False
  15.    StartUpPosition =   2  'CenterScreen
  16.    Begin VB.CommandButton cmdReset 
  17.       Caption         =   "Reset"
  18.       BeginProperty Font 
  19.          Name            =   "MS Sans Serif"
  20.          Size            =   7.8
  21.          Charset         =   0
  22.          Weight          =   700
  23.          Underline       =   0   'False
  24.          Italic          =   0   'False
  25.          Strikethrough   =   0   'False
  26.       EndProperty
  27.       Height          =   732
  28.       Left            =   4200
  29.       TabIndex        =   4
  30.       Top             =   1680
  31.       Width           =   972
  32.    End
  33.    Begin VB.ListBox lstNew 
  34.       BeginProperty Font 
  35.          Name            =   "MS Sans Serif"
  36.          Size            =   7.8
  37.          Charset         =   0
  38.          Weight          =   700
  39.          Underline       =   0   'False
  40.          Italic          =   0   'False
  41.          Strikethrough   =   0   'False
  42.       EndProperty
  43.       ForeColor       =   &H000000FF&
  44.       Height          =   2160
  45.       ItemData        =   "frmParamQuery.frx":0000
  46.       Left            =   240
  47.       List            =   "frmParamQuery.frx":0002
  48.       TabIndex        =   3
  49.       Top             =   360
  50.       Visible         =   0   'False
  51.       Width           =   3732
  52.    End
  53.    Begin VB.CommandButton cmdGetColors 
  54.       Caption         =   "Get Colors"
  55.       BeginProperty Font 
  56.          Name            =   "MS Sans Serif"
  57.          Size            =   7.8
  58.          Charset         =   0
  59.          Weight          =   700
  60.          Underline       =   0   'False
  61.          Italic          =   0   'False
  62.          Strikethrough   =   0   'False
  63.       EndProperty
  64.       Height          =   732
  65.       Left            =   4200
  66.       TabIndex        =   2
  67.       Top             =   552
  68.       Width           =   972
  69.    End
  70.    Begin VB.ListBox lstColors 
  71.       BeginProperty Font 
  72.          Name            =   "MS Sans Serif"
  73.          Size            =   7.8
  74.          Charset         =   0
  75.          Weight          =   700
  76.          Underline       =   0   'False
  77.          Italic          =   0   'False
  78.          Strikethrough   =   0   'False
  79.       EndProperty
  80.       Height          =   2208
  81.       ItemData        =   "frmParamQuery.frx":0004
  82.       Left            =   240
  83.       List            =   "frmParamQuery.frx":0006
  84.       Style           =   1  'Checkbox
  85.       TabIndex        =   0
  86.       Top             =   360
  87.       Width           =   3732
  88.    End
  89.    Begin VB.Label Label1 
  90.       Caption         =   "Color Selector"
  91.       BeginProperty Font 
  92.          Name            =   "MS Sans Serif"
  93.          Size            =   7.8
  94.          Charset         =   0
  95.          Weight          =   700
  96.          Underline       =   0   'False
  97.          Italic          =   0   'False
  98.          Strikethrough   =   0   'False
  99.       EndProperty
  100.       Height          =   252
  101.       Left            =   240
  102.       TabIndex        =   1
  103.       Top             =   120
  104.       Width           =   1932
  105.    End
  106. Attribute VB_Name = "frmParamQuery"
  107. Attribute VB_GlobalNameSpace = False
  108. Attribute VB_Creatable = False
  109. Attribute VB_PredeclaredId = True
  110. Attribute VB_Exposed = False
  111. '*******************************************************************************
  112. ' MODULE:       ParamQuery
  113. ' FORM:         frmParamQuery
  114. ' DATABASE:     Text.mdb
  115. ' TABLE:        Color
  116. ' AUTHOR:       Jim Ryan
  117. ' EMAIL:        jprism@prism2000.net
  118. ' CREATED:      24-Dec-2000
  119. ' DESCRIPTION:
  120. '    This program demonstrates how one can
  121. '    allow a user to:
  122. '    1) Make one or more choices from a complete
  123. '       recordset (at runtime)
  124. '    2) Build a Parameter Query based on the selected
  125. '       items
  126. '    3) Run the Parameter Query
  127. ' MODIFICATION HISTORY:
  128. ' 1.0       24-Dec-2000
  129. '           Jim Ryan
  130. '           Initial Version
  131. '*******************************************************************************
  132. Option Explicit
  133. Private Rst As adodb.Recordset
  134. Attribute Rst.VB_VarHelpID = -1
  135. Private Sub cmdGetColors_Click()
  136.    Dim Cmd As adodb.Command
  137.    Dim Prm As adodb.Parameter
  138.    Dim Cnn As adodb.Connection
  139.    Dim Sql As String
  140.    Dim Colors() As Integer
  141.    Dim i As Integer
  142.    Dim c As Integer
  143.    On Error GoTo ErrorTrap
  144.    ' check to see if user has selected any
  145.    ' colors from the lstcolors list
  146.    If lstColors.SelCount = 0 Then
  147.       MsgBox "You must first select one or more colors, then click the Get Colors button"
  148.       Exit Sub
  149.    End If
  150.    Label1.Caption = "Selected Colors"
  151.    ' load the colors array with
  152.    ' the itemdata i.e. colorno
  153.    For i = 0 To lstColors.ListCount - 1
  154.       If lstColors.Selected(i) Then
  155.          ReDim Preserve Colors(c)
  156.          Colors(c) = lstColors.ItemData(i)
  157.          c = c + 1
  158.       End If
  159.    Next
  160.    ' Open a connection to the
  161.    ' Color.mdb database
  162.    Set Cnn = New Connection
  163.    Cnn.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;" & _
  164.             "Data Source= " & App.Path & "\Color.mdb;"
  165.    ' Setup the new command and
  166.    ' query
  167.    Set Cmd = New Command
  168.    Cmd.CommandType = adCmdText
  169.    ' build SQL string for all selected
  170.    ' colors
  171.    Sql = "SELECT  [color].[colorno], [color].[colorname] " & _
  172.          "FROM [color] WHERE"
  173.    For i = 0 To UBound(Colors)
  174.       Sql = Sql & " [color].[colorno] = ? OR"
  175.    Next
  176.    Sql = Left(Sql, Len(Sql) - 3) & " ORDER BY [color].[colorname]"
  177.    Cmd.CommandText = Sql
  178.    Cmd.Name = "adoCommand"
  179.    ' set each colors parameter to its
  180.    ' colorno
  181.    For i = 0 To UBound(Colors)
  182.       Set Prm = New Parameter
  183.       Prm.Name = "colorno"
  184.       Prm.Type = adInteger
  185.       Prm.Size = 4
  186.       Prm.Value = Colors(i)
  187.       Cmd.Parameters.Append Prm
  188.       Set Prm = Nothing
  189.    Next
  190.    ' set active connection and
  191.    ' execute recordset
  192.    Set Cmd.ActiveConnection = Cnn
  193.    Set Rst = Cmd.Execute
  194.    ' move through the recordset
  195.    ' and add the selected colors
  196.    ' to the lstnew list
  197.    lstNew.Clear
  198.    While Not Rst.EOF
  199.       lstNew.AddItem Rst![colorname]
  200.       Rst.MoveNext
  201.    Wend
  202.    lstColors.Visible = False
  203.    lstNew.Visible = True
  204. ExitOk:
  205.    On Error Resume Next
  206.    Set Cmd = Nothing
  207.    Set Prm = Nothing
  208.    Rst.Close
  209.    Set Rst = Nothing
  210.    Cnn.Close
  211.    Set Cnn = Nothing
  212.    On Error GoTo 0
  213.    Exit Sub
  214. ErrorTrap:
  215.    MsgBox "Error: " & Err.Number & vbCrLf & Err.Description
  216.    Resume ExitOk
  217. End Sub
  218. Private Sub cmdReset_Click()
  219.    Dim i As Integer
  220.    ' reset the selected items in
  221.    ' the lstcolors list
  222.    For i = 0 To lstColors.ListCount - 1
  223.       lstColors.Selected(i) = False
  224.    Next
  225.    ' clear the lstnew list and make
  226.    ' invisible
  227.    lstNew.Clear
  228.    lstNew.Visible = False
  229.    ' show the lstcolors list
  230.    lstColors.Visible = True
  231. End Sub
  232. Private Sub Form_Load()
  233.    Dim Src As String
  234.    Dim Sql As String
  235.    Dim MDBname As String
  236.    On Error GoTo ErrorTrap
  237.    ' check for the existence of the
  238.    ' Color.mdb database
  239.    MDBname = App.Path & "\Color.mdb"
  240.    If Dir(MDBname, vbNormal) = "" Then
  241.       MsgBox "The MDB database Color.mdb could not be found!"
  242.       Exit Sub
  243.    End If
  244.    ' Open a recordset on the color table
  245.    ' Src = "PROVIDER=Microsoft.Jet.OLEDB.3.51;Data Source= " & MDBname
  246.    Src = "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source= " & MDBname
  247.    Sql = "SELECT [color].[colorno], [color].[colorname] " & _
  248.          "FROM [color] ORDER BY [color].[colorname]"
  249.    Set Rst = New adodb.Recordset
  250.    Rst.CursorLocation = adUseClient
  251.    Rst.Open Sql, Src, adOpenForwardOnly, adLockReadOnly
  252.    lstColors.Clear
  253.    ' fill the lstColors list with
  254.    ' the colorno and colorname columns
  255.    While Not Rst.EOF
  256.       lstColors.AddItem Rst![colorname]
  257.       lstColors.ItemData(lstColors.NewIndex) = Rst![colorno]
  258.       Rst.MoveNext
  259.    Wend
  260.    ' notify the user if the lstcolors list
  261.    ' contains no records
  262.    If lstColors.ListCount < 0 Then
  263.       MsgBox "The table Color contains NO records..."
  264.    End If
  265. ExitOk:
  266.    On Error Resume Next
  267.    Rst.Close
  268.    Set Rst = Nothing
  269.    On Error GoTo 0
  270.    Exit Sub
  271. ErrorTrap:
  272.    MsgBox "Error: " & Err.Number & vbCrLf & Err.Description
  273.    Resume ExitOk
  274. End Sub
  275.