¡Nuevo sistema de party! (con porcentajes etc etc)

Option Explicit
 
'Designed and Implemented by maTih.-
 
'###########################################################'#
'#                                                          '#
'#              CAUTION - WARNING    - CARE              '#
'#            PRECAUCION - ADVERTENCIA - CUIDADO            '#
'#                                                          '#
'#          NEVER GO FROM 1 TO newParty().PartyMembers!!!  '#
'#          NUNCA IR DE  1 TO NewParty().PartyMembers!!!  '#
'#                                                          '#
'###########################################################'#
 
'Maximum number of users at a party.
Public Const NP_MAX_MEMBERS    As Integer = 5
 
'MODO LIDERES : Se usa para elegir si al deslogear el lider
'              Se elige otro usuario como lider
'              O se cierra la party.
'              1 = CIERRA PARTY 2 = ELIGE OTRO COMO LIDER.
 
Public Const NP_MODO_LIDERES  As Byte = 1
 
Public Const NP_MAX_PARTYS      As Integer = 500
 
Type NPUsers
    UserIndex                      As Integer  'Puntero para indexar el array de userlist()
    ExpAccumulated                As Long    'Experiencia que lleva el usuario.
    Percentage                    As Byte    'Porcentaje del usuario.
End Type
 
Type newParty
    iUsers(1 To NP_MAX_MEMBERS)    As NPUsers  'Con esto indexamos los usuarios y sus datos.
    PartyOnline                    As Boolean  'Para buscar slots.
    CreatorIndex                  As Integer  'El creador de la party.
    PartyMembers                  As Byte    'Cantidad de miembros que tiene la party.
End Type
 
Public newPartys(1 To NP_MAX_PARTYS) As newParty
'Esto nos sirve nada mas que para los slots.
Private UltimaParty                  As Integer
 
Private Function NewParty_SearchFreeSlot(ByRef AllOcupeds As Boolean)
 
' \ Designed : maTih.-
' \ Note    : Find an available slot.
 
AllOcupeds = False
 
Dim nLoop  As Long
 
'If not full, we were here.
If UltimaParty < NP_MAX_PARTYS Then
    NewParty_SearchFreeSlot = UltimaParty + 1
    Exit Function
End If
 
For nLoop = 1 To NP_MAX_PARTYS + 1
 
    With newPartys(nLoop)
        If nLoop > NP_MAX_PARTYS Then Exit For
     
        If .PartyOnline = False Then Exit For
 
    End With
Next nLoop
 
'If we keep not full...
If nLoop <= NP_MAX_PARTYS Then
        NewParty_SearchFreeSlot = nLoop
    Else
        AllOcupeds = True
End If
 
End Function
 
Private Function NewParty_PartyFull(ByVal partyIndex As Byte) As Boolean
 
' \ Designed : maTih.-
' \ Note    : Returns whether the party is full.
 
Dim endBool    As Long
 
If partyIndex <= 0 Or partyIndex > NP_MAX_PARTYS Then Exit Function
 
If newPartys(partyIndex).PartyMembers < 5 Then
    NewParty_PartyFull = False
    Exit Function
End If
 
For endBool = 1 To NP_MAX_MEMBERS + 1
 
    If endBool > NP_MAX_MEMBERS Then Exit For
 
    If Not newPartys(partyIndex).iUsers(endBool).UserIndex <> 0 Then Exit For
 
Next endBool
 
NewParty_PartyFull = (endBool < 5)
 
End Function
 
Private Function NewParty_LeaderParty(ByVal iUserIndex As Integer) As Boolean
 
' \ Designed : maTih.-
' \ Note    : Returns whether the user is the leader of the party.
 
Dim pIndex  As Integer
 
pIndex = UserList(iUserIndex).Partys.partyIndex
 
If pIndex <= 0 Or pIndex > NP_MAX_PARTYS Then Exit Function
 
NewParty_LeaderParty = (newPartys(pIndex).CreatorIndex = iUserIndex)
 
End Function
 
Public Sub NewParty_CreateNew(ByVal CreatorIndex As Integer)
 
' \ Designed : maTih.-
' \ Note    : Create a new party.
 
Dim FindSlot    As Boolean
Dim tmpInt      As Integer
 
tmpInt = NewParty_SearchFreeSlot(FindSlot)
 
'Update last Party.
UltimaParty = UltimaParty + 1
 
