Solved

Returning Recordset from a Active X DLL

Posted on 2001-06-09
7
236 Views
Last Modified: 2013-11-25
Is it possible to return a recordset from a DLL written in VB. If so then how and if not then is there any other alternative?


Best Regards.
Shehzad Munir.
0
Comment
Question by:ShehzadMunir
7 Comments
 
LVL 2

Expert Comment

by:kmv
ID: 6170492
Yes. Recordset is a object. You can return VARIANT type variable and on eof possible values type is Object. As a matter of fact you will return a pointer to COM-interface of Recordset object.
0
 

Author Comment

by:ShehzadMunir
ID: 6170553
Thanks for your response. Do you know some article available on the net with reference to the same query

Best Reagards
Shehzad Munir.
0
 
LVL 1

Expert Comment

by:MattC
ID: 6170823
you could declare the recordset as public in the dll and then access it direct from wherever you are calling the dll functions
0
What Security Threats Are You Missing?

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

 
LVL 3

Accepted Solution

by:
nigelrowe earned 10 total points
ID: 6171245
Its not really good practice to pass data objects about. It is more usual to have the DLL do the whole data business. Hence 'Business Objects'
0
 
LVL 3

Expert Comment

by:nigelrowe
ID: 6171272
For example, you create a class for each table in the database. The class contains all of the functions needed to manage the table. For example....
Create(ByVal primarykey As Long)..Returns an object representing the field values
CreateNew()..Returns an object with empty field values
UpdateDB()..Updates the DB depending on whether Create or CreateNew was called


Object oriented programming in other words
0
 

Author Comment

by:ShehzadMunir
ID: 6172715
Though I am accepting MattC answer for the time being I have got the solution. But nigelrowe you are right that there must be data abstraction. One must follow the rules of object oriented programing. I was wandering if on the net there is any such example available in which it has been shown how to map Database using classes.

Thanks for everybody answer.
Best Regards
Shehzad Munir.
0
 
LVL 3

Expert Comment

by:nigelrowe
ID: 6176253
Heres an example (I'm not suggesting that you do the same, just giving you an idea)of how I do it (this object is transactional in microsoft transaction server)...


'IMPORTANT: Only ONE role of a specific type for a given procedure !!!

'WARNING : Before using a method wich manages roles or/and players,
'          you must load the roles or/and players.
'Example : Before calling GetRole, GetPlayerInRole or GetNrPlayersInRole, you must call LoadRole.

'Remarks : To check if a role exists in the procedure, use LoadRole.
'          To get the numbers of roles in the procedure, use GetNrRolesInProcedure.


Option Base 1
Option Explicit


Private Enum OPER_STATUS
    OPER_ERROR = 0
    OPER_INIT = 1
    OPER_ADD = 2
    OPER_DEL = 3
End Enum

Private toupdate As Boolean
Private IdProc As Long
Private ProcType As Variant
Private mvarreference As Variant
Private mvardtapplication As Variant
Private mvardtacceptance As Variant
Private mvardtpublication As Variant
Private mvarprocstatus As Variant
Private mvarjournalnr As Variant
Private mvaramount As Variant
Private mvardtpaid As Variant
Private mvaroffincharge As Variant


Private AllPlayers As Collection
Private Roles As Collection

Private is_new As Boolean
Private CardinalityArray
Private CardinalityArrayNrItems As Integer

Const PRO_TYROLE_FILE = 9
Public Function CheckIntegrity() As Boolean
On Error GoTo ErrorHandler
Dim DB_Conn As New ADODB.Connection
Dim Rs As ADODB.Recordset
Dim cpt As Integer
Dim sqlclause As String
    'CheckState "CheckIntegrity"
    If Not IsArray(CardinalityArray) Then
        'array not already filled
        'retrieve cardinalities for the given kind of procedure
       
        sqlclause = "SELECT tyrole, typlayer, nbrole, nbplayer FROM procardinality WHERE typroc = " & SQLEncode(ProcType)
        DB_Conn.Open Env.GetConnectionString
        Set Rs = DB_Conn.Execute(sqlclause)
        If Rs.EOF Then
            Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "CheckIntegrity", "table definitions.procardinality is empty")
        End If
        Rs.MoveFirst
        cpt = 1
        While Not Rs.EOF
            If Not IsArray(CardinalityArray) Then
                ReDim CardinalityArray(4, cpt) As Integer
            Else
                'only the last dimension on the array can be redimensioned
                ReDim Preserve CardinalityArray(4, cpt)
            End If
            CardinalityArray(1, cpt) = SQLDecode(Rs.Fields("tyrole").Value)
            CardinalityArray(2, cpt) = SQLDecode(Rs.Fields("typlayer").Value)
            CardinalityArray(3, cpt) = SQLDecode(Rs.Fields("nbrole").Value)
            CardinalityArray(4, cpt) = SQLDecode(Rs.Fields("nbplayer").Value)
            cpt = cpt + 1
            Rs.MoveNext
        Wend
        CardinalityArrayNrItems = cpt - 1
        DB_Conn.Close
    End If
    'check cardinalities for each role
    For cpt = 1 To CardinalityArrayNrItems
        'check roles : roles may have cardinalities 0=[0,1] or 1=[1,1]
        ' as the type of role is a unique index in the roles collection,
        ' we do not check the case : more than one role of the same type
        ' in the collection
        'for this cardinality 1=[1,1], at least one role must exist
        If CardinalityArray(3, cpt) = 1 And Not ExistRole(CardinalityArray(1, cpt)) Then
            CheckIntegrity = False
            Exit Function
        Else
            If CardinalityArray(3, cpt) > 1 Then
                'role cannot have a cardinality [1,n] or [0,n]
                Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "CheckIntegrity", "Cardinality table is not correctly filled : tyrole=" _
                & CardinalityArray(1, cpt) & ",typlayer=" & CardinalityArray(2, cpt) & ",nbrole=" & CardinalityArray(3, cpt) & ",nbplayer=" & CardinalityArray(4, cpt) & " is not allowed")
            End If
        End If
        'check players : players may have cardinalities 0=[0,1],1=[1,1],2=[1,n],3=[0,n]
        'check cardinality 2=[1,n]
        If CardinalityArray(4, cpt) = 2 _
            And GetNrPlayersInRole(CardinalityArray(1, cpt)) = 0 Then
                CheckIntegrity = False
                Exit Function
        End If
        'if more or less than one player for a cardinality 1=[1,1], return false
        If CardinalityArray(4, cpt) = 1 Then
            If GetNrPlayersInRole(CardinalityArray(1, cpt)) = 0 Then
                CheckIntegrity = False
                Exit Function
            Else
                If GetNrPlayersInRole(CardinalityArray(1, cpt)) > 1 Then
                    CheckIntegrity = False
                    Exit Function
                End If
            End If
        End If
    Next
    CheckIntegrity = True
    Exit Function
