Liren Large Software Subsidy 10/10.iso/l/l406/4.ddi/QUERY.FR_/QUERY.bin

Visual Basic Form | 1992-10-21 | 17.2 KB | 581 lines

VERSION 2.00
Begin Form fQuery
   BackColor       =   &H00C0C0C0&
   Caption         =   "Query Builder"
   Height          =   5535
   Icon            =   QUERY.FRX:0000
   KeyPreview      =   -1  'True
   Left            =   1170
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MDIChild        =   -1  'True
   ScaleHeight     =   5112
   ScaleMode       =   0  'User
   ScaleWidth      =   7116
   Top             =   810
   Width           =   7215
   Begin CommandButton JoinButton
      Caption         =   "Set Table &Joins"
      Height          =   256
      Left            =   4427
      TabIndex        =   27
      Top             =   2529
      Width           =   2528
   End
   Begin ListBox cJoinFields
      Height          =   421
      Left            =   4427
      TabIndex        =   26
      Top             =   2770
      Width           =   2528
   End
   Begin CommandButton CopySQLButton
      Caption         =   "&Copy SQL"
      Height          =   376
      Left            =   2991
      TabIndex        =   25
      Top             =   4696
      Width           =   1092
   End
   Begin ComboBox cOrderByField
      BackColor       =   &H00FFFFFF&
      Height          =   301
      Left            =   4427
      Style           =   2  'Dropdown List
      TabIndex        =   23
      Top             =   2168
      Width           =   2528
   End
   Begin ComboBox cGroupByField
      BackColor       =   &H00FFFFFF&
      Height          =   301
      Left            =   4427
      Style           =   2  'Dropdown List
      TabIndex        =   21
      Top             =   1565
      Width           =   2528
   End
   Begin Frame ExpressionBox
      BackColor       =   &H00C0C0C0&
      Caption         =   "(Expressions)"
      Height          =   1305
      Left            =   120
      TabIndex        =   10
      Top             =   0
      Width           =   6835
      Begin PictureBox Filler
         BackColor       =   &H00C0C0C0&
         BorderStyle     =   0  'None
         Height          =   288
         Left            =   6370
         ScaleHeight     =   288
         ScaleMode       =   0  'User
         ScaleWidth      =   108
         TabIndex        =   20
         Top             =   600
         Width           =   108
      End
      Begin CommandButton ANDButton
         Caption         =   "&And into Criteria"
         Height          =   252
         Left            =   120
         TabIndex        =   19
         Top             =   960
         Width           =   1812
      End
      Begin CommandButton ORButton
         Caption         =   "&Or into Criteria"
         Height          =   252
         Left            =   2040
         TabIndex        =   18
         Top             =   960
         Width           =   1812
      End
      Begin ComboBox cField
         BackColor       =   &H00FFFFFF&
         Height          =   288
         Left            =   120
         Style           =   2  'Dropdown List
         TabIndex        =   14
         Top             =   600
         Width           =   2652
      End
      Begin ComboBox cOperator
         Height          =   288
         Left            =   2880
         Style           =   2  'Dropdown List
         TabIndex        =   13
         Top             =   600
         Width           =   1092
      End
      Begin ComboBox cValue
         Height          =   288
         Left            =   4080
         Sorted          =   -1  'True
         TabIndex        =   12
         Text            =   "cValue"
         Top             =   600
         Width           =   2652
      End
      Begin CommandButton GetValuesButton
         Caption         =   "List Possible &Values"
         Height          =   252
         Left            =   4200
         TabIndex        =   11
         Top             =   960
         Width           =   2292
      End
      Begin Label FieldNameLabel
         BackColor       =   &H00C0C0C0&
         Caption         =   "Field Name:"
         Height          =   252
         Left            =   120
         TabIndex        =   17
         Top             =   360
         Width           =   1332
      End
      Begin Label ValueLabel
         BackColor       =   &H00C0C0C0&
         Caption         =   "Value:"
         Height          =   252
         Left            =   4080
         TabIndex        =   16
         Top             =   360
         Width           =   1452
      End
      Begin Label OperatorLabel
         BackColor       =   &H00C0C0C0&
         Caption         =   "Operator:"
         Height          =   252
         Left            =   2880
         TabIndex        =   15
         Top             =   360
         Width           =   972
      End
   End
   Begin ListBox cTableList
      Height          =   1596
      Left            =   120
      MultiSelect     =   1  'Simple
      TabIndex        =   9
      Top             =   1565
      Width           =   1570
   End
   Begin CommandButton ShowSQLButton
      Caption         =   "&Show SQL"
      Height          =   376
      Left            =   1675
      TabIndex        =   8
      Top             =   4696
      Width           =   1092
   End
   Begin ListBox cShowFields
      Height          =   1596
      Left            =   1795
      MultiSelect     =   1  'Simple
      TabIndex        =   5
      Top             =   1565
      Width           =   2528
   End
   Begin CommandButton CloseButton
      Caption         =   "Close"
      Height          =   376
      Left            =   5623
      TabIndex        =   2
      Top             =   4696
      Width           =   1092
   End
   Begin CommandButton RunQueryButton
      Caption         =   "&Run Query"
      Height          =   376
      Left            =   359
      TabIndex        =   1
      Top             =   4696
      Width           =   1092
   End
   Begin CommandButton ClearButton
      Caption         =   "C&lear All"
      Height          =   376
      Left            =   4307
      TabIndex        =   0
      Top             =   4696
      Width           =   1092
   End
   Begin TextBox cCriteria
      Height          =   1219
      Left            =   120
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   3
      Top             =   3372
      Width           =   6835
   End
   Begin Label OrberByFieldLabel
      BackColor       =   &H00C0C0C0&
      Caption         =   "Order By Field:"
      Height          =   256
      Left            =   4427
      TabIndex        =   24
      Top             =   1927
      Width           =   2049
   End
   Begin Label GroupByFieldLabel
      BackColor       =   &H00C0C0C0&
      Caption         =   "Group By Field:"
      Height          =   256
      Left            =   4427
      TabIndex        =   22
      Top             =   1355
      Width           =   2049
   End
   Begin Label TableListLabel
      BackColor       =   &H00C0C0C0&
      Caption         =   "Select Tables:"
      Height          =   256
      Left            =   120
      TabIndex        =   7
      Top             =   1355
      Width           =   1451
   End
   Begin Label ShowFieldsLabel
      BackColor       =   &H00C0C0C0&
      Caption         =   "Select Fields to Show:"
      Height          =   256
      Left            =   1795
      TabIndex        =   6
      Top             =   1355
      Width           =   2049
   End
   Begin Label CriteriaLabel
      BackColor       =   &H00C0C0C0&
      Caption         =   "Criteria:"
      Height          =   256
      Left            =   120
      TabIndex        =   4
      Top             =   3161
      Width           =   1331
   End
