cauthor.cls

《VB6数据库开发指南》所有的例程的源码

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cAuthor"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
Public Sub NewAuthor(psau_id As String, psau_lname As String _
    , psau_fname As String, psphone As String, psaddress As String _
    , pscity As String, psstate As String, pszip As String _
    , pbcontract As Boolean)
    Dim Conn As Connection
    
    Set Conn = New Connection
    Conn.Open "Provider=SQLOLEDB.1;User ID=sa;Password=;" _
        + "Location=WINEMILLER;Database=pubs"
    
    'build insest string
    Dim sCmd As String
    sCmd = "insert authors (au_id, au_lname, au_fname , phone , address"
    sCmd = sCmd + ", city, state, zip, contract)"
    sCmd = sCmd + " values "
    sCmd = sCmd + "('" + psau_id + "'"
    sCmd = sCmd + ",'" + psau_lname + "'"
    sCmd = sCmd + ",'" + psau_fname + "'"
    sCmd = sCmd + ",'" + psphone + "'"
    sCmd = sCmd + ",'" + psaddress + "'"
    sCmd = sCmd + ",'" + pscity + "'"
    sCmd = sCmd + ",'" + psstate + "'"
    sCmd = sCmd + ",'" + pszip + "'"
    sCmd = sCmd + "," & IIf(pbcontract, 1, 0)
    sCmd = sCmd + ")"
    'use execute to do the insert
    On Error GoTo InsertError
    Conn.Execute sCmd
    
    GetObjectContext().SetComplete
    Exit Sub
InsertError:
    GetObjectContext().SetAbort
    Err.Raise vbObjectError, , "Error inserting"
End Sub
Public Sub UpdateAuthor(psau_id As String, psau_lname As String _
    , psau_fname As String, psphone As String, psaddress As String _
    , pscity As String, psstate As String, pszip As String _
    , pbcontract As Boolean)
    Dim Conn As Connection
    
    Set Conn = New Connection
    Conn.Open "Provider=SQLOLEDB.1;User ID=sa;Password=;" _
        + "Location=WINEMILLER;Database=pubs"
    
    'build udpate string
    Dim sCmd As String
    sCmd = "update authors "
    sCmd = sCmd + " set"
    sCmd = sCmd + " au_lname = '" + psau_lname + "'"
    sCmd = sCmd + ",au_fname = '" + psau_fname + "'"
    sCmd = sCmd + ",phone = '" + psphone + "'"
    sCmd = sCmd + ",address = '" + psaddress + "'"
    sCmd = sCmd + ",city = '" + pscity + "'"
    sCmd = sCmd + ",state = '" + psstate + "'"
    sCmd = sCmd + ",zip = '" + pszip + "'"
    sCmd = sCmd + ",contract = " & IIf(pbcontract, 1, 0)
    sCmd = sCmd + " where au_id = '" + psau_id + "'"
    'use execute to do the update
    On Error GoTo UpdateError
    Conn.Execute sCmd
    
    GetObjectContext().SetComplete
    Exit Sub
UpdateError:
    GetObjectContext().SetAbort
    Err.Raise vbObjectError, , "Error updating"
End Sub
Public Sub DeleteAuthor(psau_id As String)
    Dim Conn As Connection
    
    Set Conn = New Connection
    Conn.Open "Provider=SQLOLEDB.1;User ID=sa;Password=;" _
        + "Location=WINEMILLER;Database=pubs"
    
    'build delete string
    Dim sCmd As String
    sCmd = "delete authors"
    sCmd = sCmd + " where au_id = '" + psau_id + "'"
    'use execute to do the delete
    On Error GoTo DeleteError:
    Conn.Execute sCmd
    
    GetObjectContext().SetComplete
    Exit Sub
DeleteError:
    GetObjectContext().SetAbort
    Err.Raise vbObjectError, , "Error deleting"
End Sub
Public Function GetList(Optional psWhere As String) As Object
    Dim Conn As Connection
    
    Set Conn = New Connection
    Conn.Open "Provider=SQLOLEDB.1;User ID=sa;Password=;" _
        + "Location=WINEMILLER;Database=pubs"
    
    'return a record set to the client as object so they don't
    'even need to have a reference to ADO to use this object
    Dim sCmd As String
    Dim rs As Recordset
    
    sCmd = "select * from authors"
    'if they wanted a restricted list give it to them
    If Len(psWhere) > 0 Then
        sCmd = sCmd + " where " + psWhere
    End If
    
    Set rs = New Recordset
    rs.CursorLocation = adUseClient
    
    On Error GoTo GetListError:
    rs.Open sCmd, Conn, adOpenForwardOnly, adLockReadOnly, adCmdText
    
    Set GetList = rs
    GetObjectContext().SetComplete
    Exit Function
GetListError:
    GetObjectContext().SetAbort
    Err.Raise vbObjectError, , "Error getting list"
End Function