ErrorHandler:
    CheckIntegrity = False
    Abort "CheckIntegrity"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "CheckIntegrity", Err.description)
End Function
Public Property Get NeedUpdate() As Boolean
On Error GoTo ErrorHandler
    NeedUpdate = toupdate
    Exit Property
ErrorHandler:
    Abort "Get NeedUpdate"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "Get NeedUpdate", Err.description)
End Property

Public Function GetVbClass() As String
On Error GoTo ErrorHandler
    GetVbClass = "Procedures.procedure"
    Exit Function
ErrorHandler:
    GetVbClass = "Procedures.procedure"
    Abort "GetVbClass"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "GetVbClass", Err.description)
End Function

Public Sub Create(ByVal an_environment As String, ByVal an_idproc As Long, Optional ByVal LoadAll As Boolean = True)
On Error GoTo ErrorHandler
Dim sqlclause As String
Dim Conn As New ADODB.Connection
Dim Proc_RS As ADODB.Recordset
Dim ProcType_RS As ADODB.Recordset
   
    LoadEnv an_environment
   
    If an_idproc <= 0 Then
        Err.Raise PtolemyFatal, Err.Source, "Invalid procedure number " & an_idproc
    End If
   
    sqlclause = "SELECT idproc, typroc, reference, dtapplication, dtacceptance, dtpublication, stproc, journalnr, amount, dtpaid, offincharge " & _
                " FROM ptoprocedure WHERE idproc=" & SQLEncode(an_idproc)
    Conn.Open Env.GetConnectionString
    Set Proc_RS = Conn.Execute(sqlclause)
    If Not Proc_RS.EOF Then
        IdProc = SQLDecode(Proc_RS.Fields("idproc").Value)
        ProcType = SQLDecode(Proc_RS.Fields("typroc").Value)
        reference = SQLDecode(Proc_RS.Fields("reference").Value)
        dtapplication = SQLDecode(Proc_RS.Fields("dtapplication").Value)
        dtacceptance = SQLDecode(Proc_RS.Fields("dtacceptance").Value)
        dtpublication = SQLDecode(Proc_RS.Fields("dtpublication").Value)
        stproc = SQLDecode(Proc_RS.Fields("stproc").Value)
        journalnr = SQLDecode(Proc_RS.Fields("journalnr").Value)
        amount = SQLDecode(Proc_RS.Fields("amount").Value)
        dtpaid = SQLDecode(Proc_RS.Fields("dtpaid").Value)
        offincharge = SQLDecode(Proc_RS.Fields("offincharge").Value)
    Else
        Err.Raise PtolemyFatal, Err.Source, "Cannot find procedure " & an_idproc
    End If
    Conn.Close
    is_new = False
    toupdate = False
    Set Roles = New Collection
    Set AllPlayers = New Collection
' SHT 17/10/00
'   LoadAllRoles
'   LoadAllPlayers
    If LoadAll Then
        LoadAllRoles
        LoadAllPlayers
    End If

    Exit Sub
ErrorHandler:
    Abort "Create"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "Create", Err.description)
End Sub

Public Sub CreateSpecificProcedure(ByVal an_environment As String, ByVal an_idproc As Long, ByVal ListRole As Variant)
On Error GoTo ErrorHandler
Dim sqlclause As String
Dim Conn As New ADODB.Connection
Dim Proc_RS As ADODB.Recordset
Dim DefinitionsDB_Conn As New ADODB.Connection
Dim ProcType_RS As ADODB.Recordset
   
    LoadEnv an_environment
   
    'object_status = OS_INITIALIZED
    If an_idproc <= 0 Then
        Err.Raise PtolemyFatal, Err.Source, "Invalid procedure number " & an_idproc
    End If
   
   
    sqlclause = "SELECT idproc, typroc, reference, dtapplication, dtacceptance, dtpublication, stproc, journalnr, amount, dtpaid, offincharge " & _
                " FROM ptoprocedure WHERE idproc=" & SQLEncode(an_idproc)
    Conn.Open Env.GetConnectionString
    Set Proc_RS = Conn.Execute(sqlclause)
    If Not Proc_RS.EOF Then
        IdProc = SQLDecode(Proc_RS.Fields("idproc").Value)
        ProcType = SQLDecode(Proc_RS.Fields("typroc").Value)
        reference = SQLDecode(Proc_RS.Fields("reference").Value)
        dtapplication = SQLDecode(Proc_RS.Fields("dtapplication").Value)
        dtacceptance = SQLDecode(Proc_RS.Fields("dtacceptance").Value)
        dtpublication = SQLDecode(Proc_RS.Fields("dtpublication").Value)
        stproc = SQLDecode(Proc_RS.Fields("stproc").Value)
        journalnr = SQLDecode(Proc_RS.Fields("journalnr").Value)
        amount = SQLDecode(Proc_RS.Fields("amount").Value)
        dtpaid = SQLDecode(Proc_RS.Fields("dtpaid").Value)
        offincharge = SQLDecode(Proc_RS.Fields("offincharge").Value)
    Else
        Err.Raise PtolemyFatal, Err.Source, "Cannot find procedure " & an_idproc
    End If
    Conn.Close
    is_new = False
    Set Roles = New Collection
    Set AllPlayers = New Collection

    Call LoadSpecificRoles(ListRole)

    LoadAllPlayers

    Exit Sub
ErrorHandler:
    Abort "CreateSpecificProcedure"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "CreateSpecificProcedure", Err.description)
End Sub

Public Sub CreateNew(ByVal an_environment As String, ByVal a_proctype As Integer)
On Error GoTo ErrorHandler
#If conComBindType = 1 Then
    Dim num As allotnum.numbersuser
#Else
    Dim num As Object
