Master 95 #1

home *** CD-ROM | disk | FTP | other *** search

/ Master 95 #1 / MASTER95_1.iso / microsof / vbasic4 / vb4-6.cab / query.frm (.txt) < prev next >

Wrap

Visual Basic Form | 1995-07-26 | 20.7 KB | 697 lines

VERSION 4.00 Begin VB.Form frmQuery BorderStyle = 3 'Fixed Double Caption = "Query Builder" ClientHeight = 5025 ClientLeft = 1230 ClientTop = 1500 ClientWidth = 7455 Height = 5430 HelpContextID = 2016115 Icon = "QUERY.frx":0000 KeyPreview = -1 'True Left = 1170 LinkTopic = "Form1" LockControls = -1 'True MaxButton = 0 'False MDIChild = -1 'True ScaleHeight = 5007.369 ScaleMode = 0 'User ScaleWidth = 7477.065 Top = 1155 Width = 7575 Begin VB.OptionButton optOrder Caption = "Desc" Height = 225 Index = 1 Left = 6480 TabIndex = 10 Top = 1560 Width = 855 End Begin VB.OptionButton optOrder Caption = "Asc" Height = 221 Index = 0 Left = 5760 TabIndex = 9 Top = 1560 Value = -1 'True Width = 615 End Begin VB.CheckBox chkTopPercent Caption = "Top Percent" Height = 255 Left = 3840 TabIndex = 15 Top = 2880 Width = 2175 End Begin VB.TextBox txtTopNValue Height = 285 Left = 3000 TabIndex = 14 Top = 2880 Width = 735 End Begin VB.CommandButton cmdGetValues Caption = "List &Possible Values" Height = 315 Left = 4560 TabIndex = 5 Top = 600 Width = 2775 End Begin VB.CommandButton cmdOr Caption = "&Or into Criteria" Height = 315 Left = 2280 TabIndex = 4 Top = 600 Width = 2175 End Begin VB.CommandButton cmdAnd Caption = "&And into Criteria" Height = 315 Left = 120 TabIndex = 3 Top = 600 Width = 2175 End Begin VB.ComboBox cboValue BackColor = &H00FFFFFF& Height = 300 Left = 4560 Sorted = -1 'True TabIndex = 2 Text = "cValue" Top = 240 Width = 2775 End Begin VB.ComboBox cboOperator BackColor = &H00FFFFFF& Height = 300 ItemData = "QUERY.frx":030A Left = 3120 List = "QUERY.frx":0323 Style = 2 'Dropdown List TabIndex = 1 Top = 240 Width = 1335 End Begin VB.ComboBox cboField BackColor = &H00FFFFFF& Height = 300 Left = 120 Style = 2 'Dropdown List TabIndex = 0 Top = 240 Width = 2895 End Begin VB.CommandButton cmdSaveQDF Caption = "Sa&ve" Height = 375 Left = 3720 TabIndex = 20 Top = 4560 Width = 1215 End Begin VB.CommandButton cmdJoin Caption = "Set Table &Joins" Height = 255 Left = 4560 TabIndex = 12 Top = 2160 Width = 2775 End Begin VB.ListBox lstJoinFields BackColor = &H00FFFFFF& Height = 420 Left = 4560 TabIndex = 13 Top = 2400 Width = 2775 End Begin VB.CommandButton cmdCopySQL Caption = "Cop&y" Height = 375 Left = 2520 TabIndex = 19 Top = 4560 Width = 1215 End Begin VB.ComboBox cboOrderByField BackColor = &H00FFFFFF& Height = 300 Left = 4560 Style = 2 'Dropdown List TabIndex = 11 Top = 1800 Width = 2775 End Begin VB.ComboBox cboGroupByField BackColor = &H00FFFFFF& Height = 300 Left = 4560 Style = 2 'Dropdown List TabIndex = 8 Top = 1200 Width = 2775 End Begin VB.ListBox lstTables BackColor = &H00FFFFFF& Height = 1590 Left = 120 MultiSelect = 1 'Simple TabIndex = 6 Top = 1200 Width = 1815 End Begin VB.CommandButton cmdShowSQL Caption = "&Show" Height = 375 Left = 1320 TabIndex = 18 Top = 4560 Width = 1215 End Begin VB.ListBox lstShowFields BackColor = &H00FFFFFF& Height = 1590 Left = 2040 MultiSelect = 1 'Simple TabIndex = 7 Top = 1200 Width = 2295 End Begin VB.CommandButton cmdClose Cancel = -1 'True Caption = "&Close" Height = 375 Left = 6120 TabIndex = 22 Top = 4560 Width = 1215 End Begin VB.CommandButton cmdRunQuery Caption = "&Run" Height = 375 Left = 120 TabIndex = 17 Top = 4560 Width = 1215 End Begin VB.CommandButton cmdClear Caption = "C&lear" Height = 375 Left = 4920 TabIndex = 21 Top = 4560 Width = 1215 End Begin VB.TextBox txtCriteria BackColor = &H00FFFFFF& Height = 1215 Left = 120 MultiLine = -1 'True ScrollBars = 2 'Vertical TabIndex = 16 Top = 3240 Width = 7215 End Begin VB.Label lblTopN Caption = "Top N Value:" Height = 195 Left = 1440 TabIndex = 31 Top = 2910 Width = 1470 End Begin VB.Label lblOperator AutoSize = -1 'True Caption = "Operator:" Height = 195 Left = 3120 TabIndex = 30 Top = 0 Width = 660 End Begin VB.Label lblValue AutoSize = -1 'True Caption = "Value:" Height = 195 Left = 4560 TabIndex = 29 Top = 0 Width = 450 End Begin VB.Label lblFieldName AutoSize = -1 'True Caption = "Field Name:" Height = 195 Left = 120 TabIndex = 28 Top = 0 Width = 840 End Begin VB.Label lblOrberByField AutoSize = -1 'True Caption = "Order By: " Height = 195 Left = 4560 TabIndex = 27 Top = 1560 Width = 705 End Begin VB.Label lblGroupByField AutoSize = -1 'True Caption = "Group By: " Height = 195 Left = 4560 TabIndex = 26 Top = 960 Width = 750 End Begin VB.Label lblTableList AutoSize = -1 'True Caption = "Tables: " Height = 195 Left = 120 TabIndex = 25 Top = 960 Width = 570 End Begin VB.Label lblShowFields AutoSize = -1 'True Caption = "Fields to Show: " Height = 195 Left = 2040 TabIndex = 24 Top = 960 Width = 1125 End Begin VB.Label lblCriteria AutoSize = -1 'True Caption = "Criteria: " Height = 195 Left = 120 TabIndex = 23 Top = 3000 Width = 570 End Attribute VB_Name = "frmQuery" Attribute VB_Creatable = False Attribute VB_Exposed = False Option Explicit Dim mbShowSQL As Integer Dim mbCopySQL As Integer Dim mbSaveSQL As Integer Private Sub cmdAnd_Click() Dim nFldType As Integer Dim sFieldName As String Dim sTableName As String If Len(cboField.Text) = 0 Then Exit Sub sTableName = stSTF((cboField), 0) sFieldName = stSTF((cboField), 1) nFldType = gdbCurrentDB.TableDefs(StripBrackets(sTableName)).Fields(StripBrackets(sFieldName)).Type If Len(txtCriteria.Text) > 0 Then txtCriteria.Text = txtCriteria.Text & gsNewLine & "And " End If If nFldType = dbText Or nFldType = dbMemo Or nFldType = dbDate Then txtCriteria.Text = txtCriteria.Text & cboField.Text & " " & cboOperator.Text & " '" & cboValue.Text & "'" Else txtCriteria.Text = txtCriteria.Text & cboField.Text & " " & cboOperator.Text & " " & cboValue.Text End If cboField.SetFocus End Sub Private Sub cboField_Click() cboValue.Clear End Sub Private Sub cmdClear_Click() On Error Resume Next Dim i As Integer For i = 0 To lstTables.ListCount - 1 lstTables.Selected(i) = False Next txtCriteria.Text = gsNULL_STR txtTopNValue.Text = gsNULL_STR End Sub Private Sub cmdClose_Click() Unload Me End Sub Private Sub cmdCopySQL_Click() mbCopySQL = True Call cmdRunQuery_Click mbCopySQL = False End Sub Private Sub cmdSaveQDF_Click() mbSaveSQL = True Call cmdRunQuery_Click mbSaveSQL = False End Sub Private Sub lstTables_Click() On Error GoTo LTErr Dim i As Integer, ii As Integer Dim tdf As TableDef Dim qdf As QueryDef Dim sTmp As String Dim fld As Field MsgBar "Updating Form Fields", True cboField.Clear lstShowFields.Clear cboGroupByField.Clear cboOrderByField.Clear cboValue.Clear cboGroupByField.AddItem "(none)" cboOrderByField.AddItem "(none)" For ii = 0 To lstTables.ListCount - 1 If lstTables.Selected(ii) Then If lstTables.ItemData(ii) = 0 Then 'must be a table Set tdf = gdbCurrentDB.TableDefs(lstTables.List(ii)) For Each fld In tdf.Fields sTmp = AddBrackets((lstTables.List(ii))) & "." & AddBrackets((fld.Name)) cboField.AddItem sTmp lstShowFields.AddItem sTmp cboGroupByField.AddItem sTmp cboOrderByField.AddItem sTmp Next Else 'must be a querydef Set qdf = gdbCurrentDB.QueryDefs(lstTables.List(ii)) For Each fld In qdf.Fields sTmp = AddBrackets((lstTables.List(ii))) & "." & AddBrackets((fld.Name)) cboField.AddItem sTmp lstShowFields.AddItem sTmp cboGroupByField.AddItem sTmp cboOrderByField.AddItem sTmp Next End If End If Next If Len(cboField.List(0)) > 0 Then cboField.ListIndex = 0 cboGroupByField.ListIndex = 0 cboOrderByField.ListIndex = 0 End If MsgBar gsNULL_STR, False Exit Sub LTErr: ShowError Exit Sub End Sub Private Sub Form_Load() On Local Error GoTo FLErr Dim rec As Recordset Dim i As Integer 'Clear listbox txtCriteria.Text = gsNULL_STR cboOperator.ListIndex = 0 'fill the table list GetTableList lstTables, True, False, True lstTables.ListIndex = 0 cboValue.Text = gsNULL_STR Height = 5520 Width = 7224 Left = (frmMDI.Width - Width) / 2 Top = 0 Exit Sub FLErr: ShowError Exit Sub End Sub Private Sub Form_Resize() On Error Resume Next If WindowState <> 1 Then Me.Height = 5430 Me.Width = 7575 End If End Sub Private Sub cmdGetValues_Click() On Error GoTo GVErr Dim rec As Recordset MsgBar "Getting Possible Values", True SetHourglass Set rec = gdbCurrentDB.OpenRecordset("select Distinct " & cboField & " from " & stSTF((cboField), 0)) Do While rec.EOF = False If Len(Trim(rec(0))) > 0 Then cboValue.AddItem rec(0).Value End If rec.MoveNext Loop rec.Close cboValue.Text = cboValue.List(0) cboValue.SetFocus Screen.MousePointer = vbDefault MsgBar gsNULL_STR, False Exit Sub GVErr: Screen.MousePointer = vbDefault MsgBar gsNULL_STR, False cboValue.Text = gsNULL_STR Exit Sub End Sub Private Sub cmdJoin_Click() Dim i As Integer Dim c As Integer For i = 0 To lstTables.ListCount - 1 If lstTables.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 frmJoin.Show vbModal MsgBar gsNULL_STR, False End If End Sub Private Sub cmdOr_Click() Dim nType As Integer Dim sFieldName As String Dim sTableName As String If Len(cboField.Text) = 0 Then Exit Sub sTableName = stSTF((cboField), 0) sFieldName = stSTF((cboField), 1) nType = gdbCurrentDB.TableDefs(StripBrackets(sTableName)).Fields(StripBrackets(sFieldName)).Type If Len(txtCriteria.Text) > 0 Then txtCriteria.Text = txtCriteria.Text & gsNewLine & " Or " End If If nType = dbText Or nType = dbMemo Or nType = dbDate Then txtCriteria.Text = txtCriteria.Text & cboField.Text & " " & cboOperator.Text & " '" & cboValue.Text & "'" Else txtCriteria.Text = txtCriteria.Text & cboField.Text & " " & cboOperator.Text & " " & cboValue.Text End If cboField.SetFocus End Sub Private Sub cmdRunQuery_Click() On Error GoTo OKErr Dim rec As Recordset Dim fs As String Dim ts As String Dim i As Integer Dim sWhere As String Dim sWhere2 As String Dim sNewWhere As String Dim sTmp As String Dim bMatchParen As Integer Dim sQueryName As String Dim qdfTmp As QueryDef If lstShowFields.ListCount = 0 Then MsgBox "No Query Entered!", vbExclamation Exit Sub End If MsgBar "Building Query", True If Len(txtCriteria.Text) > 0 Then sWhere = "AND " & LTrim(txtCriteria.Text) 'strip gsNewLines For i = 1 To Len(sWhere) If Mid(sWhere, i, 1) = Chr(13) Then sTmp = sTmp & " " ElseIf Mid(sWhere, i, 1) = Chr(10) Then 'do nothing Else sTmp = sTmp + Mid(sWhere, i, 1) End If Next sWhere = sTmp sWhere = RTrim(sWhere) 'Add parens to sWhere sWhere2 = sWhere Do sTmp = stGetToken(sWhere2, " ") sTmp = sTmp & " " If bMatchParen = False And UCase(sTmp) = "AND " Then sNewWhere = sNewWhere + sTmp & "(" bMatchParen = True ElseIf bMatchParen = True And UCase(sTmp) = "AND " Then sNewWhere = sNewWhere & ") " & sTmp & "(" 'bMatchParen = False Else If UCase(sTmp) = "OR" Or UCase(sTmp) = "IN " Or UCase(sTmp) = "LIKE" Then sNewWhere = sNewWhere & " " & sTmp Else sNewWhere = sNewWhere + sTmp End If End If Loop Until sWhere2 = gsNULL_STR sWhere = sNewWhere & ")" 'Build DynaSet string: 'Peel off leading AND/OR If Mid(sWhere, 2, 2) = "OR" Then sWhere = Mid(sWhere, 5, Len(sWhere) - 5) Else sTmp = stGetToken(sWhere, " ") End If If Len(sWhere) > 0 Then sWhere = " Where " & sWhere End If End If 'check for join condition If lstJoinFields.ListCount > 0 Then If Len(sWhere) = 0 Then sWhere = sWhere & " Where " Else sWhere = sWhere & " And " End If For i = 0 To lstJoinFields.ListCount - 1 sWhere = sWhere + lstJoinFields.List(i) & " And " Next sWhere = Mid(sWhere, 1, Len(sWhere) - 5) End If 'check for group by field If cboGroupByField <> "(none)" Then sWhere = sWhere & " Group By " & cboGroupByField End If 'check for order by field If cboOrderByField <> "(none)" Then sWhere = sWhere & " Order By " & cboOrderByField If optOrder(1).Value = True Then sWhere = sWhere & " Desc " End If End If 'get show field names For i% = 0 To lstShowFields.ListCount - 1 If lstShowFields.Selected(i%) Then fs = fs + lstShowFields.List(i%) & "," End If Next If Len(fs) = 0 Then For i% = 0 To lstTables.ListCount - 1 If lstTables.Selected(i%) Then fs = fs + AddBrackets((lstTables.List(i%))) & ".*," End If Next If Len(fs) = 0 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 lstTables.ListCount - 1 If lstTables.Selected(i%) Then ts = ts + AddBrackets((lstTables.List(i%))) & "," End If Next ts = Mid(ts, 1, Len(ts) - 1) gsDynaString = "Select " 'set Top N Value if present If Len(txtTopNValue.Text) > 0 Then gsDynaString = gsDynaString & " TOP " & txtTopNValue.Text & " " If chkTopPercent.Value = 1 Then gsDynaString = gsDynaString & " PERCENT " End If End If gsDynaString = gsDynaString & fs & " From " & ts + sWhere If mbShowSQL = False And mbCopySQL = False And mbSaveSQL = False Then MsgBar "Running Query", True gbFromSQL = True 'create a new recordset form If frmMDI.optNoDataCtl = True Then Dim frmNDC As New frmDynaSnap frmNDC.Show ElseIf frmMDI.optDataCtl.Value = True Then Dim frmDC As New frmDataControl frmDC.Show Else Dim frmGRID As New frmDataGrid frmGRID.Show End If ElseIf mbShowSQL = True Then MsgBar gsNULL_STR, False MsgBox gsDynaString, 0, "SQL Query" ElseIf mbCopySQL = True Then frmSQL.txtSQLStatement.Text = gsDynaString ElseIf mbSaveSQL = True Then MsgBar gsNULL_STR, False sQueryName = InputBox("Enter QueryDef Name:") If Len(sQueryName) = 0 Then Exit Sub 'check for a dupe and exit if the user won't overwrite it If DupeTableName(sQueryName) = True Then Exit Sub End If 'add the new querydef Set qdfTmp = gdbCurrentDB.CreateQueryDef(sQueryName, gsDynaString) RefreshTables frmTables.lstTables, True End If MsgBar gsNULL_STR, False Exit Sub OKErr: If Err = 364 Then Exit Sub 'catch unloaded form ShowError Exit Sub End Sub Private Sub cmdShowSQL_Click() mbShowSQL = True Call cmdRunQuery_Click mbShowSQL = False End Sub Private Function stGetToken(rsLine As String, rsDelim As String) As String On Error GoTo GetTokenError Dim iOpenQuote As Integer Dim iCloseQuote As Integer Dim iDelim As Integer Dim stToken As String iOpenQuote = InStr(1, rsLine, """") iDelim = InStr(1, rsLine, rsDelim) If (iOpenQuote > 0) And (iOpenQuote < iDelim) Then iCloseQuote = InStr(iOpenQuote + 1, rsLine, """") iDelim = InStr(iCloseQuote + 1, rsLine, rsDelim) End If If (iDelim% <> 0) Then stToken = LTrim(RTrim(Mid(rsLine, 1, iDelim - 1))) rsLine = Mid(rsLine, iDelim + 1) Else stToken = LTrim(RTrim(Mid(rsLine, 1))) rsLine = gsNULL_STR 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 Exit Function GetTokenError: Exit Function End Function 'function to split the table and the field from a tbl.fld pair Private Function stSTF(rsName As String, rnPart As Integer) As String If InStr(InStr(1, rsName, ".") + 1, rsName, ".") > 1 Then rsName = StripOwner(rsName) End If If rnPart = 0 Then stSTF = Mid(rsName, 1, InStr(1, rsName, ".") - 1) Else stSTF = Mid(rsName, InStr(1, rsName, ".") + 1, Len(rsName)) End If End Function