Dim FShowSQL As Integer
Dim FCopySQL As Integer
Sub ANDButton_Click ()
  Dim f As Field
  If cField = "" Then Exit Sub
  Set f = gCurrentDB.TableDefs(stSTF((cField), 0)).Fields(stSTF((cField), 1))
  If cCriteria <> "" Then
    cCriteria = cCriteria + Chr(13) + Chr(10) + "And "
  End If
  If f.Type = FT_STRING Or f.Type = FT_MEMO Or f.Type = FT_DATETIME Then
    cCriteria = cCriteria + cField + " " + cOperator + " '" + cValue + "'"
  Else
    cCriteria = cCriteria + cField + " " + cOperator + " " + cValue
  End If
  cField.SetFocus
End Sub
Sub cField_Click ()
  cValue.Clear
End Sub
Sub ClearButton_Click ()
  cCriteria = ""
End Sub
Sub CloseButton_Click ()
  Unload Me
End Sub
Sub CopySQLButton_Click ()
  FCopySQL = True
  Call RunQueryButton_Click
  FCopySQL = False
End Sub
Sub cTableList_Click ()
  Dim i As Integer, ii As Integer
  Dim t As TableDef
  Dim st As String
  MsgBar "Updating Form Fields", True
  cField.Clear
  cShowFields.Clear
  cGroupByField.Clear
  cOrderByField.Clear
  cValue.Clear
  cGroupByField.AddItem "(none)"
  cOrderByField.AddItem "(none)"
  For ii = 0 To cTableList.ListCount - 1
    If cTableList.Selected(ii) Then
      Set t = gCurrentDB.TableDefs(cTableList.List(ii))
      t.Fields.Refresh
      For i = 0 To t.Fields.Count - 1
        st = cTableList.List(ii) + "." + t.Fields(i).Name
        cField.AddItem st
        cShowFields.AddItem st
        cGroupByField.AddItem st
        cOrderByField.AddItem st
      Next
    End If
  Next
  If cField.List(0) <> "" Then
    cField.ListIndex = 0
    cGroupByField.ListIndex = 0
    cOrderByField.ListIndex = 0
  End If
  MsgBar "", False
