adomain.frm

数据库sql200和vb在一起的数据库查询代码呵工程

Private Sub cmdDisconnect_Click()
      
    ' Clear the error log display.
    Form2.lstErrors.Clear
    
    ' Disconnect from a connected server.
    If cn.State = adStateOpen Then
        Msg = "Disconnect from Server?"
        Response = MsgBox(Msg, vbOKCancel, Title)
        If Response = vbOK Then
            cn.Close
            List2.Clear
            txtQuery.Text = ""
            buttonsConnectClosed
        Else
            txtQuery.SetFocus
        End If
    End If
   
End Sub

Private Sub cmdExecute_Click()
    
    Dim rs As ADODB.Recordset
    Dim fldLoop As ADODB.Field
    
    Dim rowstring As String, boolvalue As Boolean, _
        rowvalue As String, rowcount As Integer
    
    On Error GoTo ErrorExecute

    ' Clear the results displays (error log and results).
    Form2.lstErrors.Clear
    List2.Clear
    
    ' The sample is intentionally light on formatting of displayed result sets.
    padding = Space(10)
                
    ' Change mousepointer to busy.
    Screen.MousePointer = vbHourglass
    
    ' Put SQL query text into variable cmd1.
    cmd1 = txtQuery.Text
    
    ' Initialize recordset
    Set rs = New ADODB.Recordset
    
    ' Open recordset.
    rs.Open cmd1, cn
    
    ' Move to first row.
    rs.MoveFirst
   
    ' Outermost loop handles multiple result sets per query cases.
    ' Variable "intcount" counts each result set in a query.
    ' 2nd Loop: loop through fields, concatenate values into rowstring variable.
    ' Place output into list box control.
    ' Go through all rows in open recordset.
    
    intcount = 1
    Do Until rs Is Nothing
        
        For Each fldLoop In rs.Fields
            rowvalue = fldLoop.Name
            rowstring = rowstring + rowvalue + padding
        Next fldLoop
                
        List2.AddItem rowstring
        List2.AddItem ""
            
        Do While Not rs.EOF
                
            With rs
            
                rowvalue = ""
                rowstring = ""
                            
                ' Concatenate column values for each record.
                For Each fldLoop In rs.Fields
               
                    ' Catch ADO Boolean type values, convert to VB string.
                    If fldLoop.Type = adBoolean Then
                        boolvalue = fldLoop.Value
                        rowvalue = CStr(boolvalue)
                   '  Catch NULL values, convert to string "NULL" for display.
                    ElseIf IsNull(fldLoop.Value) = True Then
                        rowvalue = "NULL"
                    Else
                        rowvalue = fldLoop.Value
                    End If
                
                    rowstring = rowstring + rowvalue + padding
                Next fldLoop      ' End of inner loop.
                
                List2.AddItem rowstring
                rowstring = ""
            End With
            rowcount = rowcount + 1
            rs.MoveNext
        Loop                    ' End of outer loop.
    
        ' Display summary data on query results
        List2.AddItem ""
        countStr = "Result set #" & intcount & ":  (" & rowcount & " row(s) affected)"
        List2.AddItem countStr
        List2.AddItem ""
        rowcount = 0
        
        intcount = intcount + 1
        
        Set rs = rs.NextRecordset
        
    Loop        ' End outermost (multiple result sets) loop.
    
    buttonsQueryDone
    
    ' Change mousepointer to normal.
    Screen.MousePointer = vbDefault
    
    Exit Sub
      

ErrorExecute:
    
    ' Error checking. Bad query.
    
    If cn.State = adStateOpen Then
        errcase = 3
    End If
    
    ErrorLog
    
End Sub

