Solved

Implements a class

Posted on 2001-08-26
36
335 Views
Last Modified: 2013-11-23
Hi experts,

1. If classB implements classA, we can do:
Dim obj As classA
Set obj = New classB

2. If we copy all the procedures from classA into a new class, classB. We can also do the job:
Dim obj As classB
Set obj = New classB

So, can you tell me what is the advantage by the first approuch?
0
Comment
Question by:markdot
  • 11
  • 10
  • 6
  • +3
36 Comments
 
LVL 142

Expert Comment

by:Guy Hengel [angelIII / a3]
ID: 6426720
It's a question of interface ...
Now to be honest, i used this kind of things not often. I used it in 2 large projects, in order to simplify and reduce some  code in the main forms...

In fact, using the main ideas, you could eventually enlarge your application without recompiling it, using additional activeX ...

If you have a class DataItem that has the methods Save, Open, Edit  etc...
You can implement any kind of classes, and an edit form will only need to use that interface... You don't need a form per class... That's theory... Practice is technically difficult...

Cheers
0
 
LVL 28

Accepted Solution

by:
AzraSound earned 60 total points
ID: 6426760
If you create an interface class, that class need not contain any code at all.  It simply serves as a template.  For example, if you had an Animal class, and called it IAnimal, it may have some basic functions that all animals share:


Public Sub Eat()
End Sub

Public Sub Sleep()
End Sub


Now, any class you create that implements this interface, MUST provide functionality for those code statements, e.g.,

'CDog - dog class
Implements IAnimal

Public Sub IAnimal_Eat()
   'dog eats dogfood
End Sub

Public Sub IAnimal_Sleep()
   'sleep in doghouse
End Sub

Public Sub Bark()
   'unique to a dog
End Sub


The same could be said for a cat, e.g.,

'CCat - cat class
Implements IAnimal

Public Sub IAnimal_Eat()
   'cat eats catfood
End Sub

Public Sub IAnimal_Sleep()
   'sleeps on couch
End Sub

Public Sub Meow()
   'unique to a cat
End Sub



As you can see, it lets you ensure that objects that implement this interface, all abide by the same rules, based on the template defined in the interface.  Thus, say in a client program, you want to be able to tell the animal passed in to eat.  Since you can be sure each animal implements the required interface, you can have functions that expect the interface as a parameter, and call functions of that interface, e.g.,

'some client prog
Sub EatFood(Animal As IAnimal)
   Call Animal.Eat
End Sub

Thus, this function could take an instance of a dog class, cat class, etc, and perform the Eat method as its defined for that particular class.
0
 

Author Comment

by:markdot
ID: 6426871
To AzraSound:

That is quite interesting....but still not understand...
1. Why the class name start with 'I': IAnimal :-)
2. Sub EatFood(Animal As IAnimal)
   Call Animal.Eat
   End Sub
Can we call .Eat without firstly Set Animal = New CDog?
0
 
LVL 28

Expert Comment

by:AzraSound
ID: 6426955
>>Why the class name start with 'I': IAnimal

That is my syntax of choice, to tell me that it is an interface (a class which defined methods, but with no actual code in those methods).  This is a personal preference, so you can name it however you wish to let you understand it clearer.


>>Can we call .Eat without firstly Set Animal = New CDog?

Yes, because Animal is the parameter being passed to the function EatFood.  The function assumes that Animal is already an existing object.  For example, assuming you had all the classes defined above in a project, then, in a form, you could have:


Private Sub Command1_Click()
   Dim myDog As New CDog
   Dim myCat As New CCat

   Call EatFood(myDog)
   Call EatFood(myCat)
End Sub


Sub EatFood(Animal As IAnimal)
   Call Animal.Eat
End Sub



You see, the EatFood function does not care what object it is getting, so long as that object derives from a class that Implements the IAnimal interface class.  It will then call the IAnimal_Eat function as it is defined for that particular object.  To make it a bit clearer, for the IAnimal_Eat methods of the Dog and Cat class, write a line of code to prompt you with the method call, e.g.,


'Dog class
Public Sub IAnimal_Eat()
   MsgBox "Dog is eating"
End Sub


'Cat clas
Public Sub IAnimal_Eat()
   MsgBox "Cat is eating"
End Sub
0
 

Author Comment

by:markdot
ID: 6427084
Hi  AzraSound,

Yse....you explained very clear.....Thanks!

One thing more:
     'CDog - dog class
     Implements IAnimal
     Public Sub IAnimal_Eat()
     'dog eats dogfood
     End Sub
Do you think we should use Private instead of Public?
0
 
LVL 5

Expert Comment

by:rkot2000
ID: 6427102
markdot - yes 100% correct it must be private not public.

I used implements to develop secondary interfaces like
Dog and later Dog2(dog2 has extra arguments or new functions)  without breaking clients
code  

Just keep in mind you must use early binding in order to get access to the implemented interface. VB calls QueryIntrface from Iunknown,
so this solution does not work for late binding clients as asp clients or scripts (clients based on Idispatch interface)
0
 

