adocore.bas

vc ADO 连接数据库

Attribute VB_Name = "AdoCore"
Public SQLServerConnect As String

Public Sub Access(List1 As ListBox)
   Dim Conn1 As ADODB.Connection
   Dim Cmd1 As ADODB.Command
   Dim Params1 As ADODB.Parameters
   Dim Param1 As ADODB.Parameter
   Dim Rs1 As ADODB.Recordset
   
   Dim i As Integer
      
   ' Trap error/exceptions
   On Error GoTo AdoError
   
   '------------------------
   ' Open Connection Object
   '------------------------
   
   ' Warm & Fuzzy for user
   List1.Clear
   List1.AddItem "Opening Access Database ADODEMO.MDB..."
   List1.AddItem vbTab & "...Assumes ADODEMO.MDB is in the same directory"
   List1.AddItem vbTab & "...With Error Handling Using Connection Object"
   
   ' Create Connection Object and open it on ADODEMO.MDB
   Set Conn1 = New ADODB.Connection
   
   Conn1.ConnectionString = "DSN=AdoDemo;UID=admin;PWD=;"
   Conn1.Open

   '-----------------------------------
   ' Open Parameterized Command Object
   '-----------------------------------
   List1.AddItem vbTab & "...Parameterized Command Object"
   
   
   Set Cmd1 = New ADODB.Command
   Set Cmd1.ActiveConnection = Conn1
   Cmd1.CommandText = "SELECT * FROM Authors WHERE AU_ID < ?"
   
   Set Param1 = Cmd1.CreateParameter(, adInteger, adParamInput, 3)
   Param1.Value = 10
   Cmd1.Parameters.Append Param1
   Set Param1 = Nothing
   
   Set Rs1 = Cmd1.Execute()
   
   '----------------------------------------
   ' Manipulate Recordset/Fields Collection
   '----------------------------------------
   
   List1.AddItem vbTab & "...Forward-Only Recordset"
   
   List1.AddItem "Dumping contents of each record..."
   
   i = 0
   While Rs1.EOF = False
      List1.AddItem vbTab & Rs1.Fields(0).Value & " | " & _
                            Rs1(1).Value
      Rs1.MoveNext
   Wend
   
   List1.AddItem "Dumping properties of each column in the recordset..."
   
   Rs1.Requery
   
   For i = 0 To Rs1.Fields.Count - 1
      List1.AddItem "    Field #" & i
      List1.AddItem vbTab & "Actual Size  = " & Rs1.Fields(i).ActualSize
      List1.AddItem vbTab & "Attributes   = " & Rs1.Fields(i).Attributes
      List1.AddItem vbTab & "Defined Size = " & Rs1.Fields(i).DefinedSize
      List1.AddItem vbTab & "Name         = " & Rs1.Fields(i).Name
      List1.AddItem vbTab & "NumericScale = " & Rs1.Fields(i).NumericScale
      'List1.AddItem vbTab & "OriginalValue= " & Rs1.Fields(i).OriginalValue
      List1.AddItem vbTab & "Precision    = " & Rs1.Fields(i).Precision
      List1.AddItem vbTab & "Type         = " & Rs1.Fields(i).Type
      List1.AddItem vbTab & "Value        = " & Rs1.Fields(i).Value
   Next
   
   
   ' Successful Shutdown
   List1.AddItem "*** Success! ***"
   Rs1.Close
   Conn1.Close
   
Done:
   '----------------------------------
   ' Miscellaneous (graceful) Cleanup
   ' with quiet error trapping
   '----------------------------------
   
   On Error Resume Next
      
   Set Rs1 = Nothing
   Set Conn1 = Nothing
   
   Exit Sub
   
' Error/Exception Handler
AdoError:
    ' Check Err Object
    VbErrorEx List1, Err.Number, Err.Source, Err.Description
    
    ' Check ADO Errors Collection for Errors raised by Data provider
    If Not (Conn1 Is Nothing) Then
       AdoErrorEx List1, Conn1
    End If
    
    GoTo Done
End Sub

