frmquerys.frm

网上教务管理系统 包括（教师

VERSION 5.00
Begin VB.Form frmQuerys 
   Caption         =   "查询(适合熟悉SQL语句的用户)"
   ClientHeight    =   4185
   ClientLeft      =   1650
   ClientTop       =   1545
   ClientWidth     =   5100
   Icon            =   "frmQuerys.frx":0000
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   ScaleHeight     =   4185
   ScaleWidth      =   5100
   Tag             =   "Querys"
   Begin VB.ListBox lstQueryDefs 
      Height          =   1140
      Left            =   96
      TabIndex        =   0
      Top             =   274
      Width           =   3392
   End
   Begin VB.TextBox txtSQLStatement 
      BackColor       =   &H00FFFFFF&
      Height          =   2159
      Left            =   96
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   4
      Top             =   1921
      Width           =   4931
   End
   Begin VB.CommandButton cmdRemoveQuery 
      Caption         =   "删除(&R)"
      Height          =   370
      Left            =   3572
      TabIndex        =   3
      Tag             =   "&Remove"
      Top             =   1277
      Width           =   1443
   End
   Begin VB.CommandButton cmdSaveQueryDef 
      Caption         =   "保存(&S)"
      Height          =   370
      Left            =   3572
      TabIndex        =   2
      Tag             =   "&Save"
      Top             =   775
      Width           =   1443
   End
   Begin VB.CommandButton cmdExecuteSQL 
      Caption         =   "执行(&E)"
      Enabled         =   0   'False
      Height          =   370
      Left            =   3572
      TabIndex        =   1
      Tag             =   "&Execute"
      Top             =   274
      Width           =   1443
   End
   Begin VB.Label lblSQL 
      Caption         =   "SQL 语句:"
      Height          =   251
      Index           =   1
      Left            =   132
      TabIndex        =   6
      Tag             =   "SQL Statement:"
      Top             =   1682
      Width           =   2189
   End
   Begin VB.Label lblSQL 
      Caption         =   "保存的查询:"
      Height          =   251
      Index           =   0
      Left            =   108
      TabIndex        =   5
      Tag             =   "Saved Querys:"
      Top             =   24
      Width           =   2189
   End
End
Attribute VB_Name = "frmQuerys"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

'====================================================================
'本模板需要在应用程序中存在下列代码（或等价的代码），
' 以及对 DAO 3.50 和 DataGrid 模板的引用。
'
'Global gsDatabase As String
'Global gsRecordsource As String
'
'Sub Main()
'  gsDatabase = "c:\vb5\biblio.mdb"
'  frmQuerys.Show
'End Sub
'====================================================================


Dim mdbDatabase As Database

Private Sub Form_Load()
    Set mdbDatabase = OpenDatabase(App.Path + "\DATABASE\MARK.MDB", , False)
    RefreshQuerys
    Me.Left = GetSetting(App.Title, "Settings", "QueryLeft", 0)
    Me.Top = GetSetting(App.Title, "Settings", "QueryTop", 0)
End Sub

Private Sub Form_Unload(Cancel As Integer)
    If Me.WindowState <> vbMinimized Then
        SaveSetting App.Title, "Settings", "QueryLeft", Me.Left
        SaveSetting App.Title, "Settings", "QueryTop", Me.Top
    End If
    FRMKCDW_ID = True
End Sub



Private Sub cmdSaveQueryDef_Click()
    On Error GoTo SQDErr

    Dim sQueryName As String
    Dim sTmp As String
    Dim qdNew As QueryDef

    If lstQueryDefs.ListIndex >= 0 Then
        '选中一个查询定义，用户可能希望更新 SQL
        If MsgBox("更新 '" & lstQueryDefs.Text & "' 吗？", vbYesNo + vbQuestion) = vbYes Then
            '存储 SQL 窗口中的 SQL 于当前选中的查询定义中
            mdbDatabase.QueryDefs(lstQueryDefs.Text).SQL = Me.txtSQLStatement.Text
            Exit Sub
        End If
    End If
    
    '也许当前无选中的查询定义或用户不想更新，
    '要提示一个新名称
    sQueryName = InputBox("输入新查询名称：")
    If Len(sQueryName) = 0 Then Exit Sub
    
    '添加新查询定义
    Set qdNew = mdbDatabase.CreateQueryDef(sQueryName)
    '提示是否传递查询定义
    If MsgBox("这是一个 SQL 传递查询定义吗？", vbYesNo + vbQuestion + vbDefaultButton2) = vbYes Then
        sTmp = InputBox("输入 Connect 属性的值：")
        If Len(sTmp) > 0 Then
            qdNew.Connect = sTmp
            If MsgBox("查询行是否正在返回？", vbYesNo + vbQuestion) = vbNo Then
                qdNew.ReturnsRecords = False
            End If
        End If
    End If
    qdNew.SQL = txtSQLStatement.Text
    
    mdbDatabase.QueryDefs.Refresh
    RefreshQuerys

    Exit Sub