Author Comment

by:markdot
ID: 6427111
To AzraSound:

Any I tried
Dim myDog As New CDog
not work. Do we need
Dim myDog As IAnimal
Set myDog = New CDog
-------------------------------------

To rkot2000:

Thank you for your help.

>Just keep in mind you must use early binding in order to get access to the implemented interface.
Can you give me an example?
0
 
LVL 28

Expert Comment

by:AzraSound
ID: 6427130
What exactly failed for you markdot?  Can you post all the code?


Early Binding:
Dim myDog As CDog
Set myDog = New CDog


Late Binding:
Dim myDog As Object
Set myDog = CreateObject("Component.CDog")
0
 

Author Comment

by:markdot
ID: 6427168
To AzraSound:

'Form1
Private Sub Command1_Click()
Dim myDog As New CDog
myDog.Speak     'error: method not found
End Sub
---------------
'IAnimal
Public Sub Speak()
End Sub
-----------------
'CDog
Implements IAnimal
Private Sub IAnimal_Speak()
MsgBox "bark"
End Sub
0
 

Author Comment

by:markdot
ID: 6427187
Hi AzraSound,

Are these also Late Binding:

Dim myDog As Object
Set myDog = New CDog
----------
Dim myDog As IAnimal
Set myDog = New CDog
0
 
LVL 28

Expert Comment

by:AzraSound
ID: 6427192
Well the problem is that the Speak method is Private to the dog class.  If you want to be able to call it explicitly, it needs to be public.  However, if you passed the dog class to a function that expects a parameter of type IAnimal, then you can call it directly from that function, e.g.,


Private Sub Command1_Click()
   Dim myDog As New CDog
   Call AnimalSpeak(myDog)
End Sub

Sub AnimalSpeak(Animal As IAnimal)
   Call Animal.Speak
End Sub


This will call the Speak method of the object passed in that implements the IAnimal interface.  It receives the CDog object, finds its implementation of the Speak method, and then calls it.
0
 
LVL 15

Expert Comment

by:ameba
ID: 6427195
For markdot's homework   :-)

Early or Late Binding?

3.
Dim myDog As Object
Set myDog = New CDog

4.
Dim myDog As CDog
Set myDog = CreateObject("Component.CDog")
0
 

Author Comment

by:markdot
ID: 6427208
To AzraSound:

I have just changed to 'Public' without success:
'Form1
Private Sub Command1_Click()
Dim myDog As New CDog
myDog.Speak     'error: method not found
End Sub
---------------
'IAnimal
Public Sub Speak()
End Sub
-----------------
'CDog
Implements IAnimal
Public Sub IAnimal_Speak()
MsgBox "bark"
End Sub
0
 
LVL 28

Expert Comment

by:AzraSound
ID: 6427211
Well, once it is declared as Public, the function name is no longer just Speak, as it appears to the interface class, it is IAnimal_Speak, and if you wish to call it explicitly, you must call it with this name.

myDog.IAnimal_Speak

If you have Intellisense turned on, you should have seen this right when you typed the period after myDog(.)[List of public members]
0
 

Author Comment

by:markdot
ID: 6427214
Hi ameba:

Unfortunately, I am not a student:-( Anyway, I try to answer the question: Early or Late Binding?
1.
Dim myDog As Object
Set myDog = New CDog
2.
Dim myDog As IAnimal
Set myDog = New CDog
3.
Dim myDog As Object
Set myDog = New CDog
4.
Dim myDog As CDog
Set myDog = CreateObject("Component.CDog")
1. Late, 2. Lage, 3. Late, 4. Early.
0
 
LVL 15

Expert Comment

by:ameba
ID: 6427219
markdot,
Only one small mistake (2. Early) - you have good teacher(s)  ;-)
0
 

Author Comment

by:markdot
ID: 6427228
Hi ameba,

I never believe a teacher until he/she give prove.
Why you say
Dim myDog As IAnimal
Set myDog = New CDog
is Early binding? Can you show me how to prove this:-)
0
 
LVL 15

Expert Comment

by:ameba
ID: 6427256
>Can you show me how to prove this?

It is by definition - we do not have to prove definitions. :-)

Is it Late or Early binding depends only on declaration.
If declaration has "As Object" then it is Late Binding, and when you specify class, it is Early.

"As Variant" is also Late (variants can hold objects)
"As Form", "As Control" are also Late Binding (those are two exceptions)

OK. One for you:

If two classes expose the same interface, we call them .......... classes.

.......... = ?


And advanced one for other experts:

Write *polymorphic* routine which is able to change Caption of Form1 and Form2 (two different forms).
0
How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

 

Author Comment

by:markdot
ID: 6427281
Hi All experts (including ameba), can yor support me:

Assume class CChild is derived from CParent, and we have
Dim myDog As CParent
Set myDog = New CChild
We defined this is Late Binding.