#End If
   
    LoadEnv an_environment
   
    'object_status = OS_INITIALIZED
    Set num = CreateObject("allotnum.numbersuser")
    IdProc = num.GetNextNumber(an_environment, "procedures", "ptoprocedure", "idproc")
    ProcType = a_proctype
    reference = Null
    dtapplication = Null
    dtacceptance = Null
    dtpublication = Null
    journalnr = Null
    stproc = Null
    amount = Null
    dtpaid = Null
    offincharge = Null
    is_new = True
    toupdate = False
    Set Roles = New Collection
    Set AllPlayers = New Collection
    Exit Sub
ErrorHandler:
    Abort "CreateNew"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "CreateNew", Err.description)
End Sub

Public Sub CreateCopy(ByVal an_environment As String, ByVal a_procedure As Procedures.Procedure)
On Error GoTo ErrorHandler
Dim i As Integer
Dim copy_role As Procedures.Role
Dim TabRole(0 To 1) As Variant
   
    LoadEnv an_environment
   
    'object_status = OS_INITIALIZED
    IdProc = a_procedure.GetIdproc
    ProcType = a_procedure.GetTyProc
    reference = a_procedure.reference
    dtapplication = a_procedure.dtapplication
    dtacceptance = a_procedure.dtacceptance
    dtpublication = a_procedure.dtpublication
    journalnr = a_procedure.journalnr
    amount = a_procedure.amount
    dtpaid = a_procedure.dtpaid
    stproc = a_procedure.stproc
    offincharge = a_procedure.offincharge
    is_new = a_procedure.IsNew
    Set Roles = New Collection
    Set AllPlayers = New Collection
    For i = 1 To a_procedure.AbsGetNrRoles
        Set copy_role = GetObjectContext.CreateInstance("Procedures.Role")
        Call copy_role.CreateCopy(an_environment, a_procedure.AbsGetRole(i), AllPlayers)
        Set TabRole(0) = copy_role
        TabRole(1) = a_procedure.AbsGetOper(i)
        Roles.Add TabRole, CStr(copy_role.GetType)
    Next
    toupdate = a_procedure.NeedUpdate
    Exit Sub
ErrorHandler:
    Abort "CreateCopy"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "CreateCopy", Err.description)
End Sub
Public Function IsNew() As Boolean
On Error GoTo ErrorHandler
    'CheckState "IsNew"
    IsNew = is_new
    Exit Function
ErrorHandler:
    IsNew = False
    Abort "IsNew"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "IsNew", Err.description)
End Function

' WARNING : Do not call this function if some roles are already loaded !!!

Public Sub LoadAllRoles()
On Error GoTo ErrorHandler
Dim sqlclause As String, i As Integer
Dim Conn As New ADODB.Connection
Dim Role_RS As ADODB.Recordset
Dim RoleType As Variant
Dim NewRole As Procedures.Role
Dim TabRole(0 To 1) As Variant
Dim Rolearray As Variant

    'CheckState "LoadAllRoles"
    If IdProc <= 0 Then
        Err.Raise PtolemyFatal, Err.Source, "Invalid procedure number " & IdProc
    End If
   
    sqlclause = "SELECT tyrole FROM role WHERE idproc=" & SQLEncode(IdProc)
    Conn.Open Env.GetConnectionString
    Set Role_RS = Conn.Execute(sqlclause)
    If Not Role_RS.EOF Then
        Rolearray = Role_RS.GetRows
        Conn.Close
        For i = LBound(Rolearray, 2) To UBound(Rolearray, 2)
            Rolearray(0, i) = SQLDecode(Rolearray(0, i))
            'MODIF JSM on site
            If Rolearray(0, i) <> PRO_TYROLE_FILE Then 'The FILE role is in the database but should be disregarded except by Backlog Scanning
               Set NewRole = GetObjectContext.CreateInstance("Procedures.Role")
               NewRole.Create SerialEnv, IdProc, Rolearray(0, i)
               Set TabRole(0) = NewRole
               TabRole(1) = OPER_INIT
               Roles.Add TabRole, CStr(Rolearray(0, i))
            End If
        Next
    Else
        Conn.Close
    End If
    Exit Sub
ErrorHandler:
    Abort "LoadAllRoles"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "LoadAllRoles", Err.description)
End Sub

Public Sub LoadSpecificRoles(ListRole)
On Error GoTo ErrorHandler
Dim sqlclause As String, i As Integer
Dim Conn As New ADODB.Connection
Dim Role_RS As ADODB.Recordset
Dim RoleType As Variant
Dim NewRole As Procedures.Role
Dim TabRole(0 To 1) As Variant
Dim tyrole_str As String
Dim Rolearray As Variant

    'CheckState "LoadSpecificRoles"
    If IdProc <= 0 Then
        Err.Raise PtolemyFatal, Err.Source, "Invalid procedure number " & IdProc
    End If
   
    tyrole_str = ListRole.Item(1)
    For i = 2 To ListRole.Count Step 1
       tyrole_str = tyrole_str & "," & ListRole.Item(i)
    Next
 
   
    sqlclause = "SELECT tyrole FROM role WHERE idproc=" & SQLEncode(IdProc) & " AND tyrole IN (" & tyrole_str & ")"
    Conn.Open Env.GetConnectionString
    Set Role_RS = Conn.Execute(sqlclause)
    If Not Role_RS.EOF Then
        Rolearray = Role_RS.GetRows
        Conn.Close
        For i = LBound(Rolearray, 2) To UBound(Rolearray, 2)
            Rolearray(0, i) = SQLDecode(Rolearray(0, i))
            Set NewRole = GetObjectContext.CreateInstance("Procedures.Role")
            NewRole.Create SerialEnv, IdProc, Rolearray(0, i)
            Set TabRole(0) = NewRole
            TabRole(1) = OPER_INIT
            Roles.Add TabRole, CStr(Rolearray(0, i))
        Next
    Else
        Conn.Close
    End If

    Exit Sub
ErrorHandler:
    Abort "LoadSpecificRoles"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "LoadSpecificRoles", Err.description)
End Sub

' WARNING : Do not call this function if some players are already loaded !!!

Public Sub LoadAllPlayers()
On Error GoTo ErrorHandler
Dim i As Integer
    'CheckState "LoadAllPlayers"
    For i = 1 To AbsGetNrRoles
        Call AbsGetRole(i).LoadPlayers(AllPlayers)
    Next
    Exit Sub
