adovb.frm

vb下数据库的读取范例

VERSION 5.00
Begin VB.Form frmADOVB 
   Caption         =   "ActiveX Data Objects w/Visual Basic 5.0"
   ClientHeight    =   5400
   ClientLeft      =   1905
   ClientTop       =   1800
   ClientWidth     =   7185
   LinkTopic       =   "Form1"
   ScaleHeight     =   360
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   479
   Begin VB.CommandButton cmdTemplate 
      Caption         =   "Code Template"
      Height          =   372
      Left            =   4920
      TabIndex        =   4
      Top             =   120
      Width           =   2172
   End
   Begin VB.ListBox List1 
      Height          =   4020
      Left            =   120
      TabIndex        =   3
      Top             =   1080
      Width           =   6972
   End
   Begin VB.CommandButton cmdProperties 
      Caption         =   "&Provider Properties"
      Height          =   372
      Left            =   2520
      TabIndex        =   2
      Top             =   120
      Width           =   2172
   End
   Begin VB.CommandButton cmdSQLServer 
      Caption         =   "&Input / Output / Return Parameters (Requires SQL Server)"
      Height          =   372
      Left            =   120
      TabIndex        =   1
      Top             =   600
      Width           =   6972
   End
   Begin VB.CommandButton cmdAccess 
      Caption         =   "&Open Access Database"
      Height          =   372
      Left            =   120
      TabIndex        =   0
      Top             =   120
      Width           =   2172
   End
End
Attribute VB_Name = "frmADOVB"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'------------------------
' BEGIN VB SPECIFIC CODE
'------------------------
Option Explicit
Const WM_USER = &H400
Const LB_SETTABSTOPS = &H192
Const LB_SETHORIZONTALEXTENT As Long = &H194
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long

Dim ErrNumber As String
Dim ErrSource As String
Dim ErrDescription As String

'----------------------
' END VB SPECIFIC CODE
'----------------------

Dim AccessConnect As String
Dim SQLServerConnect As String



Private Sub Form_Load()

   '------------------------------------------------------
   ' VB SPECIFIC CODE:  For creating a Horizontal ListBox
   '                    Very Brute Force in setting the
   '                    horizontal extents, though
   '------------------------------------------------------
   Dim avgWidth As Single
   Dim tabstops(1 To 1)
   Dim i As Integer               ' Used in For Next loops.
   Dim scrollbarwidth  As Long    ' Width of horizontal scrollbar.
   Dim retval As Long
     
   avgWidth = Me.TextWidth("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ")
   avgWidth = avgWidth / Screen.TwipsPerPixelX / 52 * 10

   tabstops(1) = avgWidth * 4
   retval& = SendMessage(List1.hwnd, LB_SETTABSTOPS, 1, tabstops(1))
   
   scrollbarwidth = 256 * avgWidth + 2
   retval& = SendMessage(List1.hwnd, LB_SETHORIZONTALEXTENT, scrollbarwidth, 0&)
   
   '----------------------
   ' END VB SPECIFIC CODE
   '----------------------
   
                      
   ' Make sure that the DefaultDir for ADODEMO.MDB is correct
   AccessConnect = "DRIVER={Microsoft Access Driver (*.mdb)};" & _
                   "DBQ=ADODEMO.MDB;" & _
                   "DefaultDir=" & App.Path & ";" & _
                   "UID=admin;PWD=;"

End Sub


Private Sub cmdAccess_Click()
   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 (non-ADO) error/exceptions
   On Error GoTo VbError
   
   '------------------------
   ' 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
   
   ' Trap any error/exception
   On Error GoTo AdoError
   
   Conn1.ConnectionString = AccessConnect
   Conn1.Open

   '-----------------------------------
   ' Open Parameterized Command Object
   '-----------------------------------
   List1.AddItem vbTab & "...Parameterized Command Object"
   
   
   Set Cmd1 = New ADODB.Command
   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("Year Born")
      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
   
' ADO Error/Exception Handler
AdoError:
   ErrNumber = Err.Number
   ErrSource = Err.Source
   ErrDescription = Err.Description

   AdoErrorEx List1, Conn1
   
' Non-ADO Native error/exception handler
VbError:
   VbErrorEx List1, ErrNumber, ErrSource, ErrDescription
   GoTo Done

End Sub

Private Sub cmdProperties_Click()
   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 (non-ADO) error/exceptions
   On Error GoTo VbError
   
   '-------------------
   ' 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 = AccessConnect
   Conn1.Open

   ' Dump conneciton properties
   List1.AddItem "*** *** *** *** *** Dumping contents of the Properties Collection for the Connection object *** *** *** *** ***"
   
   For i = 0 To Conn1.Properties.Count - 1
      List1.AddItem vbTab & "Name = " & Conn1.Properties(i).Name
      List1.AddItem vbTab & "       Type = " & GetType(Conn1.Properties(i).Type)
      List1.AddItem vbTab & "       Value = " & Conn1.Properties(i).Value
      List1.AddItem vbTab & "       Attributes = " & GetPropertyAttributes(Conn1.Properties(i).Attributes)
   Next i
   
   '----------------
   ' Command Object
   '----------------
   
   Set Cmd1 = New ADODB.Command
   Cmd1.ActiveConnection = Conn1
   Cmd1.CommandText = "SELECT * FROM Authors"
   
   Set Rs1 = Cmd1.Execute()
   
   List1.AddItem "*** *** *** *** *** Dumping contents of the Properties Collection for the Command object *** *** *** *** ***"
   
   For i = 0 To Cmd1.Properties.Count - 1
      List1.AddItem vbTab & "Name = " & Cmd1.Properties(i).Name
      List1.AddItem vbTab & "       Type = " & GetType(Cmd1.Properties(i).Type)
      List1.AddItem vbTab & "       Value = " & Cmd1.Properties(i).Value
      List1.AddItem vbTab & "       Attributes = " & GetPropertyAttributes(Cmd1.Properties(i).Attributes)
   Next

   Dim a As ADODB.PropertyAttributesEnum
   
   
   '------------------
   ' Recordset Object
   '------------------
   
   List1.AddItem "*** *** *** *** *** Dumping contents of the Properties Collection for the Recordset object *** *** *** *** ***"

   For i = 0 To Rs1.Properties.Count - 1
      List1.AddItem vbTab & "Name = " & Rs1.Properties(i).Name
      List1.AddItem vbTab & "       Type = " & GetType(Rs1.Properties(i).Type)
      List1.AddItem vbTab & "       Value = " & Rs1.Properties(i).Value
      List1.AddItem vbTab & "       Attributes = " & GetPropertyAttributes(Rs1.Properties(i).Attributes)
   Next