----------------
To amebe only:
If two classes expose the same interface, we call them POLYMORPHIC classes.



0
 
LVL 15

Expert Comment

by:ameba
ID: 6427303
markdot,

>We defined this is Late Binding.
No, it's early binding. You are accessing myDog object via its secondary (known, well defined at design time) interface.

>Assume class CChild is derived from CParent
I don't think you can use "derived" term in its OO meaning - VB6 doesn't support inheritance.

>If two classes expose the same interface ...
POLYMORPHIC is correct.  :-)


Any 'takers' for the early bound ChangeCaption routine.

' this uses late binding (very slow)  - this is NOT the solution
Public Sub ChangeCaption(obj As Form)
    obj.Caption = "Changed"
End Sub
0
 
LVL 28

Expert Comment

by:AzraSound
ID: 6427347
Not sure, along the same lines you can define the interface for changing the caption:

'Interface class ICaption
Sub ChangeCaption(NewCaption As String)
End Sub


'Form1 & Form2
Implements ICaption
Private Sub ICaption_ChangeCaption(NewCaption As String)
   Me.Caption = NewCaption
End Sub


'public function
Sub ChangeFormCaption(FormObject As ICaption, NewCaption As String)
   Call FormObject.Caption(NewCaption)
End Sub
0
 
LVL 15

Expert Comment

by:ameba
ID: 6427370
AzraSound, that is correct. Points are yours  :-)

AzraSound used a *Method* in his interface (Sub ChangeCaption)

It is also possible to use a *Property* in interface:

' class ICaptionable  (abstract class, or interface) ------
Option Explicit
Public Caption As String

' in bas module  ----------------------------
' polymorphic routine to change caption of any object
'   which implements ICaptionable interface
'
Public Sub ChangeCaption(obj As ICaptionable)
    obj.Caption = "Changed"
End Sub

' Form1 / Form2 ------------------------------------------
Option Explicit
Implements ICaptionable

Private Property Let ICaptionable_Caption(ByVal RHS As String)
    Me.Caption = RHS
End Property

Private Property Get ICaptionable_Caption() As String
End Property

Private Sub Form_Click()
    ' this is to test our function
    ChangeCaption Me
End Sub
0
 
LVL 15

Expert Comment

by:ameba
ID: 6427378
Methods, Properties, ... we also have Events, but VB doesn't allow implementing events  :-(
0
 
LVL 15

Expert Comment

by:ameba
ID: 6427398
Also, you cannot use arrays in polymorphic procedures:
' this won't work
Public Sub ChangeCaption(obj() As ICaptionable)

from http://www.vb2themax.com/HtmlDoc.asp?Table=Articles&ID=350
"However, in some situations you can?t use secondary interfaces to write polymorphic routines; most notably when you need to pass an array of objects. If you have a routine that expects an array of objects of type "A", you can't pass it an array of objects of type "B," even if class "B" implements "A" as a secondary interface."
0
 
LVL 4

Expert Comment

by:vindevogel
ID: 6428156
I haven't read this whole thread, but I'll explain you one thing we use ....

We have a class IDataObject.  This class is implemented by SQL7DataObject and SQL2KDataObject.
We have another wrapper around that ... class DataObject.

Now, class DataObject uses delegation towards the IDataObject ... well, to one of the two that are implementing IDataObject.

DataObject has a property, "Parent".  This is used to see in the registry on which database the data is retreived.  One of the properties of that database in the registry is its type, sql 7 or 2000.  We then set our vIDataObject = new SQL7 or SQL2KDataObject.

I hope this real life example helps you a bit ...

I'm willing to post our code of these objects.  AzraSound or Ameba, if you are interested, I'll post too ...
0
 
LVL 15

Expert Comment

by:ameba
ID: 6428517
Sure, vindevogel, you're welcome to post it, well designed interfaces can be very useful.

Interfaces can be very simple (few lines, or only one code line), but they often require more work than implementation.
0
 
LVL 4

Expert Comment

by:vindevogel
ID: 6428780
THIS IS THE CLSIDATA
********************


Option Explicit

Public ServerName As String
Public Catalog As String
Public Provider As String

Public Recordset As ADODB.Recordset
Public Connection As ADODB.Connection

Public Sub SaveSingleObject(aObject As Object)
End Sub

Public Sub CreateSingleObject(aObject As Object)
End Sub

Public Function ExecuteSQL(aSQL As String, Optional aPRMObject As Object = Nothing, Optional aCommandType As CommandTypeEnum = adCmdText) As Long
End Function

Public Function ExecuteSP(aStoredProcedure As String, Optional aPRMObject As Object = Nothing) As Long
End Function

Public Function OpenRecordsetSP(aStoredProcedure As String, Optional aPRMObject As Object = Nothing, Optional ByRef aReturnValueSP As Long = 0) As ADODB.Recordset
End Function