ErrorHandler:
    Abort "LoadAllPlayers"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "LoadAllPlayers", Err.description)
End Sub
 
Public Sub AddRole(ByVal role_type As Integer)
On Error GoTo ErrorHandler
Dim NewRole As Procedures.Role
Dim TabRole(0 To 1) As Variant
    'CheckState "AddRole"
    If ExistRole(role_type) Then
        Err.Raise PtolemyFatal, Err.Source, "Role of type " & role_type & " already exists."
    Else
        If AbsExistRole(role_type) Then
            Set TabRole(0) = Roles.Item(CStr(role_type))(0)
            TabRole(1) = OPER_INIT
            Roles.Remove CStr(role_type)
            Roles.Add TabRole, CStr(role_type)
        Else
            Set NewRole = GetObjectContext.CreateInstance("procedures.role")
            NewRole.CreateNew SerialEnv, IdProc, role_type
            Set TabRole(0) = NewRole
            TabRole(1) = OPER_ADD
            Roles.Add TabRole, CStr(role_type)
        End If
    End If
    Exit Sub
ErrorHandler:
    Abort "AddRole"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "AddRole", Err.description)
End Sub

Public Sub AddPlayerInRole(ByVal role_type As Integer, ByVal a_player As Object)
On Error GoTo ErrorHandler
    'CheckState "AddPlayerInRole"
    If Not ExistRole(role_type) Then
        Err.Raise PtolemyFatal, Err.Source, "Role of type " & role_type & " does not exists."
    Else
        Call GetRole(role_type).AddPlayer(a_player, AllPlayers)
    End If
    Exit Sub
ErrorHandler:
    Abort "AddPlayerInRole"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "AddPlayerInRole", Err.description)
End Sub

Public Function GetNrPlayersInRole(ByVal role_type As Integer) As Long
On Error GoTo ErrorHandler
    'CheckState "GetNrPlayersInRole"
    If Not ExistRole(role_type) Then
        Err.Raise PtolemyFatal, Err.Source, "Role of type " & role_type & " does not exists."
    Else
        GetNrPlayersInRole = GetRole(role_type).GetNrPlayers
    End If
    Exit Function
ErrorHandler:
    GetNrPlayersInRole = 0
    Abort "GetNrPlayersInRole"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "GetNrPlayersInRole", Err.description)
End Function

' WARNING !!! This function only returns the number of LOADED roles.
' To get the real number of roles in the procedure, use GetNrRolesInProcedure.
Public Function GetNrRoles() As Long
On Error GoTo ErrorHandler
Dim cpt As Long
Dim i As Integer
    'CheckState "GetNrRoles"
    cpt = 0
    For i = 1 To AbsGetNrRoles
        If AbsGetOper(i) <> OPER_DEL Then
            cpt = cpt + 1
        End If
    Next
    GetNrRoles = cpt
    Exit Function
ErrorHandler:
    GetNrRoles = 0
    Abort "GetNrRoles"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "GetNrRoles", Err.description)
End Function

Public Function GetRole(ByVal role_type As Integer) As Procedures.Role
On Error GoTo ErrorHandler
    'CheckState "GetRole"
    If ExistRole(role_type) Then
        Set GetRole = Roles.Item(CStr(role_type))(0)
    Else
        Set GetRole = Nothing
    End If
    Exit Function
ErrorHandler:
    Set GetRole = Nothing
    Abort "GetRole"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "GetRole", Err.description)
End Function

Public Function GetOper(ByVal role_type As Integer) As Integer
On Error GoTo ErrorHandler
    'CheckState "GetOper"
    If ExistRole(role_type) Then
        GetOper = Roles.Item(CStr(role_type))(1)
    Else
        GetOper = OPER_ERROR
    End If
    Exit Function
ErrorHandler:
    GetOper = OPER_ERROR
    Abort "GetOper"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "GetOper", Err.description)
End Function

Public Function GetPlayerInRole(ByVal role_type As Integer, ByVal index_player As Integer) As Object
On Error GoTo ErrorHandler
    'CheckState "GetPlayerInRole"
    If ExistRole(role_type) Then
        Set GetPlayerInRole = GetRole(role_type).GetPlayer(index_player)
    Else
        Set GetPlayerInRole = Nothing
    End If
    Exit Function
ErrorHandler:
    Set GetPlayerInRole = Nothing
    Abort "GetPlayerInRole"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "GetPlayerInRole", Err.description)
End Function

Public Sub RemoveRole(ByVal role_type As Integer)
On Error GoTo ErrorHandler
Dim TabRole(0 To 1) As Variant
    'CheckState "RemovePlayer"
    If GetNrPlayersInRole(role_type) > 0 Then
        Err.Raise PtolemyFatal, Err.Source, "Role of type " & role_type & " have players."
    End If
    If GetOper(role_type) = OPER_ADD Then
        GetRole(role_type).Destroy
        Roles.Remove CStr(role_type)
    Else
        Set TabRole(0) = GetRole(role_type)
        TabRole(1) = OPER_DEL
        Roles.Remove CStr(role_type)
        Roles.Add TabRole, CStr(role_type)
    End If
    Exit Sub
ErrorHandler:
    Abort "RemoveRole"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "RemoveRole", Err.description)
End Sub

Public Sub ModifyPlayerInRole(ByVal role_type As Integer, ByVal player_index As Integer, ByVal a_player As Object)
On Error GoTo ErrorHandler
Dim ARole As Procedures.Role
    'CheckState "ModifyPlayerInRole"
    If Not ExistRole(role_type) Then
        Err.Raise PtolemyFatal, Err.Source, "Role of type " & role_type & " does not exists."
    Else
        Call GetRole(role_type).ModifyPlayer(player_index, a_player, AllPlayers)
    End If
    Exit Sub
ErrorHandler:
    Abort "ModifyPlayerInRole"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "ModifyPlayerInRole", Err.description)
End Sub

Public Sub RemovePlayerInRole(ByVal role_type As Integer, ByVal player_index As Integer)
On Error GoTo ErrorHandler
Dim ARole As Procedures.Role
    'CheckState "RemovePlayerInRole"
    If Not ExistRole(role_type) Then
        Err.Raise PtolemyFatal, Err.Source, "Role of type " & role_type & " does not exists."
    Else
        Call GetRole(role_type).RemovePlayer(player_index, AllPlayers)
    End If
    Exit Sub