If FindSlot Then
    WriteConsoleMsg CreatorIndex, "No hay más slots para partys, avise a un administrador!!", FontTypeNames.FONTTYPE_CITIZEN
    Exit Sub
End If
 
With newPartys(tmpInt)
    .PartyOnline = True
   
    '"Connect" the first user as a leader.
    .iUsers(1).UserIndex = CreatorIndex
    .iUsers(1).ExpAccumulated = 0
    'Set the maximum percentage from leader.
    .iUsers(1).Percentage = 100
   
    .CreatorIndex = CreatorIndex
   
    .PartyMembers = 1
End With
 
WriteConsoleMsg CreatorIndex, "Has creado una party!", FontTypeNames.FONTTYPE_PARTY
 
UserList(CreatorIndex).Partys.partyIndex = tmpInt
UserList(CreatorIndex).Partys.UserIndexInParty = 1
 
End Sub
 
Public Sub NewParty_SubmitRequest(ByVal SendIndex As Integer, ByVal OtherIndex As Integer)
 
' \ Designed : maTih.-
' \ Note    : Submit Request to OtherIndex party.
 
Dim otherParty  As Integer
 
otherParty = UserList(OtherIndex).Partys.partyIndex
 
'Invalid Pointer party?
If otherParty <= 0 Then
    WriteConsoleMsg SendIndex, UserList(OtherIndex).name & " No es el lider de ninguna party.", FontTypeNames.FONTTYPE_PARTY
    Exit Sub
End If
 
'Already in a party?
If UserList(SendIndex).Partys.partyIndex > 0 Then
    WriteConsoleMsg SendIndex, "Ya integras una party.", FontTypeNames.FONTTYPE_PARTY
    Exit Sub
End If
 
'If Party its full?
 
If NewParty_PartyFull(otherParty) Then
    WriteConsoleMsg SendIndex, "Esa party no puede tener más miembros..", FontTypeNames.FONTTYPE_PARTY
    Exit Sub
End If
 
'This user is a leader?
 
If NewParty_LeaderParty(OtherIndex) <> True Then
    WriteConsoleMsg SendIndex, "Ese usuario no es el lider de su party.", FontTypeNames.FONTTYPE_PARTY
    Exit Sub
End If
 
'Notice the leader and keep the pointer.
UserList(SendIndex).Partys.PartySender = otherParty
 
WriteConsoleMsg OtherIndex, UserList(SendIndex).name & " Solicita ingresar a la party.", FontTypeNames.FONTTYPE_PARTY
 
End Sub
 
Private Function NewParty_IndexToUser(ByVal pIndex As Byte) As Byte
 
' \ Designed : maTih.-
' \ Note    : Returns an array index for the user in the party.
 
Dim nLoop  As Long
 
For nLoop = 1 To NP_MAX_MEMBERS
    With newPartys(pIndex).iUsers(nLoop)
        If Not (.UserIndex <> 0) Then
            NewParty_IndexToUser = nLoop
        End If
    End With
Next nLoop
 
End Function
 
Private Function NewParty_Members(ByVal pIndex As Byte)
 
' \ Designed : maTih.-
' \ Note    : Returns the number of members the party has..
 
Dim nLoop  As Long
Dim Count  As Byte
 
For nLoop = 1 To NP_MAX_MEMBERS
 
    With newPartys(pIndex).iUsers(nLoop)
        If .UserIndex <> 0 Then
            Count = Count + 1
        End If
    End With
 
Next nLoop
 
NewParty_Members = Count
 
End Function
 
Public Sub NewParty_AcceptUser(ByVal CreatorIndex As Integer, ByVal UserAccepted As Integer)
 
' \ Designed : maTih.-
' \ Note    : Leader accepts a new member to the party.
 
Dim pIndex      As Integer
 
pIndex = UserList(CreatorIndex).Partys.partyIndex
 
If pIndex <= 0 Then Exit Sub
 
'If you do not ask to enter..
If UserList(UserAccepted).Partys.PartySender <> pIndex Then
    WriteConsoleMsg CreatorIndex, "Ese usuario no solicito ingresar a tu party.", FontTypeNames.FONTTYPE_PARTY
    Exit Sub
End If
 
'If another user is already in a party..
If UserList(UserAccepted).Partys.partyIndex > 0 Then
    WriteConsoleMsg CreatorIndex, "Ese usuario ya esta en una party.", FontTypeNames.FONTTYPE_PARTY
    Exit Sub
End If
 