Public Function OpenRecordsetSQL(aSQL As String, Optional aCursorType As CursorTypeEnum = adOpenStatic, Optional aCursorlocation As CursorLocationEnum = adUseClient, Optional aLockType As LockTypeEnum = adLockOptimistic) As ADODB.Recordset
End Function

Public Sub OpenConnection(Optional aDefaultCursorLocation As CursorLocationEnum = adUseClient)
End Sub

Public Sub CloseConnection()
End Sub

Public Sub BeginTrans()
End Sub

Public Sub CommitTrans()
End Sub

Public Sub RollbackTrans()
End Sub

Public Property Get Errors() As ADODB.Errors
End Property



THIS IS THE CLSSQL2KDATA (clsSql7Data is very similar)
******************************************************

Option Explicit

Implements dlkIData.clsIData

Private mServerName As String
Private mCatalog As String
Private mProvider As String

Private mConnection As ADODB.Connection
Private mRecordset As ADODB.Recordset
Private mStream As ADODB.Stream

Private mCollection As Collection
Private mTransactionStatus As dlkDataTransactionStatus

Public Property Get clsIData_Recordset() As ADODB.Recordset
    On Error GoTo Handler
   
    Set clsIData_Recordset = mRecordset
   
    Exit Property
Handler:
    Err.Raise Err.Number, Erl & "Property Get Recordset - clsSQL2KData - " & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Property

Public Property Set clsIData_Recordset(ByVal aRS As ADODB.Recordset)
    On Error GoTo Handler
   
    Set mRecordset = aRS
   
    Set mStream = Nothing   'To ensure the load of the stream is done again
   
    Exit Property
Handler:
    Err.Raise Err.Number, Erl & "Property Set Recordset - clsSQL2KData - " & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Property

Public Property Get clsIData_Connection() As ADODB.Connection
    On Error GoTo Handler
   
    Set clsIData_Connection = mConnection
   
    Exit Property
Handler:
    Err.Raise Err.Number, Erl & "Property Get Connection - clsSQL2KData - " & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Property

Public Property Set clsIData_Connection(ByVal aCN As ADODB.Connection)
    On Error GoTo Handler
   
    Set mConnection = aCN
   
    Exit Property
Handler:
    Err.Raise Err.Number, Erl & "Property Set Connection - clsSQL2KData - " & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Property

Private Sub Class_Terminate()
    On Error Resume Next
   
    mRecordset.Close
    Set mRecordset = Nothing
   
    mStream.Close
    Set mStream = Nothing
   
    mConnection.Cancel
    mConnection.Close
    Set mConnection = Nothing
   
    Set mCollection = Nothing
End Sub

Public Property Let clsIData_Provider(ByVal aProvider As String)
    On Error GoTo Handler
   
    mProvider = aProvider
   
    Exit Property
Handler:
    Err.Raise Err.Number, Erl & "Property Let Provider - clsSQL2KData - " & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Property

Public Property Get clsIData_Provider() As String
    On Error GoTo Handler
   
    clsIData_Provider = mProvider
   
    Exit Property
Handler:
    Err.Raise Err.Number, Erl & "Property Get Provider - clsSQL2KData - " & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Property

Public Property Let clsIData_ServerName(ByVal aServerName As String)
    On Error GoTo Handler
   
    mServerName = aServerName
   
    Exit Property
Handler:
    Err.Raise Err.Number, Erl & "Property Let Servername - clsSQL2KData - " & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Property

Public Property Get clsIData_ServerName() As String
    On Error GoTo Handler
   
    clsIData_ServerName = mServerName
   
    Exit Property
Handler:
    Err.Raise Err.Number, Erl & "Property Get ServerName - clsSQL2KData - " & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Property

Public Property Let clsIData_Catalog(ByVal aCatalog As String)
    On Error GoTo Handler
   
    mCatalog = aCatalog
   
    Exit Property
Handler:
    Err.Raise Err.Number, Erl & "Property Let Catalog - clsSQL2KData - " & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Property

Public Property Get clsIData_Catalog() As String
    On Error GoTo Handler
   
    clsIData_Catalog = mCatalog
   
    Exit Property
Handler:
    Err.Raise Err.Number, Erl & "Property Get Catalog - clsSQL2KData - " & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Property

Public Sub clsIData_SaveSingleObject(aObject As Object)
    On Error GoTo Handler
    Dim vField As ADODB.Field
   
    On Error Resume Next
   
    For Each vField In mRecordset.Fields
        If Not (vField.Type = adGUID And vField.Properties("KEYCOLUMN").Value = True) Then
            vField.Value = CallByName(aObject, vField.Name, VbGet)
        End If
    Next
   
    On Error GoTo Handler
   
    mRecordset.Update
   
    Set vField = Nothing
    Exit Sub
Handler:
    Err.Raise Err.Number, Erl & "Sub SaveSingleObject - clsSQL2KData - " & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub

Public Sub clsIData_CreateSingleObject(aObject As Object)
    On Error GoTo Handler
    Dim vField As ADODB.Field
   
    On Error Resume Next
   
    For Each vField In mRecordset.Fields
        CallByName aObject, vField.Name, VbLet, vField.Value & ""
    Next
   
    On Error GoTo Handler
    Set vField = Nothing
   
    Exit Sub