ErrorHandler:
    Abort "RemovePlayerInRole"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "RemovePlayerInRole", Err.description)
End Sub

Public Sub UpdateDB()
On Error GoTo ErrorHandler
Dim Conn As New ADODB.Connection
Dim sqlclause As String
Dim Rs As ADODB.Recordset
Dim i As Integer
    'CheckState "UpdateDB"
   
    If is_new = True Then
        sqlclause = "INSERT INTO ptoprocedure (idproc, typroc, reference, dtapplication, dtacceptance, dtpublication, stproc, journalnr, amount, dtpaid, offincharge) VALUES ( " & _
                    SQLEncode(IdProc) & ", " & SQLEncode(ProcType) & ", " & _
                    SQLEncode(reference) & ", TO_DATE(" & SQLEncode(dtapplication) & ",'DD/MM/YYYY'), TO_DATE(" & _
                    SQLEncode(dtacceptance) & ",'DD/MM/YYYY'), TO_DATE(" & SQLEncode(dtpublication) & ",'DD/MM/YYYY'), " & _
                    SQLEncode(stproc) & ", " & SQLEncode(journalnr) & ", " & _
                    SQLEncode(amount) & ", TO_DATE(" & SQLEncode(dtpaid) & ", 'DD/MM/YYYY'), " & _
                    SQLEncode(offincharge) & ")"
        Conn.Open Env.GetConnectionString
        Conn.Execute sqlclause
        Conn.Close
    Else
        'update procedure items
        If toupdate = True Then
            sqlclause = "UPDATE ptoprocedure SET " & "reference = " & SQLEncode(reference) & ", " & _
                        "dtapplication = TO_DATE(" & SQLEncode(dtapplication) & ", 'DD/MM/YYYY'), " & _
                        "dtacceptance = TO_DATE(" & SQLEncode(dtacceptance) & ", 'DD/MM/YYYY'), " & _
                        "dtpublication = TO_DATE(" & SQLEncode(dtpublication) & ", 'DD/MM/YYYY'), " & _
                        "journalnr = " & SQLEncode(journalnr) & ", " & _
                        "amount = " & SQLEncode(amount) & ", " & _
                        "stproc = " & SQLEncode(stproc) & ", " & _
                        "dtpaid = TO_DATE(" & SQLEncode(dtpaid) & ", 'DD/MM/YYYY'), " & _
                        "offincharge = " & SQLEncode(offincharge) & _
                        " WHERE idproc= " & IdProc
            Conn.Open Env.GetConnectionString
            Conn.Execute sqlclause
            Conn.Close
        End If
    End If
   
    UpdatePlayersDB
    UpdateRolesDB
    is_new = False
    Exit Sub
ErrorHandler:
    Abort "UpdateDB"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "UpdateDB", Err.description)
End Sub

Public Sub UpdateRolesDB()
On Error GoTo ErrorHandler
Dim i As Integer
    'CheckState "UpdateRolesDB"
    For i = 1 To AbsGetNrRoles
        If AbsGetOper(i) = OPER_DEL Then
            AbsGetRole(i).DeleteDB
        Else
            AbsGetRole(i).UpdateDB
        End If
    Next
    Exit Sub
ErrorHandler:
    Abort "UpdateRolesDB"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "UpdateRolesDB", Err.description)
End Sub

Public Sub UpdatePlayersDB()
On Error GoTo ErrorHandler
Dim i As Integer
    'CheckState "UpdatePlayersDB"
    For i = 1 To AbsGetNrRoles
        Call AbsGetRole(i).UpdatePlayersDB(AllPlayers)
    Next
    Exit Sub
ErrorHandler:
    Abort "UpdatePlayersDB"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "UpdatePlayersDB", Err.description)
End Sub

Public Sub DeleteDB()
On Error GoTo ErrorHandler
Dim i As Integer
Dim Conn As New ADODB.Connection
Dim sqlclause As String
    'CheckState "DeleteDB"
    For i = 1 To AbsGetNrRoles
        AbsGetRole(i).DeleteDB
    Next
   
    sqlclause = "DELETE FROM ptoprocedure WHERE idproc=" & SQLEncode(IdProc)
    Conn.Open Env.GetConnectionString
    Conn.Execute sqlclause
    Conn.Close
    Exit Sub
ErrorHandler:
    Abort "DeleteDB"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "DeleteDB", Err.description)
End Sub

Private Sub Abort(ByVal method_name As String)
    GetObjectContext.SetAbort
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), method_name, Err.description)
End Sub

Public Sub Destroy()
On Error GoTo ErrorHandler
    ClearAllPlayers
    ClearAllRoles

    GetObjectContext.SetComplete
    Exit Sub
ErrorHandler:
    Abort "Destroy"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "Destroy", Err.description)
End Sub

Public Sub ClearAllRoles()
On Error GoTo ErrorHandler
Dim i As Integer
    'CheckState "ClearAllRoles"
    For i = 1 To AbsGetNrRoles
        AbsGetRole(1).Destroy
        Roles.Remove 1
    Next
    Set Roles = Nothing
    Exit Sub
ErrorHandler:
    Abort "ClearAllRoles"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "ClearAllRoles", Err.description)
End Sub

Public Sub ClearAllPlayers()
On Error GoTo ErrorHandler
Dim i As Integer
    'CheckState "ClearAllPlayers"
    For i = 1 To AbsGetNrRoles
        Call AbsGetRole(i).ClearPlayers(AllPlayers)
   Next
    For i = 1 To AllPlayers.Count
        AllPlayers.Remove 1
    Next
    Set AllPlayers = Nothing
    Exit Sub
ErrorHandler:
    Abort "ClearAllPlayers"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "ClearAllPlayers", Err.description)
End Sub

Public Function GetId() As Long
On Error GoTo ErrorHandler
    'CheckState "GetId"
    GetId = IdProc
    Exit Function
ErrorHandler:
    GetId = 0
    Abort "GetId"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "GetId", Err.description)
End Function