SQDErr:
    MsgBox ERR.Description
End Sub

Private Sub lstQueryDefs_Click()
    txtSQLStatement.Text = mdbDatabase.QueryDefs(lstQueryDefs.Text).SQL
End Sub

Private Sub lstQueryDefs_DblClick()
    cmdExecuteSQL_Click
End Sub

Private Sub txtSQLStatement_Change()
    If Len(txtSQLStatement.Text) > 0 Then
        cmdExecuteSQL.Enabled = True
    Else
        cmdExecuteSQL.Enabled = False
    End If
End Sub

Private Sub cmdExecuteSQL_Click()
    Dim rsTmp As Recordset
    Dim dbTmp As Database
    Dim qdfTmp As QueryDef
    Dim bSavedQDF As Boolean
    Dim sSQL As String
    
    If Len(txtSQLStatement.Text) = 0 Then Exit Sub
    
    Set dbTmp = OpenDatabase(App.Path + "\DATABASE\MARK.MDB", , False)
    
    If lstQueryDefs.ListIndex >= 0 Then
        sSQL = dbTmp.QueryDefs(lstQueryDefs.Text).SQL
        If sSQL = txtSQLStatement.Text Then
            Set qdfTmp = dbTmp.QueryDefs(lstQueryDefs.Text)
            bSavedQDF = True
            If Not SetQryParams(qdfTmp) Then Exit Sub
        Else
            '仅创建一个临时查询定义
            Set qdfTmp = dbTmp.CreateQueryDef(vbNullString, txtSQLStatement.Text)
        End If
    Else
        '仅创建一个临时查询定义
        Set qdfTmp = dbTmp.CreateQueryDef(vbNullString, txtSQLStatement.Text)
    End If

    'Screen.MousePointer = vbHourglass
    If UCase(Mid(txtSQLStatement, 1, 6)) = "SELECT" And InStr(UCase(txtSQLStatement.Text), " INTO ") = 0 Then
        On Error GoTo SQLErr
MakeDynaset:
        Dim f As New frmDataGrid
        Set rsTmp = qdfTmp.OpenRecordset()
        Set f.Data1.Recordset = rsTmp
        If bSavedQDF Then
            f.Caption = qdfTmp.Name
        Else
            f.Caption = Left(txtSQLStatement.Text, 32) & "..."
        End If
        
        f.Show 1
    Else
        On Error GoTo SQLErr
        qdfTmp.Execute
    End If

    Screen.MousePointer = vbDefault
    Exit Sub

SQLErr:
    If ERR = 3065 Or ERR = 3078 Then '行正在返回或名称未找到，所以试图创建记录集
        Resume MakeDynaset
    End If
    MsgBox ERR.Description

SQLEnd:

End Sub

Private Sub Form_Resize()
    On Error Resume Next

    If WindowState <> 1 Then
        If Me.Width < 5220 Then Me.Width = 5220
        If Me.Height < 2784 Then Me.Height = 2784
        
        txtSQLStatement.Width = Me.Width - 320
        txtSQLStatement.Height = Me.Height - 2424
    End If
End Sub

Sub RefreshQuerys()
    Dim qdf As QueryDef
    
    lstQueryDefs.Clear
    
    For Each qdf In mdbDatabase.QueryDefs
        lstQueryDefs.AddItem qdf.Name
    Next
    
End Sub

Private Function SetQryParams(rqdf As QueryDef) As Boolean
    On Error GoTo SPErr
    
    Dim prm As Parameter
    Dim sTmp As String
    Dim i As Integer
    
    For Each prm In rqdf.Parameters
        '从用户那里得到值
        sTmp = InputBox("为参数 '" & prm.Name & "' 输入值：")
        If Len(sTmp) = 0 Then
            '如果用户一个参数也没有输入，则退出
            SetQryParams = False
            Exit Function
        End If
        '存储该值
        prm.Value = CVar(sTmp)
    Next
    
    SetQryParams = True
    Exit Function
        
SPErr:
    MsgBox ERR.Description
End Function