Public Sub ProviderProperties(List1 As ListBox)
   Dim Conn1 As ADODB.Connection
   Dim Cmd1 As ADODB.Command
   Dim Rs1 As ADODB.Recordset
   Dim Fld1 As ADODB.Field
      
   Dim i As Integer
      
   ' Trap error/exceptions
   On Error GoTo AdoError
   
   '-------------------
   ' Connection Object
   '-------------------
   
   ' Warm & Fuzzy for user
   List1.Clear
   
   ' Create Connection Object and open it on ADODEMO.MDB
   Set Conn1 = New ADODB.Connection
   
   ' Trap any error/exception
   On Error GoTo AdoError
   
   Conn1.ConnectionString = "DSN=AdoDemo;UID=admin;PWD=;"
   Conn1.Open

   ' Dump conneciton properties
   List1.AddItem "*** *** *** *** *** Dumping contents of the Properties Collection for the Connection object *** *** *** *** ***"
   DumpProperty List1, Conn1, Conn1.Properties
   
   '----------------
   ' Command Object
   '----------------
   
   Set Cmd1 = New ADODB.Command
   Set Cmd1.ActiveConnection = Conn1
   Cmd1.CommandText = "SELECT * FROM Authors"
   
   Set Rs1 = Cmd1.Execute()
   
   List1.AddItem "*** *** *** *** *** Dumping contents of the Properties Collection for the Command object *** *** *** *** ***"
   DumpProperty List1, Conn1, Cmd1.Properties
   
   '------------------
   ' Recordset Object
   '------------------
   
   List1.AddItem "*** *** *** *** *** Dumping contents of the Properties Collection for the Recordset object *** *** *** *** ***"
   DumpProperty List1, Conn1, Rs1.Properties

   '--------------
   ' Field Object
   '--------------
   
   List1.AddItem "*** *** *** *** *** Dumping contents of the Properties Collection for the Field object *** *** *** *** ***"
   DumpProperty List1, Conn1, Rs1.Fields(0).Properties
   
   ' Successful Shutdown
   List1.AddItem "*** Success! ***"
   Rs1.Close
   Conn1.Close

Done:
   '----------------------------------
   ' Miscellaneous (graceful) Cleanup
   ' with quiet error trapping
   '----------------------------------
   
   On Error Resume Next
      
   Set Rs1 = Nothing
   Set Cmd1 = Nothing
   Set Conn1 = Nothing
   
   Exit Sub
   
' Error/Exception Handler
AdoError:
    ' Check Err Object
    VbErrorEx List1, Err.Number, Err.Source, Err.Description
    
    ' Check ADO Errors Collection for Errors raised by Data provider
    If Not (Conn1 Is Nothing) Then
       AdoErrorEx List1, Conn1
    End If
    
    GoTo Done
End Sub

Public Sub CodeTemplate(List1 As ListBox)
   ' Using the helper routines, this shows what a typical
   ' code fragment using ADO would need in order to provide
   ' accurate error handling.
   
   Dim Conn1 As ADODB.Connection
   Dim Cmd1 As ADODB.Command
   Dim Rs1 As ADODB.Recordset
   
   ' Trap error/exceptions
   On Error GoTo AdoError
   
   '------------------------
   ' Open Connection Object
   '------------------------
   
   ' Warm & Fuzzy for user
   List1.Clear
   List1.AddItem "ADO Code Template..."
   
   ' Create Connection Object (using early binding)
   Set Conn1 = New ADODB.Connection
   Conn1.ConnectionString = "DSN=AdoDemo;UID=admin;PWD=;"
   Conn1.Open
   
   ' Successful Shutdown
   Conn1.Close
   
   '----------------------
   ' YOUR CODE GOES HERE!
   ' (in this case a little dummy code to throw some errors
   '----------------------
   List1.AddItem "...delibratly generating a dummy error"
   
   Dim conn2 As New ADODB.Connection
   conn2.Open
   
Done:
   '----------------------------------
   ' Miscellaneous (graceful) Cleanup
   ' with quiet error trapping
   '----------------------------------
   
   On Error Resume Next
      
   Set Rs1 = Nothing
   Set conn2 = Nothing
   Set Conn1 = Nothing
   
   Exit Sub
   
' Error/Exception Handler
AdoError:
    ' Check Err Object
    VbErrorEx List1, Err.Number, Err.Source, Err.Description
    
    ' Check ADO Errors Collection for Errors raised by Data provider
    If Not (Conn1 Is Nothing) Then
       AdoErrorEx List1, Conn1
    End If
    
    GoTo Done
End Sub