Public Function IsEqualTo(ByVal a_procedure As Procedures.Procedure) As Boolean
On Error GoTo ErrorHandler
Dim i As Integer
    'CheckState "IsEqualTo"
    If ProcType <> a_procedure.GetTyProc Or stproc <> a_procedure.stproc Then
        IsEqualTo = False
        Exit Function
    End If
    If reference <> a_procedure.reference Then
        IsEqualTo = False
        Exit Function
    End If
    If dtapplication <> a_procedure.dtapplication Or _
       dtacceptance <> a_procedure.dtacceptance Or _
       dtpublication <> a_procedure.dtpublication Or _
       offincharge <> a_procedure.offincharge Or _
       journalnr <> a_procedure.journalnr Then
        IsEqualTo = False
        Exit Function
    End If
    If AbsGetNrRoles <> a_procedure.AbsGetNrRoles Then
        IsEqualTo = False
        Exit Function
    End If
    For i = 1 To AbsGetNrRoles
        If Not AbsGetRole(i).IsEqualTo(a_procedure.AbsGetRole(i)) Or AbsGetOper(i) <> a_procedure.AbsGetOper(i) Then
            IsEqualTo = False
            Exit Function
        End If
    Next
    IsEqualTo = True
    Exit Function
ErrorHandler:
    IsEqualTo = False
    Abort "IsEqualTo"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "IsEqualTo", Err.description)
End Function

Public Function IsStrictlyEqualTo(ByVal a_procedure As Procedures.Procedure) As Boolean
On Error GoTo ErrorHandler
    'CheckState "IsStrictlyEqualTo"
    If IdProc = a_procedure.GetIdproc And IsEqualTo(a_procedure) Then
        IsStrictlyEqualTo = True
        Exit Function
    End If
    IsStrictlyEqualTo = False
    Exit Function
ErrorHandler:
    IsStrictlyEqualTo = False
    Abort "IsStrictlyEqualTo"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "IsStrictlyEqualTo", Err.description)
End Function

Public Sub NewId()
On Error GoTo ErrorHandler
#If conComBindType = 1 Then
    Dim num As allotnum.numbersuser
#Else
    Dim num As Object
#End If
Dim i As Integer
    Set num = CreateObject("allotnum.numbersuser")
    IdProc = num.GetNextNumber(SerialEnv, "procedures", "ptoprocedure", "idproc")
    For i = 1 To AbsGetNrRoles
        Call AbsGetRole(i).SetIdProc(IdProc)
        Call AbsGetRole(i).NewId
    Next
    is_new = True
    Exit Sub
ErrorHandler:
    Abort "NewId"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "NewId", Err.description)
End Sub

Public Sub SetTyProc(ByVal typroc As Integer)
On Error GoTo ErrorHandler
    'CheckState "SetTyProc"
    ProcType = typroc
    Exit Sub
ErrorHandler:
    Abort "SetTyProc"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "SetTyProc", Err.description)
End Sub
Public Function GetIdproc() As Long
On Error GoTo ErrorHandler
    'CheckState "GetIdproc"
    GetIdproc = IdProc
    Exit Function
ErrorHandler:
    GetIdproc = Null
    Abort "GetIdproc"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "GetIdproc", Err.description)
End Function

Public Property Get stproc() As Variant
On Error GoTo ErrorHandler
    'CheckState "Get stproc"
    stproc = mvarprocstatus
    Exit Property
ErrorHandler:
    stproc = Null
    Abort "Get stproc"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "Get stproc", Err.description)
End Property

Public Property Let stproc(ByVal vData As Variant)
On Error GoTo ErrorHandler
    'CheckState "Let stproc"
    If mvarprocstatus <> vData Then
        toupdate = True
    End If
    mvarprocstatus = vData
    Exit Property
ErrorHandler:
    Abort "Let stproc"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "Let stproc", Err.description)
End Property

Public Property Get journalnr() As Variant
On Error GoTo ErrorHandler
    'CheckState "Get journalnr"
    journalnr = mvarjournalnr
    Exit Property
ErrorHandler:
    journalnr = Null
    Abort "Get journalnr"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "Get journalnr", Err.description)
End Property

Public Property Let journalnr(ByVal vData As Variant)
On Error GoTo ErrorHandler
    'CheckState "Let journalnr"
    If mvarjournalnr <> vData Then
        toupdate = True
    End If
    mvarjournalnr = vData
    Exit Property
ErrorHandler:
    Abort "Let journalnr"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "Let journalnr", Err.description)
End Property

Public Property Get reference() As Variant
On Error GoTo ErrorHandler
    'CheckState "Get reference"
    reference = mvarreference
    Exit Property
ErrorHandler:
    reference = Null
    Abort "Get reference"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "Get reference", Err.description)
End Property

Public Property Let reference(ByVal vData As Variant)
On Error GoTo ErrorHandler
    'CheckState "Let reference"
    If mvarreference <> vData Then
        toupdate = True
    End If
    mvarreference = vData
    Exit Property
ErrorHandler:
    Abort "Let reference"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "Let reference", Err.description)
End Property

Public Property Get offincharge() As Variant
On Error GoTo ErrorHandler
    'CheckState "Get offincharge"
    offincharge = mvaroffincharge
    Exit Property
ErrorHandler:
    offincharge = Null
    Abort "Get offincharge"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "Get offincharge", Err.description)
End Property

Public Property Let offincharge(ByVal vData As Variant)
On Error GoTo ErrorHandler
    'CheckState "Let offincharge"
    If mvaroffincharge <> vData Then
        toupdate = True
    End If
    mvaroffincharge = vData
    Exit Property
ErrorHandler:
    Abort "Let offincharge"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "Let offincharge", Err.description)
End Property
Public Property Get dtapplication() As Variant
On Error GoTo ErrorHandler
    'CheckState "Get dtapplication"
    dtapplication = mvardtapplication
    Exit Property
ErrorHandler:
    dtapplication = Null
    Abort "Get dtapplication"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "Get dtapplication", Err.description)
End Property

Public Property Let dtapplication(ByVal vData As Variant)
On Error GoTo ErrorHandler
    'CheckState "Set dtapplication"
    If mvardtapplication <> vData Then
        toupdate = True
    End If
    mvardtapplication = vData
    Exit Property
ErrorHandler:
    Abort "Set dtapplication"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "Set dtapplication", Err.description)
End Property

Public Property Get dtacceptance() As Variant
On Error GoTo ErrorHandler
    'CheckState "Get dtacceptance"
    dtacceptance = mvardtacceptance
    Exit Property
ErrorHandler:
    dtacceptance = Null
    Abort "Get dtacceptance"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "Get dtacceptance", Err.description)
End Property