'If not the leader...
If newPartys(pIndex).CreatorIndex <> CreatorIndex Then
    WriteConsoleMsg CreatorIndex, "Solo el lider de la party puede aceptar un nuevo miembro.", FontTypeNames.FONTTYPE_PARTY
    Exit Sub
End If
 
'If the party is full..
If NewParty_PartyFull(pIndex) Then
    WriteConsoleMsg CreatorIndex, "La party no puede tener más miembros.", FontTypeNames.FONTTYPE_PARTY
    Exit Sub
End If
 
'Connect the new member and notify.
 
Dim newIndex    As Byte
Dim nLoop      As Long
 
With newPartys(pIndex)
 
      NewParty_SendMessage pIndex, "El lider aceptó a " & UserList(UserAccepted).name & " en la party."
   
    If .PartyMembers < 5 Then
            .PartyMembers = .PartyMembers + 1
            newIndex = .PartyMembers
        Else
            newIndex = NewParty_IndexToUser(pIndex)
    End If
   
    UserList(UserAccepted).Partys.UserIndexInParty = newIndex
    'We set the new rate and notify
   
    .iUsers(newIndex).Percentage = Porcentaje(100, NewParty_Members(pIndex))
    NewParty_SendMessage pIndex, "¡Porcentajes actualizados!"
   
    For nLoop = 1 To NP_MAX_MEMBERS    '.PartyMembers
    'We send the message the name and percentage.
        If .iUsers(nLoop).UserIndex <> 0 Then
            'If the user does not send nothing is valid
            If UserList(.iUsers(nLoop).UserIndex).ConnID <> -1 Then
                NewParty_SendMessage pIndex, UserList(.iUsers(nLoop).UserIndex).name & " : " & .iUsers(nLoop).Percentage & " %"
            End If
        End If
     
    Next nLoop
End With
 
End Sub
 
Private Sub NewParty_SendMessage(ByVal partyIndex As Integer, ByRef sMSG As String)
 
' \ Designed : maTih.-
' \ Note    : Leader accepts a new member to the party.
 
Dim nLoop  As Long
 
For nLoop = 1 To NP_MAX_MEMBERS    'NewPartys(PartyIndex).PartyMembers
 
    If newPartys(partyIndex).iUsers(nLoop).UserIndex <> 0 Then
 
    '  If the user does not send nothing is valid
        If UserList(newPartys(partyIndex).iUsers(nLoop).UserIndex).ConnID <> -1 Then
         
            WriteConsoleMsg newPartys(partyIndex).iUsers(nLoop).UserIndex, "[Mensaje PARTY] : " & sMSG, FontTypeNames.FONTTYPE_PARTY
         
        End If
    End If
 
Next nLoop
 
End Sub
 
Public Sub NewParty_SetNewPercentage(ByVal pIndex As Byte, ByRef arrayUsers() As Byte, ByRef arrayPercentages() As Byte)
 
' \ Designed : maTih.-
' \ Note    : The leader changes the percentages.
 
Dim nLoop  As Long
 
NewParty_SendMessage pIndex, "El lider ha cambiado los valores de los porcentajes"
NewParty_SendMessage pIndex, "Porcentajes : "
For nLoop = LBound(arrayUsers()) To UBound(arrayUsers())
    'Set new percentages and notify
    With newPartys(pIndex).iUsers(nLoop)
        .Percentage = arrayPercentages(nLoop)
        NewParty_SendMessage pIndex, "Porcentaje de : " & UserList(.UserIndex).name & " " & .Percentage & " % "
    End With
Next nLoop
 
'Notify all users in pIndex
 
End Sub
 
Public Sub NewParty_DealExperiencie(ByVal pIndex As Integer)
 
' \ Designed : maTih.-
' \ Note    : Divide the user experience in party.
 
Dim nLoopX      As Long
Dim tmpIntUser  As Integer
 
For nLoopX = 1 To NP_MAX_MEMBERS
 
    With newPartys(pIndex).iUsers(nLoopX)
 
        'A user is logged?
 
        If .UserIndex <> 0 Then
            If UserList(.UserIndex).ConnID <> -1 Then
                'We experience and close.
                UserList(.UserIndex).Stats.Exp = UserList(.UserIndex).Stats.Exp + .ExpAccumulated
                'Update the client.
                WriteUpdateExp .UserIndex
                'We check for level went up.
                CheckUserLevel .UserIndex
            End If
        End If
 
    End With
 
Next nLoopX
 
End Sub
 
