frmsql.frm

大量优秀的vb编程

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "mscomctl.ocx"
Begin VB.Form frmSQL 
   BorderStyle     =   4  'Fixed ToolWindow
   Caption         =   "执行SQL语句"
   ClientHeight    =   5064
   ClientLeft      =   48
   ClientTop       =   288
   ClientWidth     =   6384
   Icon            =   "frmSQL.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   5064
   ScaleWidth      =   6384
   ShowInTaskbar   =   0   'False
   StartUpPosition =   1  '所有者中心
   Begin VB.CommandButton Command1 
      Caption         =   "关闭窗口"
      Height          =   375
      Left            =   120
      TabIndex        =   8
      Top             =   4560
      Width           =   1095
   End
   Begin VB.TextBox txtMaxRows 
      Height          =   285
      Left            =   5400
      TabIndex        =   6
      Top             =   840
      Width           =   855
   End
   Begin VB.Frame Frame1 
      Caption         =   "统计信息"
      Height          =   855
      Left            =   1320
      TabIndex        =   3
      Top             =   4080
      Width           =   4935
      Begin VB.Label lblStats 
         AutoSize        =   -1  'True
         Caption         =   "Label1"
         Height          =   195
         Left            =   240
         TabIndex        =   4
         Top             =   360
         Width           =   480
      End
   End
   Begin MSComctlLib.ListView lstResults 
      Height          =   2775
      Left            =   120
      TabIndex        =   1
      Top             =   1200
      Width           =   6135
      _ExtentX        =   10816
      _ExtentY        =   4890
      View            =   3
      LabelEdit       =   1
      LabelWrap       =   -1  'True
      HideSelection   =   -1  'True
      FullRowSelect   =   -1  'True
      _Version        =   393217
      ForeColor       =   -2147483640
      BackColor       =   -2147483643
      BorderStyle     =   1
      Appearance      =   1
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "MS Sans Serif"
         Size            =   7.8
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      NumItems        =   0
   End
   Begin VB.TextBox txtSQL 
      Height          =   735
      Left            =   120
      TabIndex        =   0
      Top             =   360
      Width           =   5175
   End
   Begin VB.CommandButton cmdRun 
      Caption         =   "执行"
      Height          =   375
      Left            =   120
      TabIndex        =   2
      Top             =   4200
      Width           =   1095
   End
   Begin VB.Label Label2 
      Caption         =   "最大行数"
      Height          =   255
      Left            =   5400
      TabIndex        =   7
      Top             =   480
      Width           =   855
   End
   Begin VB.Label Label1 
      Caption         =   "SQL语句"
      Height          =   255
      Left            =   120
      TabIndex        =   5
      Top             =   120
      Width           =   1335
   End
End
Attribute VB_Name = "frmSQL"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Sub cmdRun_Click()
On Error GoTo HandleError
    Dim rsSearch As rdoResultset
    Dim iColumnCount As Integer, iRowCount As Integer
    Dim rdoQ As New rdoQuery
    
    cmdRun.Enabled = False
    lstResults.ListItems.Clear
    lstResults.ColumnHeaders.Clear
    Set rdoQ.ActiveConnection = frmConnect.gDBase
    rdoQ.SQL = txtSQL
    rdoQ.MaxRows = txtMaxRows
    Set rsSearch = rdoQ.OpenResultset(rdOpenDynamic)
    iColumnCount = rsSearch.rdoColumns.Count
    If iColumnCount > 0 Then
        iRowCount = rsSearch.RowCount
        ConstructHeaders iColumnCount, rsSearch
        lblStats = "Number of rows : " & CStr(iRowCount) & "; Number of columns : " & iColumnCount
        PopulateList iRowCount, iColumnCount, rsSearch
    End If
    cmdRun.Enabled = True
    
    Exit Sub
    
HandleError:
    If Err.Number <> 40002 Then
        HandleErr "frmSQL.cmdRun_Click"
    Else
        MsgBox "Invalid SQL statement! Please check syntax."
    End If
End Sub

Private Sub ConstructHeaders(iColumns As Integer, rsSearch As rdoResultset)
On Error GoTo HandleError
    Dim iLoop As Integer
    
    For iLoop = 0 To iColumns - 1
        lstResults.ColumnHeaders.Add Text:=rsSearch.rdoColumns(iLoop).Name
    Next
    
    Exit Sub
    
HandleError:
    HandleErr "frmSQL.ConstructHeaders"
End Sub

Private Sub PopulateList(iRows As Integer, iColumns As Integer, rsSearch As rdoResultset)
On Error GoTo HandleError
    Dim iLoop As Integer, iInner As Integer
    Dim lstIResults As ListItem
    Dim vResult As Variant
    Dim iBounds As Integer
    Dim sConstruct As String, sPart As String
    Dim sngRowCount As Single
    
    DoEvents
    Me.MousePointer = vbHourglass
    lstResults.MousePointer = vbHourglass
    If rsSearch.RowCount <= 0 Then
        Me.MousePointer = vbDefault
        Exit Sub
    End If
    rsSearch.MoveFirst
    sngRowCount = 0
    While Not rsSearch.EOF
        Set lstIResults = lstResults.ListItems.Add()
        vResult = rsSearch.rdoColumns(0).Value
        lstIResults.Text = FormatFieldValue(vResult)
        
        For iLoop = 1 To iColumns - 1
            vResult = rsSearch.rdoColumns(iLoop).Value
            lstIResults.SubItems(iLoop) = FormatFieldValue(vResult)
        Next
        rsSearch.MoveNext
        sngRowCount = sngRowCount + 1
        If sngRowCount Mod 50 = 0 Then DoEvents
    Wend
    Me.MousePointer = vbDefault
    lstResults.MousePointer = vbDefault
    
    Exit Sub
    
HandleError:
    Me.MousePointer = vbDefault
    lstResults.MousePointer = vbDefault
    HandleErr "frmSQL.PopulateList"
End Sub

Private Function FormatFieldValue(vResult As Variant) As String
On Error GoTo HandleError
    Dim iBounds As Integer, iLoop As Integer
    Dim sConstruct As String, sPart As String
    
    iBounds = 0
    iBounds = UBound(vResult, 1)
    If iBounds > 0 Then
        sConstruct = "0x"
        For iLoop = 0 To iBounds
            sPart = Hex(vResult(iLoop))
            If Len(sPart) = 1 Then sPart = "0" & sPart
            sConstruct = sConstruct & sPart
        Next
    Else
        If Not IsNull(vResult) Then
            sConstruct = vResult
        Else
            sConstruct = "(null)"
        End If
    End If
    FormatFieldValue = sConstruct
    
    Exit Function
    
HandleError:
    If Err.Number = 13 Then Resume Next
    HandleErr "frmSQL.FormatFieldValue"
End Function

Private Sub Command1_Click()
    frmSQL.Hide
End Sub

Private Sub Form_Load()
    lblStats = "No SQL statement has been run."
    cmdRun.Enabled = False
    txtMaxRows = 100
End Sub

Private Sub txtMaxRows_KeyPress(KeyAscii As Integer)
    Select Case KeyAscii
        Case 8
        Case Is < 48
            KeyAscii = 0
        Case Is > 57
            KeyAscii = 0
    End Select
End Sub

Private Sub txtSQL_Change()
    If Len(txtSQL) >= 1 Then
        cmdRun.Enabled = True
    Else
        cmdRun.Enabled = False
    End If
End Sub