Public Property Let dtacceptance(ByVal vData As Variant)
On Error GoTo ErrorHandler
    'CheckState "Set dtacceptance"
    If mvardtacceptance <> vData Then
        toupdate = True
    End If
    mvardtacceptance = vData
    Exit Property
ErrorHandler:
    Abort "Set dtacceptance"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "Set dtacceptance", Err.description)
End Property

Public Property Get dtpublication() As Variant
On Error GoTo ErrorHandler
    'CheckState "Get dtpublication"
    dtpublication = mvardtpublication
    Exit Property
ErrorHandler:
    dtpublication = Null
    Abort "Get dtpublication"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "Get dtpublication", Err.description)
End Property

Public Property Let dtpublication(ByVal vData As Variant)
On Error GoTo ErrorHandler
    'CheckState "Set dtpublication"
    If mvardtpublication <> vData Then
        toupdate = True
    End If
    mvardtpublication = vData
    Exit Property
ErrorHandler:
    Abort "Set dtpublication"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "Set dtpublication", Err.description)
End Property

Public Property Get amount() As Variant
On Error GoTo ErrorHandler
    'CheckState "Get amount"
    amount = mvaramount
    Exit Property
ErrorHandler:
    amount = Null
    Abort "Get amount"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "Get amount", Err.description)
End Property

Public Property Let amount(ByVal vData As Variant)
On Error GoTo ErrorHandler
    'CheckState "Set amount"
    If mvaramount <> vData Then
        toupdate = True
    End If
    mvaramount = vData
    Exit Property
ErrorHandler:
    Abort "Set amount"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "Set amount", Err.description)
End Property

Public Property Get dtpaid() As Variant
On Error GoTo ErrorHandler
    'CheckState "Get dtpaid"
    dtpaid = mvardtpaid
    Exit Property
ErrorHandler:
    dtpaid = Null
    Abort "Get dtpaid"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "Get dtpaid", Err.description)
End Property

Public Property Let dtpaid(ByVal vData As Variant)
On Error GoTo ErrorHandler
    'CheckState "Set dtpaid"
    If mvardtpaid <> vData Then
        toupdate = True
    End If
    mvardtpaid = vData
    Exit Property
ErrorHandler:
    Abort "Set dtpaid"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "Set dtpaid", Err.description)
End Property

Public Function GetTyProc() As Variant
On Error GoTo ErrorHandler
    'CheckState "GetTyProc"
    GetTyProc = ProcType
    Exit Function
ErrorHandler:
    GetTyProc = Null
    Abort "GetTyProc"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "GetTyProc", Err.description)
End Function

Public Function GetLabelProc() As String
On Error GoTo ErrorHandler
Dim DefinitionsDB_Conn As New ADODB.Connection
Dim sqlclause As String
Dim Def_RS As ADODB.Recordset
    'CheckState "GetLabelProc"
   
    sqlclause = "SELECT nmproc FROM proproctype WHERE typroc=" & SQLEncode(ProcType)
    DefinitionsDB_Conn.Open Env.GetConnectionString
    Set Def_RS = DefinitionsDB_Conn.Execute(sqlclause)
    If Not Def_RS.EOF Then
        GetLabelProc = SQLDecode(Def_RS.Fields("nmproc").Value)
    Else
        GetLabelProc = ""
    End If
    DefinitionsDB_Conn.Close
    Exit Function
ErrorHandler:
    GetLabelProc = ""
    Abort "GetLabelProc"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "GetLabelProc", Err.description)
End Function

Public Function ExistRole(ByVal role_type As Integer) As Boolean
On Error GoTo ErrorHandler
Dim i As Integer
    'CheckState "ExistRole"
    For i = 1 To AbsGetNrRoles
        If AbsGetRole(i).GetType = role_type And AbsGetOper(i) <> OPER_DEL Then
            ExistRole = True
            Exit Function
        End If
    Next
    ExistRole = False
    Exit Function
ErrorHandler:
    ExistRole = False
    Abort "ExistRole"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "ExistRole", Err.description)
End Function

Public Function AbsExistRole(ByVal role_type As Integer) As Boolean
On Error GoTo ErrorHandler
Dim i As Integer
    'CheckState "AbsExistRole"
    For i = 1 To AbsGetNrRoles
        If AbsGetRole(i).GetType = role_type Then
            AbsExistRole = True
            Exit Function
        End If
    Next
    AbsExistRole = False
    Exit Function
ErrorHandler:
    AbsExistRole = False
    Abort "AbsExistRole"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "AbsExistRole", Err.description)
End Function

Public Function ExistPlayerInRole(ByVal role_type As Integer, ByVal an_idplayer As Long) As Boolean
On Error GoTo ErrorHandler
Dim i As Integer
    'CheckState "ExistPlayerInRole"
    If Not ExistRole(role_type) Then
        Err.Raise PtolemyFatal, Err.Source, "Role of type " & role_type & " does not exists."
    Else
        ExistPlayerInRole = GetRole(role_type).ExistPlayer(an_idplayer)
    End If
    Exit Function
ErrorHandler:
    ExistPlayerInRole = False
    Abort "ExistPlayerInRole"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "ExistPlayerInRole", Err.description)
End Function

Public Sub DescribeProcedure()
On Error GoTo ErrorHandler
Dim i As Integer
Dim j As Integer
Dim description As String
    'CheckState "DescribeProcedure"
    description = "No.: " & GetIdproc & Chr(10) & Chr(13)
    description = description & "Type: " & GetTyProc & Chr(10) & Chr(13)
    description = description & "Reference: " & reference & Chr(10) & Chr(13)
    description = description & "Date of application: " & dtapplication & Chr(10) & Chr(13)
    description = description & "Date of acceptance: " & dtacceptance & Chr(10) & Chr(13)
    description = description & "Date of publication: " & dtpublication & Chr(10) & Chr(13)
    description = description & "Status: " & stproc & Chr(10) & Chr(13)
    description = description & "Offincharge: " & offincharge & Chr(10) & Chr(13)
    description = description & "Journal No.: " & journalnr & Chr(10) & Chr(13)
    For i = 1 To AbsGetNrRoles
        description = description & "- Role Type: " & AbsGetRole(i).GetType & ", " & AbsGetOper(i) & Chr(10) & Chr(13)
        For j = 1 To AbsGetRole(i).AbsGetNrPlayers
            description = description & ". Player " & j & " : " & AbsGetRole(i).AbsGetPlayer(j).GetId & ", " & AbsGetRole(i).AbsGetPlayer(j).GetVbClass & ", " & AbsGetRole(i).AbsGetOper(j) & Chr(10) & Chr(13)
        Next
    Next
    Exit Sub