End Sub
Sub Form_Load ()
   On Local Error GoTo FLErr
   Dim ds As DynaSet
   Dim i As Integer
   Dim t As TableDef
   'Clear listbox
   cCriteria = ""
   'Fill the Operator combo
   cOperator.AddItem "="
   cOperator.AddItem "<>"
   cOperator.AddItem ">"
   cOperator.AddItem ">="
   cOperator.AddItem "<"
   cOperator.AddItem "<="
   cOperator.AddItem "Like"
   cOperator.ListIndex = 0
   'fill the table list
   For i = 0 To fTables.cTableList.ListCount - 1
     cTableList.AddItem fTables.cTableList.List(i)
   Next
   cTableList.ListIndex = 0
   cValue = ""
  GoTo FLEnd
FLErr:
  ShowError
  Resume FLEnd
FLEnd:
  Height = 5520
  Width = 7224
  Left = (VDMDI.Width - Width) / 2
  Top = 0
End Sub
Sub Form_Resize ()
  If WindowState <> 1 Then
    Height = 5520
    Width = 7224
  End If
End Sub
Sub GetValuesButton_Click ()
  Dim ds As DynaSet
  On Error GoTo GVErr
  MsgBar "Getting Possible Values", True
  SetHourGlass Me
  Set ds = gCurrentDB.CreateDynaset("select Distinct " + (cField) + " from " + stSTF((cField), 0))
  Do While ds.EOF = False
    If Trim(ds(0)) <> "" Then
      cValue.AddItem ds(0).Value
    End If
    ds.MoveNext
  Loop
  ds.Close
  cValue = cValue.List(0)
  cValue.SetFocus
  GoTo GVEnd
GVErr:
  cValue = ""
  Resume GVEnd
GVEnd:
  ResetMouse Me
  MsgBar "", False
End Sub
Sub JoinButton_Click ()
  Dim i As Integer
  Dim c As Integer
  For i = 0 To cTableList.ListCount - 1
    If cTableList.Selected(i) = True Then
      c = c + 1
    End If
  Next
  If c < 2 Then
    Beep
    MsgBox "You Must Have at Least 2 Tables Selected!", 48
  Else
    MsgBar "Choose Joins", False
    fJoin.Show MODAL
    MsgBar "", False
  End If
End Sub
Sub ORButton_Click ()
  Dim f As Field
  If cField = "" Then Exit Sub
  Set f = gCurrentDB.TableDefs(stSTF((cField), 0)).Fields(stSTF((cField), 1))
  If cCriteria <> "" Then
    cCriteria = cCriteria + Chr(13) + Chr(10) + " Or "
  End If
  If f.Type = FT_STRING Or f.Type = FT_MEMO Or f.Type = FT_DATETIME Then
    cCriteria = cCriteria + cField + " " + cOperator + " '" + cValue + "'"
  Else
    cCriteria = cCriteria + cField + " " + cOperator + " " + cValue
  End If
  cField.SetFocus