Handler:
    Err.Raise Err.Number, Erl & "Sub CreateSingleObject - clsSQL2KData - " & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub

Public Function clsIData_ExecuteSP(aStoredProcedure As String, Optional aPRMObject As Object = Nothing) As Long
    On Error GoTo Handler
   
    clsIData_ExecuteSP = clsIData_ExecuteSQL(aStoredProcedure, aPRMObject, adCmdStoredProc)
   
    Exit Function
Handler:
    Err.Raise Err.Number, Erl & "Function ExecuteSP - clsSQL2KData - " & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Function

Public Function clsIData_ExecuteSQL(aSQL As String, Optional aPRMObject As Object = Nothing, Optional aCommandType As CommandTypeEnum = adCmdText) As Long
    On Error GoTo Handler
    Dim vCmdSP As New ADODB.Command
   
    Set vCmdSP.ActiveConnection = mConnection
    vCmdSP.CommandText = aSQL
    vCmdSP.CommandType = aCommandType
   
    vCmdSP.Parameters.Refresh
   
    If Not vCmdSP.Parameters.Count = 0 Then
        Object2Parameters aPRMObject, vCmdSP.Parameters
    End If
   
'Yv
    vCmdSP.ActiveConnection.Errors.Clear
   
    vCmdSP.Execute
   
'YV
    If Not vCmdSP.Parameters.Count = 0 Then
        Parameters2Object aPRMObject, vCmdSP.Parameters
       
        clsIData_ExecuteSQL = vCmdSP.Parameters("@RETURN_VALUE").Value
    End If
   
    Set vCmdSP = Nothing
   
    Exit Function
Handler:
'YV
    If vCmdSP.ActiveConnection.Errors.Count > 0 Then
        Resume Next
    Else
        Err.Raise Err.Number, Erl & "Function ExecuteSql - clsSQL2KData - " & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
    End If
   
End Function

Public Function clsIData_OpenRecordsetSP(aStoredProcedure As String, Optional aPRMObject As Object = Nothing, Optional ByRef aReturnValueSP As Long = 0) As ADODB.Recordset
    On Error GoTo Handler
    Dim vCmdSP As New ADODB.Command
    Dim vPrmLoop As Parameter
   
    If Not mRecordset Is Nothing Then
        If mRecordset.State = adStateOpen Then
            mRecordset.Close
        End If
        Set mRecordset = Nothing
    End If
   
    Set mRecordset = New ADODB.Recordset
   
    Set vCmdSP.ActiveConnection = mConnection
    vCmdSP.CommandText = aStoredProcedure
    vCmdSP.CommandType = adCmdStoredProc
   
    vCmdSP.Parameters.Refresh
   
    Object2Parameters aPRMObject, vCmdSP.Parameters
   
    Set mRecordset = vCmdSP.Execute
   
    aReturnValueSP = vCmdSP.Parameters("@RETURN_VALUE").Value
   
    Set clsIData_OpenRecordsetSP = mRecordset
   
    Set vCmdSP = Nothing
    Set vPrmLoop = Nothing
   
    Exit Function
Handler:
    Err.Raise Err.Number, Erl & "Function OpenRecordsetSP - clsSQL2KData - " & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Function

Public Function clsIData_OpenRecordsetSQL(aSQL As String, Optional aCursorType As CursorTypeEnum = adOpenStatic, Optional aCursorlocation As CursorLocationEnum = adUseClient, Optional aLockType As LockTypeEnum = adLockOptimistic) As Recordset
    On Error GoTo Handler
   
    If Not mRecordset Is Nothing Then
        If mRecordset.State = adStateOpen Then
            mRecordset.Close
        End If
        Set mRecordset = Nothing
    End If
   
    Set mRecordset = New ADODB.Recordset
   
    mRecordset.ActiveConnection = mConnection
    mRecordset.CursorType = aCursorType
    mRecordset.CursorLocation = aCursorlocation
    mRecordset.LockType = aLockType
   
    mRecordset.Source = aSQL
   
    mRecordset.Open
   
    Set clsIData_OpenRecordsetSQL = mRecordset
   
    Exit Function
Handler:
    Err.Raise Err.Number, Erl & "Function OpenRecordsetSql - clsSQL2KData - " & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Function

Public Sub clsIData_CloseConnection()
    On Error Resume Next
    mConnection.Close
    Set mConnection = Nothing
End Sub

Public Sub clsIData_OpenConnection(Optional aDefaultCursorLocation As CursorLocationEnum = adUseClient)
    On Error GoTo Handler
    If Not mConnection Is Nothing Then
        mConnection.Close
        Set mConnection = Nothing
    End If
   
    Set mConnection = New ADODB.Connection
   
    mConnection.ConnectionString = "Provider=" & mProvider & _
            ";Data Source=" & mServerName & _
            ";Initial Catalog=" & mCatalog & _
            ";User ID=sa;Password=;Persist Security Info=False"
   
    mConnection.CursorLocation = aDefaultCursorLocation
   
    mConnection.Open
   
    Exit Sub