Public Sub NewParty_DealAccumulatedExperiencie(ByVal indexInParty As Byte, ByVal pIndex As Byte)
 
' \ Designed : maTih.-
' \ Note    : Delivery experience a single user in the party.
 
'    C U I D A D O!
'    ESTE METODO NO TRABAJA CON USERINDEXS
'    DIRECTAMENTE ENCUENTRA EL PUNTERO PARA EL ARRAY
'    DE USERLIST() EN EL TYPE DE NEWPARTYs!
 
Dim UserIndex      As Integer
Dim userExp        As Long
 
'Get Data.
UserIndex = newPartys(pIndex).iUsers(indexInParty).UserIndex
userExp = newPartys(pIndex).iUsers(indexInParty).ExpAccumulated
 
'High experience, upgrade the client and I control leveling
With UserList(UserIndex)
    .Stats.Exp = .Stats.Exp + userExp
    WriteUpdateExp UserIndex
    CheckUserLevel UserIndex
    WriteConsoleMsg UserIndex, "[PARTY] : Recibes la experiencia ! Has ganado : " & Format$(userExp, "#.###") & " puntos de experiencia.", FontTypeNames.FONTTYPE_PARTY
End With
 
End Sub
 
Public Sub NewParty_CloseUser(ByVal UserIndex As Integer)
 
' \ Designed : maTih.-
' \ Note    : Control user disconnects party.
 
Dim myPI    As Integer
 
myPI = UserList(UserIndex).Partys.partyIndex
 
'If you notify party colleagues and we experience it deserves.
If myPI <> 0 Then
 
    NewParty_SendMessage myPI, UserList(UserIndex).name & " Se ha desconectado!"
    NewParty_DealAccumulatedExperiencie UserList(UserIndex).Partys.UserIndexInParty, UserList(UserIndex).Partys.partyIndex
 
    'Close the connection the leader?
    If NewParty_LeaderParty(UserIndex) Then
        'You must choose a new leader?
        If NP_MODO_LIDERES <> 1 Then
                NewParty_ChooseNewLeader myPI, 0
            Else
                NewParty_CloseParty myPI
        End If
    End If
 
End If
 
End Sub
 
Private Sub NewParty_CloseParty(ByVal pIndex As Integer)
 
' \ Designed : maTih.-
' \ Note    : I shut the party sharing experience and memory clean
 
Dim nLoopX  As Long
 
    NewParty_SendMessage pIndex, "Se cierra la party!"
    NewParty_DealExperiencie pIndex
 
With newPartys(pIndex)
    .PartyMembers = 0
    .PartyOnline = False
    .CreatorIndex = 0
   
    For nLoopX = 1 To NP_MAX_MEMBERS
   
        With .iUsers(nLoopX)
                .UserIndex = 0
                .Percentage = 0
                .ExpAccumulated = 0
        End With
   
    Next nLoopX
   
End With
 
End Sub
 
Private Sub NewParty_ChooseNewLeader(ByVal partyIndex As Integer, ByVal NewLeader As Integer)
 
' \ Designed : maTih.-
' \ Note    : Sets a new leader for the party.
 
Dim nLoopX          As Long
Dim nuevoLider      As Integer
 
With newPartys(partyIndex)
 
'You have to set starting a new leader?
If NewLeader <> 0 Then
    .CreatorIndex = NewLeader
    NewParty_SendMessage partyIndex, "Nuevo lider de la party!!! : " & UserList(NewLeader).name
    Exit Sub
End If
 
'If there was to set starting a new leader then disconnect the same
.PartyMembers = .PartyMembers - 1
 
For nLoopX = 1 To NP_MAX_MEMBERS
 
    With .iUsers(nLoopX)
        If .UserIndex <> 0 Then
            If UserList(.UserIndex).ConnID <> -1 Then
                nuevoLider = nLoopX
            End If
        End If
    End With
 
Next nLoopX
 
If nuevoLider <> 0 Then
        .CreatorIndex = .iUsers(nuevoLider).UserIndex
    Else
        NewParty_CloseParty partyIndex
End If
 
End With
 
End Sub
 
Public Sub NewParty_AccumulatedExperiencie(ByVal UserWinner As Integer, ByVal expALL As Long)
 
' \ Designed : maTih.-
' \ Note    : Adds a user experience of the party.
 
Dim nLoopX  As Long
Dim tIndex  As Integer
Dim expToMy As Long
 
'Initialize variable.
expToMy = expALL
 