End Sub
Sub RunQueryButton_Click ()
  On Error GoTo OKErr
     Dim ds As DynaSet
     Dim fs As String
     Dim ts As String
     Dim i As Integer
    MsgBar "Building Query", True
     If cCriteria <> "" Then
       stWhere$ = "AND " + LTrim(cCriteria)
       'strip CRLFs
       For i = 1 To Len(stWhere$)
         If Mid(stWhere$, i, 1) = Chr$(13) Then
           stTmp$ = stTmp$ + " "
         ElseIf Mid(stWhere$, i, 1) = Chr$(10) Then
           'do nothing
         Else
           stTmp$ = stTmp$ + Mid(stWhere$, i, 1)
         End If
       Next
       stWhere$ = stTmp$
       stWhere$ = RTrim(stWhere$)

       'Add parens to stWhere$
        stTmpWhere$ = stWhere$
        Do
          stTmp$ = stGetToken(stTmpWhere$, " ")
          If fMatchParen% = False And UCase(stTmp$) = "AND" Then
            stNewWhere$ = stNewWhere$ + stTmp$ + " ("
            fMatchParen% = True
          ElseIf fMatchParen% = True And UCase(stTmp$) = "AND" Then
            stNewWhere$ = stNewWhere$ + ") " + stTmp$ + " ("
            'fMatchParen% = False
          Else
            If UCase(stTmp$) = "OR" Or UCase(stTmp$) = "IN" Or UCase(stTmp$) = "LIKE" Then
              stNewWhere$ = stNewWhere$ + " " + stTmp$ + " "
            Else
              stNewWhere$ = stNewWhere$ + stTmp$
            End If
          End If
        Loop Until stTmpWhere$ = ""
        stWhere$ = stNewWhere$ + ")"
       'Build DynaSet string:
       'Peel off leading AND/OR
       If Mid(stWhere$, 2, 2) = "OR" Then
         stWhere$ = Mid(stWhere$, 5, Len(stWhere$) - 5)
       Else
         stTmp$ = stGetToken(stWhere$, " ")
       End If
       If stWhere$ <> "" Then
         stWhere$ = " Where " + stWhere$
       End If
     End If
     'check for join condition
     If cJoinFields.ListCount > 0 Then
       If stWhere$ = "" Then
         stWhere$ = stWhere$ + " Where "
       Else
         stWhere$ = stWhere$ + " And "
       End If
       For i = 0 To cJoinFields.ListCount - 1
         stWhere$ = stWhere$ + cJoinFields.List(i) + " And "
       Next
       stWhere$ = Mid(stWhere$, 1, Len(stWhere$) - 5)
     End If

     'check for group by field
     If cGroupByField <> "(none)" Then
       stWhere$ = stWhere$ + " Group By " + cGroupByField
     End If
     'check for order by field
     If cOrderByField <> "(none)" Then
       stWhere$ = stWhere$ + " Order By " + cOrderByField
     End If
     'get show field names
     For i% = 0 To cShowFields.ListCount - 1
       If cShowFields.Selected(i%) Then
         fs = fs + cShowFields.List(i%) + ","
       End If
     Next
     If fs = "" Then
       For i% = 0 To cTableList.ListCount - 1
         If cTableList.Selected(i%) Then
           fs = fs + cTableList.List(i%) + ".*,"
         End If
       Next
       If fs = "" Then
         fs = "*"
       Else
         fs = Mid(fs, 1, Len(fs) - 1)     'take off the last ","
       End If
     Else
       fs = Mid(fs, 1, Len(fs) - 1)
     End If
     'get table names
     For i% = 0 To cTableList.ListCount - 1
       If cTableList.Selected(i%) Then
         ts = ts + cTableList.List(i%) + ","
       End If
     Next
     ts = Mid(ts, 1, Len(ts) - 1)
     gstDynaString = "Select " + fs + " From " + ts + stWhere$

     If FShowSQL = False And FCopySQL = False Then
       MsgBar "Running Query", True
       gfFromSQL = True
       'create a new dynaset form
       If VDMDI.cSingleRecord = True Then
         Dim dsform1 As New fDynaset
         dsform1.Show
       Else
         Dim dsform2 As New fGridFrm
         dsform2.Show
       End If
     ElseIf FShowSQL = True Then
       MsgBar "", False
       MsgBox gstDynaString, 0, "SQL Query"
     ElseIf FCopySQL = True Then
       fSQL.cSQLStatement = gstDynaString
     End If
  GoTo OKEnd
OKErr:
  If Err = 364 Then Resume OKEnd   'catch unloaded form
  ShowError
  Resume OKEnd
OKEnd:
  MsgBar "", False
End Sub
Sub ShowSQLButton_Click ()
  FShowSQL = True
  Call RunQueryButton_Click
  FShowSQL = False
End Sub
Function stGetToken (stLn$, stDelim$) As String
    On Error GoTo GetTokenError
    iOpenQuote% = InStr(1, stLn$, """")
    iDelim% = InStr(1, stLn$, stDelim$)
    If (iOpenQuote% > 0) And (iOpenQuote% < iDelim%) Then
         iCloseQuote% = InStr(iOpenQuote% + 1, stLn$, """")
         iDelim% = InStr(iCloseQuote% + 1, stLn$, stDelim$)
    End If
    If (iDelim% <> 0) Then
         stToken$ = LTrim$(RTrim$(Mid$(stLn$, 1, iDelim% - 1)))
         stLn$ = Mid$(stLn$, iDelim% + 1)
    Else
         stToken$ = LTrim$(RTrim$(Mid$(stLn$, 1)))
         stLn$ = ""
    End If
    If (Len(stToken$) > 0) Then
         If (Mid$(stToken$, 1, 1) = """") Then
              stToken$ = Mid$(stToken$, 2)
         End If
         If (Mid$(stToken$, Len(stToken$), 1) = """") Then
              stToken$ = Mid$(stToken$, 1, Len(stToken$) - 1)
         End If
    End If
    stGetToken = stToken$
GetTokenExit:
    Exit Function
GetTokenError:
    Resume GetTokenExit
End Function
'function to split the table and the field from a tbl.fld pair
Function stSTF (tf As String, part As Integer) As String
  If part = 0 Then
    stSTF = Mid(tf, 1, InStr(1, tf, ".") - 1)
  Else
    stSTF = Mid(tf, InStr(1, tf, ".") + 1, Len(tf))
  End If
End Function