Handler:
    Err.Raise Err.Number, Erl & "Sub OpenConnnection - clsSQL2KData - " & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub

Public Sub clsIData_BeginTrans()
    On Error GoTo Handler
   
    mConnection.BeginTrans
    mTransactionStatus = dlkDataTransactionInProgress
   
    Exit Sub
Handler:
    Err.Raise Err.Number, Erl & "Sub BeginTrans - clsSQL2KData - " & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub

Public Sub clsIData_CommitTrans()
    On Error GoTo Handler
   
    mConnection.CommitTrans
    mTransactionStatus = dlkDataNotInTransaction
   
    Exit Sub
Handler:
    Err.Raise Err.Number, Erl & "Sub CommitTrans- clsSQL2KData - " & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub

Public Sub clsIData_RollbackTrans()
    On Error GoTo Handler
   
    mConnection.RollbackTrans
    mTransactionStatus = dlkDataNotInTransaction
   
    Exit Sub
Handler:
    Err.Raise Err.Number, Erl & "Sub RolbackTrans- clsSQL2KData - " & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub

Public Property Get clsIData_Errors() As ADODB.Errors
    On Error GoTo Handler
   
    Set clsIData_Errors = mConnection.Errors
   
    Exit Property
Handler:
    Err.Raise Err.Number, Erl & "Property Get Errors - clsSQL2KData - " & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Property

Private Sub Object2Parameters(aPRMObject As Object, aParameters As Parameters)
    On Error GoTo Handler
    Dim vPrmLoop As Parameter
    Dim vVal As String
   
    For Each vPrmLoop In aParameters
        If Not (vPrmLoop.Direction = adParamOutput Or vPrmLoop.Direction = adParamReturnValue Or vPrmLoop.Direction = adParamInputOutput) Then
           
            ' SL 31/7/2001 : if uniqueidentifier and the string value is "", then return NULL as parameter.
            If vPrmLoop.Type = adGUID Then
                vVal = CallByName(aPRMObject, IIf(Left(vPrmLoop.Name, 1) = "@", Mid(vPrmLoop.Name, 2), vPrmLoop.Name), VbGet)
                vPrmLoop.Value = IIf(vVal = "", Null, vVal)
            Else
                vPrmLoop.Value = CallByName(aPRMObject, IIf(Left(vPrmLoop.Name, 1) = "@", Mid(vPrmLoop.Name, 2), vPrmLoop.Name), VbGet)
            End If
           
        End If
    Next
   
    On Error Resume Next
   
    For Each vPrmLoop In aParameters
        If vPrmLoop.Direction = adParamInputOutput Then
           
            ' SL 31/7/2001 : if uniqueidentifier and the string value is "", then return NULL as parameter.
            If vPrmLoop.Type = adGUID Then
                vVal = CallByName(aPRMObject, IIf(Left(vPrmLoop.Name, 1) = "@", Mid(vPrmLoop.Name, 2), vPrmLoop.Name), VbGet)
                vPrmLoop.Value = IIf(vVal = "", Null, vVal)
            Else
                vPrmLoop.Value = CallByName(aPRMObject, IIf(Left(vPrmLoop.Name, 1) = "@", Mid(vPrmLoop.Name, 2), vPrmLoop.Name), VbGet)
            End If
        End If
    Next
   
    On Error GoTo Handler
   
    Set vPrmLoop = Nothing
   
    Exit Sub
   
Handler:
    Err.Raise Err.Number, Erl & "Sub Object2Parameters - clsSQL2KData - " & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub

Private Sub Parameters2Object(aPRMObject As Object, aParameters As Parameters)
    On Error GoTo Handler
   
    Dim vPrmLoop As Parameter
   
    On Error GoTo Handler
   
    For Each vPrmLoop In aParameters
        If vPrmLoop.Direction = adParamInputOutput Then
            CallByName aPRMObject, IIf(Left(vPrmLoop.Name, 1) = "@", Mid(vPrmLoop.Name, 2), vPrmLoop.Name), VbLet, vPrmLoop.Value
        End If
    Next
   
    Set vPrmLoop = Nothing
   
    Exit Sub
Handler:
    Err.Raise Err.Number, Erl & "sub Parameters2Object - clsSQL2KData - " & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub

Private Function CollectionFromRecordset(aRS As Recordset, aObjectType As String) As Collection
    On Error GoTo Handler
    Dim vObject As Object
    Dim vField As ADODB.Field
    Dim vCollection As Collection
   
    Set vCollection = New Collection
    If aRS.RecordCount > 0 Then
        aRS.MoveFirst
       
        Do
            Set vObject = CreateObject(aObjectType)
           
            Me.clsIData_CreateSingleObject vObject
            vCollection.Add vObject
           
            aRS.MoveNext
            Set vObject = Nothing
        Loop Until aRS.EOF
    End If
   
    Set CollectionFromRecordset = vCollection
   
    Set vCollection = Nothing
    Set vCollection = Nothing
   
    Exit Function
