markdot
asked on
Implements a class
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?
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?
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
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?
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?
>>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
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
ASKER
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?
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?
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)
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)
ASKER
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?
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?
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.CD
Early Binding:
Dim myDog As CDog
Set myDog = New CDog
Late Binding:
Dim myDog As Object
Set myDog = CreateObject("Component.CD
ASKER
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
'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
ASKER
Hi AzraSound,
Are these also Late Binding:
Dim myDog As Object
Set myDog = New CDog
----------
Dim myDog As IAnimal
Set myDog = New CDog
Are these also Late Binding:
Dim myDog As Object
Set myDog = New CDog
----------
Dim myDog As IAnimal
Set myDog = New CDog
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.
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.
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.CD
Early or Late Binding?
3.
Dim myDog As Object
Set myDog = New CDog
4.
Dim myDog As CDog
Set myDog = CreateObject("Component.CD
ASKER
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
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
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]
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]
ASKER
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.CD
1. Late, 2. Lage, 3. Late, 4. Early.
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.CD
1. Late, 2. Lage, 3. Late, 4. Early.
markdot,
Only one small mistake (2. Early) - you have good teacher(s) ;-)
Only one small mistake (2. Early) - you have good teacher(s) ;-)
ASKER
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:-)
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:-)
>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).
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).
ASKER
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.
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.
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
>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
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(New
Me.Caption = NewCaption
End Sub
'public function
Sub ChangeFormCaption(FormObje
Call FormObject.Caption(NewCapt
End Sub
'Interface class ICaption
Sub ChangeCaption(NewCaption As String)
End Sub
'Form1 & Form2
Implements ICaption
Private Sub ICaption_ChangeCaption(New
Me.Caption = NewCaption
End Sub
'public function
Sub ChangeFormCaption(FormObje
Call FormObject.Caption(NewCapt
End Sub
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
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
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
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
Methods, Properties, ... we also have Events, but VB doesn't allow implementing events :-(
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."
' 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."
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 ...
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 ...
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.
Interfaces can be very simple (few lines, or only one code line), but they often require more work than implementation.
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
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
End Function
Public Function OpenRecordsetSP(aStoredPro
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(
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("KEYCOLU
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_CreateSingleObjec
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(aStored
On Error GoTo Handler
clsIData_ExecuteSP = clsIData_ExecuteSQL(aStore
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.Er
vCmdSP.Execute
'YV
If Not vCmdSP.Parameters.Count = 0 Then
Parameters2Object aPRMObject, vCmdSP.Parameters
clsIData_ExecuteSQL = vCmdSP.Parameters("@RETURN
End If
Set vCmdSP = Nothing
Exit Function
Handler:
'YV
If vCmdSP.ActiveConnection.Er
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(a
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
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(
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.ActiveConnectio
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(Op
On Error GoTo Handler
If Not mConnection Is Nothing Then
mConnection.Close
Set mConnection = Nothing
End If
Set mConnection = New ADODB.Connection
mConnection.ConnectionStri
";Data Source=" & mServerName & _
";Initial Catalog=" & mCatalog & _
";User ID=sa;Password=;Persist Security Info=False"
mConnection.CursorLocation
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 = dlkDataTransactionInProgre
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(aPRMObje
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(aPRMObje
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(aR
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_CreateSingleOb
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.clsDalkiaRegis
80 Set mParent = aObject
100 Set vRegistry = New dlkRegistry.clsDalkiaRegis
120 vRegistry.AppName = "Objects\" & TypeName(aObject)
130 mDBMnemonic = vRegistry.GetMachineParame
150 vRegistry.AppName = "Databases\" & mDBMnemonic
160 mDBType = vRegistry.GetMachineParame
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.GetMachineParame
280 mIData.ServerName = vRegistry.GetMachineParame
290 mIData.Provider = vRegistry.GetMachineParame
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
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
620 ExecuteSP = mIData.ExecuteSP(aStoredPr
End Function
Public Function OpenRecordsetSP(aStoredPro
630 Set OpenRecordsetSP = mIData.OpenRecordsetSP(aSt
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(aS
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
********************
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
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
End Function
Public Function OpenRecordsetSP(aStoredPro
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(
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("KEYCOLU
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_CreateSingleObjec
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(aStored
On Error GoTo Handler
clsIData_ExecuteSP = clsIData_ExecuteSQL(aStore
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.Er
vCmdSP.Execute
'YV
If Not vCmdSP.Parameters.Count = 0 Then
Parameters2Object aPRMObject, vCmdSP.Parameters
clsIData_ExecuteSQL = vCmdSP.Parameters("@RETURN
End If
Set vCmdSP = Nothing
Exit Function
Handler:
'YV
If vCmdSP.ActiveConnection.Er
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(a
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
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(
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.ActiveConnectio
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(Op
On Error GoTo Handler
If Not mConnection Is Nothing Then
mConnection.Close
Set mConnection = Nothing
End If
Set mConnection = New ADODB.Connection
mConnection.ConnectionStri
";Data Source=" & mServerName & _
";Initial Catalog=" & mCatalog & _
";User ID=sa;Password=;Persist Security Info=False"
mConnection.CursorLocation
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 = dlkDataTransactionInProgre
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(aPRMObje
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(aPRMObje
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(aR
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_CreateSingleOb
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.clsDalkiaRegis
80 Set mParent = aObject
100 Set vRegistry = New dlkRegistry.clsDalkiaRegis
120 vRegistry.AppName = "Objects\" & TypeName(aObject)
130 mDBMnemonic = vRegistry.GetMachineParame
150 vRegistry.AppName = "Databases\" & mDBMnemonic
160 mDBType = vRegistry.GetMachineParame
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.GetMachineParame
280 mIData.ServerName = vRegistry.GetMachineParame
290 mIData.Provider = vRegistry.GetMachineParame
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
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
620 ExecuteSP = mIData.ExecuteSP(aStoredPr
End Function
Public Function OpenRecordsetSP(aStoredPro
630 Set OpenRecordsetSP = mIData.OpenRecordsetSP(aSt
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(aS
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
Have fun studying it ..........
;-))
;-))
Full info on binding :
http://support.microsoft.com/support/kb/articles/Q138/1/38.asp?LN=EN-US&SD=gn&FR=0&qry=implements&rnk=4&src=DHCS_MSPSS_gn_SRCH&SPR=VBB
problems with late binding and work around:
http://support.microsoft.com/support/kb/articles/Q188/7/16.ASP?LN=EN-US&SD=gn&FR=0&qry=implements&rnk=28&src=DHCS_MSPSS_gn_SRCH&SPR=VBB
http://support.microsoft.com/support/kb/articles/Q138/1/38.asp?LN=EN-US&SD=gn&FR=0&qry=implements&rnk=4&src=DHCS_MSPSS_gn_SRCH&SPR=VBB
problems with late binding and work around:
http://support.microsoft.com/support/kb/articles/Q188/7/16.ASP?LN=EN-US&SD=gn&FR=0&qry=implements&rnk=28&src=DHCS_MSPSS_gn_SRCH&SPR=VBB
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.
A bit too much delegation (hope there are no JAVA programmers looking here ;), but in VB6 we must use it a lot.
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.
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.
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.)
> 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.)
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.
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 ?
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 ?
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("Produ
Array(mp("@Description", adVarChar, 255, description)))
Exit Function
errorHandler:
RaiseError m_modName, "FindByDescription"
End Function
>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("Produ
Array(mp("@Description", adVarChar, 255, description)))
Exit Function
errorHandler:
RaiseError m_modName, "FindByDescription"
End Function
ASKER
Thanks for all experts.
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