Private Sub ErrorLog()
    
    Dim errLoop As ADODB.Error
    
    ' Change mousepointer to normal.
    Screen.MousePointer = vbDefault

    Select Case errcase
            
        ' 1 = successful connection; if a non-provider error occurred, which
        '     can't be saved in the ADO Errors collection, error processing
        '     ends. If a provider error occurred, processing continues.
        Case 1, 2, 3
            If errcase = 1 Then
                If cn.Errors.Count = 0 Then
                    Exit Sub
                End If
            End If
            
        ' 2 = Notify user of no connection. Then go on to error logging.
            If errcase = 2 Then
                Response = MsgBox(MsgConnUn, vbOKOnly, Title)
            End If
        
        ' 3 = Error occurred during the attempt to execute or
        '       execution of the query.
            If errcase = 3 Then
                If cn.Errors.Count = 0 Then
                    Exit Sub
                End If
            End If
        
        ' Create each error message in the errors list box.
        ' Each string in the list box corresponds to an ADO Error property.
                
        ' Array items correspond to a set of properties for each
        '   ADO Error object.
        ' The HelpFile and HelpContext properties are not exposed.
          
             For Each errLoop In cn.Errors
                
                Dim strError(5)
                Dim i As Integer
               
                strError(0) = "Error Number: " & errLoop.Number
                strError(1) = "  Description: " & errLoop.Description
                strError(2) = "  Source: " & errLoop.Source
                strError(3) = "  SQL State: " & errLoop.SQLState
                strError(4) = "  Native Error: " & errLoop.NativeError
                
                ' Loop through first five properties of Error object.
                i = 0
                Do While i < 5
                    Form2.lstErrors.AddItem strError(i)
                    i = i + 1
                Loop
                
                ' Add a blank line after each error message.
                Form2.lstErrors.AddItem ""
            
            Next    ' Continue looping through ADO Errors collection.
            
            ' Create string for summary count of errors.
            c = cn.Errors.Count & " provider error(s) occurred."
            
            ' Display a count of the provider errors.
            Form2.lstErrors.AddItem c
            Form2.lstErrors.AddItem ""
            Form2.Show
            
            ' Clear the ADO errors collection.
            cn.Errors.Clear
        
        Case Else          ' Fall-through case statement.
            Exit Sub
    
    End Select
    
End Sub

Private Sub cmdClear_Click()
    ' Clear the query and query results boxes.
    txtQuery.Text = ""
    List2.Clear
    txtQuery.SetFocus
End Sub

Private Sub mnuAboutItem_Click()
    FormAbout.Show
End Sub

Private Sub mnuEditItem_Click(Index As Integer)
    Select Case Index
        Case 0      ' User chose Cut
            Clipboard.Clear
            Clipboard.SetText Screen.ActiveControl.SelText
            Screen.ActiveControl.SelText = ""

        Case 1      ' User chose Copy
            Clipboard.Clear
            Clipboard.SetText Screen.ActiveControl.SelText

        Case 2      ' User chose Paste
            Screen.ActiveControl.SelText = Clipboard.GetText()
    End Select
End Sub

Private Sub mnuItemExit_Click()

    If cn.State = adStateOpen Then
      cn.Close
    End If
    End

End Sub

Private Sub optSSAuth_Click()
    If optSSAuth.Value = True Then
        SSAuthOptionsOn
    End If
End Sub

Private Sub optWinNTAuth_Click()
    optWinNTAuth.Value = True
    WinNTAuthOptionsOn
    txtUserName.Text = ""
    txtPassword.Text = ""
End Sub

Private Sub buttonsConnectClosed()
    cmdConnect.Enabled = True
    cmdConnect.Default = True
    cmdDisconnect.Enabled = False
    cmdExecute.Enabled = False
    cmdClear.Enabled = False
End Sub

Private Sub buttonsConnectOpen()
    cmdConnect.Enabled = False
    cmdDisconnect.Enabled = True
    cmdExecute.Enabled = True
    cmdClear.Enabled = False
End Sub

Private Sub buttonsQueryDone()
    cmdConnect.Enabled = False
    cmdDisconnect.Enabled = True
    cmdExecute.Enabled = True
    cmdClear.Enabled = True
End Sub

Private Sub WinNTAuthOptionsOn()
    lblUserName.Enabled = False
    lblPassword.Enabled = False
    txtUserName.Enabled = False
    txtPassword.Enabled = False
End Sub

Private Sub SSAuthOptionsOn()
    lblUserName.Enabled = True
    lblPassword.Enabled = True
    txtUserName.Enabled = True
    txtPassword.Enabled = True
End Sub