'We found the percentage of user.
expToMy = Porcentaje(expALL, newPartys(UserList(UserWinner).Partys.partyIndex).iUsers(UserList(UserWinner).Partys.UserIndexInParty).Percentage)
 
'We add experience who want and what is left over the hand out.
    newPartys(UserList(UserWinner).Partys.partyIndex).iUsers(UserList(UserWinner).Partys.UserIndexInParty).ExpAccumulated = _
    newPartys(UserList(UserWinner).Partys.partyIndex).iUsers(UserList(UserWinner).Partys.UserIndexInParty).ExpAccumulated _
    + expToMy
 
'Reset variable.
 
expToMy = (expALL - expToMy)
 
'We go all users in the party.
For nLoopX = 1 To NP_MAX_MEMBERS
 
    With newPartys(UserList(UserWinner).Partys.partyIndex).iUsers(nLoopX)
 
    tIndex = .UserIndex
    'If a user is logged on and is in the area
    'of the user gains experience we add the experience
    'we stay according to their percentage.
 
    If tIndex <> 0 Then
        If UserList(tIndex).ConnID <> -1 Then
            If EstaPCarea(UserWinner, tIndex) Then
                .ExpAccumulated = .ExpAccumulated + Porcentaje(expToMy, .Percentage)
            End If
        End If
    End If
 
    End With
     
Next nLoopX
 
End Sub
 
Public Function NewParty_ReturnsOnlineParty(ByVal pIndex As Integer) As String
 
' \ Designed : maTih.-
' \ Note    : Returns the names from users in party.
 
If pIndex <= 0 Or pIndex > NP_MAX_MEMBERS Then Exit Function
 
Dim nLoop      As Long
Dim tmpString  As String
For nLoop = 1 To NP_MAX_MEMBERS
 
    With newPartys(pIndex).iUsers(nLoop)
     
        If .UserIndex <> 0 Then
            If UserList(.UserIndex).ConnID <> -1 Then
             
                tmpString = tmpString & UserList(.UserIndex).name & "(" & .ExpAccumulated & ")" & "-"
             
            End If
        End If
    End With
 
Next nLoop
 
'We cut the last character in string.
If Len(tmpString) > 0 Then
    tmpString = Left$(tmpString, Len(tmpString) - 1)
End If
 
'ENJOY :P
 
NewParty_ReturnsOnlineParty = tmpString
 
End Function
 
Public Sub NewParty_ConverToByteArray(ByRef Array1() As String, ByRef array2() As Byte)
 
' \ Designed : maTih.-
' \ Note    : Converts a string into a byte array.
 
Dim intoLong    As Long
 
For intoLong = LBound(Array1()) To UBound(Array1())
    array2(intoLong) = val(Array1(intoLong))
Next intoLong
 
End Sub

Private Sub HandleChangeValuesParty(ByVal UserIndex As Integer)
 
' \ Designed : maTih.-
' \ Note    : Manage the package and its actions to change the values of the party.
 
Dim buffer                  As New clsByteQueue
Dim arrUsers()              As String
Dim arrNewPercentage()      As String
Dim newArrUsers()          As Byte
Dim newArrPercentage()      As Byte
 
With UserList(UserIndex)
 
buffer.CopyBuffer .incomingData
 
buffer.ReadByte
 
arrUsers = Split(buffer.ReadASCIIString(), ",")
arrNewPercentage = Split(buffer.ReadASCIIString(), ",")
 
NewParty_ConvertToByteArray arrUsers, newArrUsers
NewParty_ConvertToByteArray arrNewPercentage, newArrPercentage
 
    If .Partys.partyIndex > 0 Then
        If NewParty_LeaderParty(UserIndex) Then
            NewParty_SetNewPercentage .Partys.partyIndex, newArrUsers, newArrPercentage
        End If
    End If
 
.incomingData.CopyBuffer buffer
 
End With
 
End Sub

Public Sub WriteChangeValuesParty(ByVal stringUserIndex As String, ByVal stringNewPercentage As String)
 
' \ Designed : maTih.-
' \ Note    : Send the package that changes the current value of party.
 
With outgoingData
 
    .WriteByte ClientPacketID.CreenElPaquete
    .WriteASCIIString stringUserIndex
    .WriteASCIIString stringNewPercentage
   
End With
 
End Sub

Dim fin1$
 
For LoopX = 1 To 5
    fin1 = fin1 & textboxarray(LoopX).Text & ","
Next LoopX