ErrorHandler:
    Abort "DescribeProcedure"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "DescribeProcedure", Err.description)
End Sub

Public Sub DescribeAllPlayers()
On Error GoTo ErrorHandler
Dim i As Integer
Dim description As String
    'CheckState "DescribeAllPlayers"
    For i = 1 To AllPlayers.Count
        description = description & _
            "- Player Type: " & AllPlayers.Item(i)(0) & _
            "- Player No.: " & AllPlayers.Item(i)(1) & _
            "- Player not updated: " & AllPlayers.Item(i)(3) & _
            "- Player not destroyed: " & AllPlayers.Item(i)(4) & _
            Chr(10) & Chr(13)
    Next
   
    Exit Sub
ErrorHandler:
    Abort "DescribeAllPlayers"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "DescribeAllPlayers", Err.description)
End Sub

Public Function AbsGetNrRoles() As Long
On Error GoTo ErrorHandler
    'CheckState "AbsGetNrRoles"
    AbsGetNrRoles = Roles.Count
    Exit Function
ErrorHandler:
    AbsGetNrRoles = 0
    Abort "AbsGetNrRoles"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "AbsGetNrRoles", Err.description)
End Function

Public Function AbsGetRole(ByVal absolute_index As Integer) As Role
On Error GoTo ErrorHandler
    'CheckState "AbsGetRole"
    Set AbsGetRole = Roles.Item(absolute_index)(0)
    Exit Function
ErrorHandler:
    Set AbsGetRole = Nothing
    Abort "AbsGetRole"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "AbsGetRole", Err.description)
End Function

Public Function AbsGetOper(ByVal absolute_index As Integer) As Integer
On Error GoTo ErrorHandler
    'CheckState "AbsGetOper"
    AbsGetOper = Roles.Item(absolute_index)(1)
    Exit Function
ErrorHandler:
    AbsGetOper = OPER_ERROR
    Abort "AbsGetOper"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "AbsGetOper", Err.description)
End Function

Public Sub ResetPlayersInRole(ByVal role_type As Integer)
On Error GoTo ErrorHandler
    'CheckState "ResetPlayersInRole"
    If Not ExistRole(role_type) Then
        Err.Raise PtolemyFatal, Err.Source, "Role of type " & role_type & " does not exists."
    Else
        Call GetRole(role_type).ResetPlayers(AllPlayers)
    End If
    Exit Sub
ErrorHandler:
    Abort "ResetPlayersInRole"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "ResetPlayersInRole", Err.description)
End Sub

' This function loads the specified role and all its players
' You can call it several times...

Public Sub LoadRole(ByVal RoleType As Variant, Optional ByRef IsRoleExist As Boolean)
On Error GoTo ErrorHandler
Dim sqlclause As String
Dim Conn As New ADODB.Connection
Dim Role_RS As ADODB.Recordset
Dim NewRole As Procedures.Role
Dim TabRole(0 To 1) As Variant
   
    IsRoleExist = False
    'CheckState "LoadRole"
    If IdProc <= 0 Then
        Err.Raise PtolemyFatal, Err.Source, "Invalid procedure number " & IdProc
    End If
    If GetRole(RoleType) Is Nothing Then
        ' The role is not already loaded
        sqlclause = "SELECT tyrole FROM role WHERE idproc=" & SQLEncode(IdProc) & " AND tyrole=" & SQLEncode(RoleType)
        Conn.Open Env.GetConnectionString
        Set Role_RS = Conn.Execute(sqlclause)
        If Not Role_RS.EOF Then
            IsRoleExist = True
            RoleType = SQLDecode(Role_RS.Fields("tyrole").Value)
            Conn.Close
            Set NewRole = GetObjectContext.CreateInstance("Procedures.Role")
            NewRole.Create SerialEnv, IdProc, RoleType
            Set TabRole(0) = NewRole
            TabRole(1) = OPER_INIT
            Roles.Add TabRole, CStr(RoleType)
            Call GetRole(RoleType).LoadPlayers(AllPlayers)
        End If
    Else
        ' The role is already loaded
        IsRoleExist = True
    End If
    Exit Sub
ErrorHandler:
    Abort "LoadRole"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "LoadRole", Err.description & " " & sqlclause)
End Sub

' This function returns the total number of roles in the procedure, not only the loaded roles.
' This function executes each time a request in the database.
Public Function GetNrRolesInProcedure() As Long

On Error GoTo ErrorHandler
Dim sqlclause As String
Dim Conn As New ADODB.Connection
Dim NbRole_RS As ADODB.Recordset

    'CheckState "GetNrRolesInProcedure"
    If IdProc <= 0 Then
        Err.Raise PtolemyFatal, Err.Source, "Invalid procedure number " & IdProc
    End If
   
    sqlclause = "SELECT COUNT(*) FROM role WHERE idproc=" & SQLEncode(IdProc)
    Conn.Open Env.GetConnectionString
    Set NbRole_RS = Conn.Execute(sqlclause)
    GetNrRolesInProcedure = SQLDecode(NbRole_RS.Fields(0).Value)
    Conn.Close
    Exit Function

ErrorHandler:
    Abort "GetNrRolesInProcedure"
    Err.Raise Err.Number, Err.Source, RTErrDescription(TypeName(Me), "GetNrRolesInProcedure", Err.description)

End Function



0

Featured Post

Top 6 Sources for Identifying Threat Actor TTPs

Understanding your enemy is essential. These six sources will help you identify the most popular threat actor tactics, techniques, and procedures (TTPs).

Join & Write a Comment

Suggested Solutions

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…
Have you ever wanted to restrict the users input in a textbox to numbers, and while doing that make sure that they can't 'cheat' by pasting in non-numeric text? Of course you can do that with code you write yourself but it's tedious and error-prone …
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 is Part 3 in a 3-part series on Experts Exchange to discuss error handling in VBA code written for Excel. Part 1 of this series discussed basic error handling code using VBA. http://www.experts-exchange.com/videos/1478/Excel-Error-Handlin…

760 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

18 Experts available now in Live!

Get 1:1 Help Now