Handler:
    Err.Raise Err.Number, Erl & "Function CollectionFromRecordset - clsSQL2KData - " & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Function


THIS IS THE CLSDATA
*******************

Option Explicit

Private mDBMnemonic As String
Private mDBType As String

Private mIData As dlkIData.clsIData

Private mParent As Object

Private Sub Class_Terminate()
10              Me.CloseConnection
               
30              Set mIData = Nothing
40              Set mParent = Nothing
End Sub

Public Property Set Parent(aObject As Object)
                On Error GoTo Handler
                Dim vRegistry As dlkRegistry.clsDalkiaRegistry
               
80              Set mParent = aObject
               
100         Set vRegistry = New dlkRegistry.clsDalkiaRegistry
               
120         vRegistry.AppName = "Objects\" & TypeName(aObject)
130         mDBMnemonic = vRegistry.GetMachineParameter("DBMnemonic")
               
150         vRegistry.AppName = "Databases\" & mDBMnemonic
160         mDBType = vRegistry.GetMachineParameter("DBType")
               
                Select Case mDBType
                Case dlkDBTypeSQL2k
200             Set mIData = New dlkSQL2KData.clsSQL2KData
210         Case dlkDBTypeSQL7
220             Set mIData = New dlkSQL7Data.clsSQL7Data
230         Case dlkDBTypeUnSpecified
240             Err.Raise vbObjectError + errUnknownDBType, "dlkData.clsData - Property Set Parent", errStrUnknownDBType
                End Select
               
270         mIData.Catalog = vRegistry.GetMachineParameter("Catalog")
280         mIData.ServerName = vRegistry.GetMachineParameter("ServerName")
290         mIData.Provider = vRegistry.GetMachineParameter("Provider")
               
310         mIData.OpenConnection
320         Set vRegistry = Nothing
               
'YV
340         Set mParent = Nothing
                Exit Property
Handler:
360         Err.Raise Err.Number, Erl & " - Property set parent - clsData - dlkData - " & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Property

Public Property Get Parent() As Object
                On Error GoTo Handler
380         Set Parent = mParent
                Exit Property
Handler:
400         Err.Raise Err.Number, Erl & " - Property get parent - clsData - dlkData - " & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Property

Public Property Get Recordset() As ADODB.Recordset
                On Error GoTo Handler
420         Set Recordset = mIData.Recordset
                Exit Property
Handler:
440         Err.Raise Err.Number, Erl & " - Property Get Recordset - clsData - dlkData - " & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Property

Public Property Set Recordset(aRS As ADODB.Recordset)
                On Error GoTo Handler
460         Set mIData.Recordset = aRS
                Exit Property
Handler:
480         Err.Raise Err.Number, Erl & " - Property set recordset - clsData - dlkData - " & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Property

Public Property Get Connection() As ADODB.Connection
                On Error GoTo Handler
500         Set Connection = mIData.Connection
                Exit Property
Handler:
520         Err.Raise Err.Number, Erl & " - Property get connection - clsData - dlkData - " & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Property

Public Property Set Connection(aCN As ADODB.Connection)
                On Error GoTo Handler
540         Set mIData.Connection = aCN
                Exit Property
Handler:
560         Err.Raise Err.Number, Erl & " - Property set Connection - clsData - dlkData - " & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
               
               
End Property

Public Sub SaveSingleObject(aObject As Object)
590         mIData.SaveSingleObject aObject
End Sub

Public Sub CreateSingleObject(aObject As Object)
600         mIData.CreateSingleObject aObject
End Sub

Public Function ExecuteSQL(aSQL As String, Optional aPRMObject As Object = Nothing, Optional aCommandType As CommandTypeEnum = adCmdText) As Long
610         ExecuteSQL = mIData.ExecuteSQL(aSQL, aPRMObject, aCommandType)
End Function

Public Function ExecuteSP(aStoredProcedure As String, Optional aPRMObject As Object = Nothing) As Long
620         ExecuteSP = mIData.ExecuteSP(aStoredProcedure, aPRMObject)
End Function

Public Function OpenRecordsetSP(aStoredProcedure As String, Optional aPRMObject As Object = Nothing, Optional ByRef aReturnValueSP As Long = 0) As Recordset
630         Set OpenRecordsetSP = mIData.OpenRecordsetSP(aStoredProcedure, aPRMObject, aReturnValueSP)
End Function

Public Function OpenRecordsetSQL(aSQL As String, Optional aCursorType As CursorTypeEnum = adOpenStatic, Optional aCursorLocation As CursorLocationEnum = adUseClient, Optional aLockType As LockTypeEnum = adLockOptimistic) As Recordset
640         Set OpenRecordsetSQL = mIData.OpenRecordsetSQL(aSQL, aCursorType, aCursorLocation, aLockType)
End Function