Public Sub SQLServer(List1 As ListBox)
   Dim Conn1 As ADODB.Connection
   Dim Cmd1 As ADODB.Command
   Dim Param1 As ADODB.Parameter
   Dim Param2 As ADODB.Parameter
   Dim Param3 As ADODB.Parameter
   Dim Rs1 As ADODB.Recordset
   
   Dim SQLServerName As String
   
   Dim SQLDrop As String
   Dim SQLCreate As String
   
   Dim i As Integer
   Dim l As Long
   Dim strTmp As String
      
   ' Trap error/exceptions
   On Error GoTo AdoError
   
   '----------------------------------------
   ' Define Connection string to SQL Server
   '----------------------------------------
      
   SQLServerName = InputBox("Enter name of SQL Server on your network:", _
                          "Select SQL Server", _
                          "Your SQL Server Name Goes Here")
                          
   If (Len(SQLServerName) = 0) Then
      GoTo Done
   End If
      
   SQLServerConnect = "driver={sql server};" & _
                      "server=" & SQLServerName & ";" & _
                      "Database=pubs;" & _
                      "PWD=;UID=sa;"
   
   '------------------------
   ' Open Connection Object
   '------------------------
   
   ' Warm & Fuzzy for user
   List1.Clear
   List1.AddItem "Demonstrating Return, Input and Output parameters..."
   List1.AddItem vbTab & "...Assumes SQL Server named " & SQLServerName
   List1.AddItem vbTab & "...With Error Handling Using Connection Object"
   List1.AddItem vbTab & "...uses stored procedure sp_AdoTest"
   
   ' Create Connection Object and open it
   Set Conn1 = New ADODB.Connection
   Conn1.ConnectionString = SQLServerConnect
   Conn1.Open

   '--------------------------
   ' Create Stored Procedures
   '--------------------------
   
   ' Define stored procedures the rest of this sample will use
   SQLDrop = "if exists " & _
               "(select * from sysobjects where " & _
               "id = object_id('dbo.sp_AdoTest') and " & _
               "sysstat & 0xf = 4)" & _
               "drop procedure dbo.sp_AdoTest"
               
   SQLCreate = "create proc sp_AdoTest( @InParam int, @OutParam int OUTPUT ) " & _
               "as " & _
               "select @OutParam = @InParam + 10SELECT * FROM Authors WHERE " & _
               "State <> 'CA' " & _
               "return @OutParam +10"
   
   List1.AddItem "Creating Stored Procedure..."
   
   Set Rs1 = Conn1.Execute(SQLDrop, l, adCmdText)
   Set Rs1 = Nothing
   
   Set Rs1 = Conn1.Execute(SQLCreate, l, adCmdText)
   Set Rs1 = Nothing

   '-----------------------------------
   ' Open Parameterized Command Object
   '-----------------------------------
   
   List1.AddItem "Opening a ForwardOnly Recordset from a Parameterized Command Object..."
   List1.AddItem "...creating command object"
     
   Set Cmd1 = New ADODB.Command        ' Don't use = '{call ?=sp_AdoTest(?, ?)}'
   Set Cmd1.ActiveConnection = Conn1   ' Parameters.Refresh won't work
   Cmd1.CommandText = "sp_AdoTest"     ' with "{call...}" syntax, Otherwise you
   Cmd1.CommandType = adCmdStoredProc  ' would have to create each parameter object
   Cmd1.Parameters.Refresh             ' and order of each parameter's direction
                                       ' must match the order of parameters given
                                       ' in the object
      
   List1.AddItem "...filling parameters collection"
   
   Cmd1.Parameters(1).Value = 10
   
   List1.AddItem "...opening Recordset"
   Set Rs1 = Cmd1.Execute()
   
   ' Display Parameters Collection
   List1.AddItem "...Dumping Recordset"

   ' Dump the recordset
   While (Rs1.EOF = False)
      strTmp = ""
      For i = 0 To Rs1.Fields.Count - 1
         If (Len(strTmp) > 0) Then
            strTmp = strTmp & " | "
         End If
         
         ' Empty string in case value is empty
         strTmp = strTmp & Rs1(i) & ""
      Next i
      
      List1.AddItem vbTab & strTmp
      
      Rs1.MoveNext
   Wend
         
   Set Rs1 = Nothing
   
   ' Display Parameters Collection (with caveat for user)
   List1.AddItem "...It is strictly Driver/Provider dependent whether you have to close"
   List1.AddItem "the recordset to retrieve output/return parameters.  With the release of"
   List1.AddItem "of the SQL Server ODBC Driver with ODBC 3.X, you have to close the recordset."
   List1.AddItem "Previous versions of this driver did not have this requirement, which itself"
   List1.AddItem "came about as part of a bug fix in previous versions of the driver."

   List1.AddItem vbTab & "RetVal Param = " & Cmd1.Parameters(0).Value
   List1.AddItem vbTab & "Input  Param = " & Cmd1.Parameters(1).Value
   List1.AddItem vbTab & "Output Param = " & Cmd1.Parameters(2).Value
      
   ' Successful Shutdown
   List1.AddItem "*** Success! ***"
   Conn1.Close
   
Done:
   '----------------------------------
   ' Miscellaneous (graceful) Cleanup
   ' with quiet error trapping
   '----------------------------------
   
   On Error Resume Next
      
   Set Rs1 = Nothing
   Set Param1 = Nothing
   Set Param2 = Nothing
   Set Param3 = Nothing
   Set Conn1 = Nothing
   
   Exit Sub

' Error/Exception Handler
AdoError:
    ' Check Err Object
    VbErrorEx List1, Err.Number, Err.Source, Err.Description
    
    ' Check ADO Errors Collection for Errors raised by Data provider
    If Not (Conn1 Is Nothing) Then
       AdoErrorEx List1, Conn1
    End If
    
    GoTo Done
End Sub