Public Sub OpenConnection(Optional aDefaultCursorLocation As CursorLocationEnum = adUseClient)
650         mIData.OpenConnection aDefaultCursorLocation
End Sub

Public Sub CloseConnection()
660         mIData.CloseConnection
End Sub

Public Sub BeginTrans()
670         mIData.BeginTrans
End Sub

Public Sub CommitTrans()
680         mIData.CommitTrans
End Sub

Public Sub RollbackTrans()
690         mIData.RollbackTrans
End Sub

Public Property Get Errors() As ADODB.Errors
700         Set Errors = mIData.Errors
End Property
           
0
 
LVL 4

Expert Comment

by:vindevogel
ID: 6428791
Have fun studying it ..........
;-))
0
 
LVL 5

Expert Comment

by:rkot2000
ID: 6428993
0
 
LVL 15

Expert Comment

by:ameba
ID: 6429703
Thanks, vindevogel, nice example !!!

A bit too much delegation (hope there are no JAVA programmers looking here ;), but in VB6 we must use it a lot.
0
 
LVL 4

Expert Comment

by:vindevogel
ID: 6429796
ameba: yes, it's too much delegation, but untill the release of .net we'll have to do with this.  I'm looking forward to that release because this is (in my honest opinion) a very nice example of polymorphism and inheritance (instead of delegation).

I don't know if any Oracle 8 users are reading this, but I'd like to invite them to use this code and write the clsOracle8Data in the same way and share the code with all other experts.
0
 
LVL 15

Expert Comment

by:ameba
ID: 6430129
vindevogel,
> inheritance (instead of delegation).
I think so.

>I'd like to invite them to use this code and write the clsOracle8Data in the same way and share the code

That would be real "knowledge exchange", cool.  :-)

I use MDB only at this time, and I cannot help or test those big databases.
Maybe you can post a separate question in VB Databases topic area, to hear from real db experts.

It is also good idea to include small 'USAGE' section which calls some stored procedure with params.

(The small problem with code reuse in VB is - when you prepare/connect all pieces of code for reuse, it's - time for new version.)
0
 
LVL 5

Expert Comment

by:rkot2000
ID: 6432061
Nice example, but I it has tons of overhead. I used different approach. I developed an ActiveX dll(with 10 functions) to work with sql server and vb-addin to generate code (calls to the ActiveX Dll from bus tier)  base on database objects.
0
 
LVL 4

Expert Comment

by:vindevogel
ID: 6432723
rkot: My reason is this:
I call this datastuff from my business components, who are ActiveX dll's passing ADO to Active Server Pages.

We have these servers:
1) Spain: SQL 7 on NT 4
2) Holland: SQL 7 on NT 4
3) UK: SQL 2000 on W2K
4) Belgium: SQL 2000 on W2K

We "copy" servers, that is put the business components on each machine and register them.  With this mechanism I tell my component to look in "MyDB", where "MyDB" is later translated as a SQL 2K or SQL 7.

For the moment, I don't use Oracle.  But I know that UK and France will pass towards Oracle Financials.  With my DB object, I could go to Oracle, without having to recompile my business objects.  


Ameba:  We found out that, if we use the same names for properties of the objects, the parameters of the stored procudure and/or the fields in the database, you can simply use the object itself to pass, and loop through the parameters of the stored procedure eg.  This way you automatically have a "Fill out parameters" procedure.  That's the loop with the call by name.

What do you mean with a "Usage section" ?
Some sample code how to use a SP with this thing ?
0
 
LVL 15

Expert Comment

by:ameba
ID: 6433023
vindevogel,
>What do you mean with a "Usage section" ?

' Here is small sample how to use/call OpenRecordsetSP function:

' clsBDProduct
Option Explicit
Private m_dbh As DBHelper

Private Sub Class_Initialize()
    Set m_dbh = New FMStocks_DB.DBHelper
End Sub

Public Function FindByDescription(ByVal description As String) As ADODB.Recordset
    On Error GoTo errorHandler
   
    Set FindByDescription = m_dbh.RunSPReturnRS("Product_FindByDescription", _
        Array(mp("@Description", adVarChar, 255, description)))
    Exit Function
   
errorHandler:
    RaiseError m_modName, "FindByDescription"
End Function
0
 

Author Comment

by:markdot
ID: 6433293
Thanks for all experts.
0

Featured Post

IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

The debugging module of the VB 6 IDE can be accessed by way of the Debug menu item. That menu item can normally be found in the IDE's main menu line as shown in this picture.   There is also a companion Debug Toolbar that looks like the followin…
I was working on a PowerPoint add-in the other day and a client asked me "can you implement a feature which processes a chart when it's pasted into a slide from another deck?". It got me wondering how to hook into built-in ribbon events in Office.
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

747 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

13 Experts available now in Live!

Get 1:1 Help Now