[Aporte] Sistema de Ranking "TORNEOS/RETOS/CIUDADANOS,CRIMINALES MATADOS/FRAGS/ORO"

IgNaah14.-

Newbie Lvl 1
Hola xD les traigo un codigo extraido de la liberacion DolwurAO (Ya se que hay Sistema deRankings pero este me parecio bueno) Solo le tienen que adaptar lo de Torneos/Retos a su codigo de eventos, lo dejo con los formularios (son los de Dolwur ustedes despues se haran uno:abrazo:)

Fotos de como seria el ranking:






#########################################SERVIDOR~#######################################
Creamos un Modulo.bas y lo vamos a llamar "mRanking" y dentro ponemos todo esto :

Código:
Option Explicit

Public Const MAX_TOP As Byte = 10
Public Const MAX_RANKINGS As Byte = 6

Public Type tRanking
    value(1 To MAX_TOP) As Long
    Nombre(1 To MAX_TOP) As String
End Type

Public Ranking(1 To MAX_RANKINGS) As tRanking

Public Enum eRanking
    TopFrags = 1
    TopTorneos = 2
    TopLevel = 3
    TopOro = 4
    TopRetos = 5
    TopClanes = 6
End Enum



Public Function RenameRanking(ByVal Ranking As eRanking) As String


    '@ Devolvemos el nombre del TAG [] del archivo .DAT
    Select Case Ranking
        Case eRanking.TopClanes
            RenameRanking = "Criminales Matados"
        Case eRanking.TopFrags
            RenameRanking = "Usuarios Matados"
        Case eRanking.TopLevel
            RenameRanking = "Ciudadanos Matados"
        Case eRanking.TopOro
            RenameRanking = "Oro"
        Case eRanking.TopRetos
            RenameRanking = "Retos"
        Case eRanking.TopTorneos
            RenameRanking = "Torneos"
        Case Else
            RenameRanking = vbNullString
    End Select
End Function
Public Function RenameValue(ByVal UserIndex As Integer, ByVal Ranking As eRanking) As Long
    ' @ Devolvemos a que hace referencia el ranking
    With UserList(UserIndex)
        Select Case Ranking
            Case eRanking.TopClanes
                RenameValue = .Faccion.CriminalesMatados
                'RenameValue = guilds(.GuildIndex).Puntos
            Case eRanking.TopFrags
                RenameValue = .Stats.UsuariosMatados
            Case eRanking.TopLevel
                RenameValue = .Faccion.CiudadanosMatados
            Case eRanking.TopOro
                RenameValue = .Stats.GLD
           ' Case eRanking.TopRetos
              '  RenameValue = .Stats.RetosGanados
           ' Case eRanking.TopTorneos
               ' RenameValue = .Stats.TorneosGanados
        End Select
    End With
End Function

Public Sub LoadRanking()
    ' @ Cargamos los rankings
   
    Dim LoopI As Integer
    Dim LoopX As Integer
    Dim ln As String
   
    For LoopX = 1 To MAX_RANKINGS
        For LoopI = 1 To MAX_TOP
            ln = GetVar(App.Path & "\Dat\" & "Ranking.dat", RenameRanking(LoopX), "Top" & LoopI)
            Ranking(LoopX).Nombre(LoopI) = ReadField(1, ln, 45)
            Ranking(LoopX).value(LoopI) = val(ReadField(2, ln, 45))
        Next LoopI
    Next LoopX
   
End Sub
   
Public Sub SaveRanking(ByVal Rank As eRanking)
' @ Guardamos el ranking

    Dim LoopI As Integer
   
        For LoopI = 1 To MAX_TOP
            Call WriteVar(DatPath & "Ranking.Dat", RenameRanking(Rank), _
                "Top" & LoopI, Ranking(Rank).Nombre(LoopI) & "-" & Ranking(Rank).value(LoopI))
        Next LoopI
End Sub

Public Sub CheckRankingUser(ByVal UserIndex As Integer, ByVal Rank As eRanking)
    ' @ Desde aca nos hacemos la siguientes preguntas
    ' @ El personaje está en el ranking?
    ' @ El personaje puede ingresar al ranking?
   
    Dim LoopX As Integer
    Dim LoopY As Integer
    Dim loopZ As Integer
    Dim i As Integer
    Dim value As Long
    Dim Actualizacion As Byte
    Dim Auxiliar As String
    Dim PosRanking As Byte
   
    With UserList(UserIndex)
       
        ' @ Not gms
        If EsGM(UserIndex) Then Exit Sub
       
        value = RenameValue(UserIndex, Rank)
       
        ' @ Buscamos al personaje en el ranking
        For i = 1 To MAX_TOP
            If Ranking(Rank).Nombre(i) = UCase$(.name) Then
                PosRanking = i
                Exit For
            End If
        Next i
       
        ' @ Si el personaje esta en el ranking actualizamos los valores.
        If PosRanking <> 0 Then
            ' ¿Si está actualizado pa que?
            If value <> Ranking(Rank).value(PosRanking) Then
                Call ActualizarPosRanking(PosRanking, Rank, value)
               
               
                ' ¿Es la pos 1? No hace falta ordenarlos
                If Not PosRanking = 1 Then
                    ' @ Chequeamos los datos para actualizar el ranking
                    For LoopY = 1 To MAX_TOP
                        For loopZ = 1 To MAX_TOP - LoopY
                               
                            If Ranking(Rank).value(loopZ) < Ranking(Rank).value(loopZ + 1) Then
                               
                                ' Actualizamos el valor
                                Auxiliar = Ranking(Rank).value(loopZ)
                                Ranking(Rank).value(loopZ) = Ranking(Rank).value(loopZ + 1)
                                Ranking(Rank).value(loopZ + 1) = Auxiliar
                               
                                ' Actualizamos el nombre
                                Auxiliar = Ranking(Rank).Nombre(loopZ)
                                Ranking(Rank).Nombre(loopZ) = Ranking(Rank).Nombre(loopZ + 1)
                                Ranking(Rank).Nombre(loopZ + 1) = Auxiliar
                                Actualizacion = 1
                            End If
                        Next loopZ
                    Next LoopY
                End If
                   
                If Actualizacion <> 0 Then
                    Call SaveRanking(Rank)
                End If
            End If
           
            Exit Sub
        End If
       
        ' @ Nos fijamos si podemos ingresar al ranking
        For LoopX = 1 To MAX_TOP
            If value > Ranking(Rank).value(LoopX) Then
                Call ActualizarRanking(LoopX, Rank, .name, value)
                Exit For
            End If
        Next LoopX
       
    End With
End Sub

Public Sub ActualizarPosRanking(ByVal Top As Byte, ByVal Rank As eRanking, ByVal value As Long)
    ' @ Actualizamos la pos indicada en caso de que el personaje esté en el ranking
    Dim LoopX As Integer

    With Ranking(Rank)
       
        .value(Top) = value
    End With
End Sub
Public Sub ActualizarRanking(ByVal Top As Byte, ByVal Rank As eRanking, ByVal UserName As String, ByVal value As Long)
   
    '@ Actualizamos la lista de ranking
   
    Dim LoopC As Integer
    Dim i As Integer
    Dim j As Integer
    Dim valor(1 To MAX_TOP) As Long
    Dim Nombre(1 To MAX_TOP) As String
   
    ' @ Copia necesaria para evitar que se dupliquen repetidamente
    For LoopC = 1 To MAX_TOP
        valor(LoopC) = Ranking(Rank).value(LoopC)
        Nombre(LoopC) = Ranking(Rank).Nombre(LoopC)
    Next LoopC
   
    ' @ Corremos las pos, desde el "Top" que es la primera
    For LoopC = Top To MAX_TOP - 1
        Ranking(Rank).value(LoopC + 1) = valor(LoopC)
        Ranking(Rank).Nombre(LoopC + 1) = Nombre(LoopC)
    Next LoopC


   
    Ranking(Rank).Nombre(Top) = UCase$(UserName)
    Ranking(Rank).value(Top) = value
    Call SaveRanking(Rank)
    Call SendData(SendTarget.ToAll, 0, PrepareMessageConsoleMsg("Ranking de " & RenameRanking(Rank) & "»" & UserName & " ha subido al TOP " & Top & ".", FontTypeNames.FONTTYPE_GUILD))
End Sub
Despues de haber creado el Modulo vamos a buscar

Código:
Libertad.map = 66
Una vez buscado arriba ponemos :

Código:
Call LoadRanking
Despues de haber puesto Call LoadRanking vamos a Buscar:

Código:
    'Load the user statistics
    Call Statistics.UserConnected(UserIndex)
y Arriba de ese codigo vamos a poner :

Código:
    'Ingresamos al Ranking
    CheckRankingUser UserIndex, TopFrags
    CheckRankingUser UserIndex, TopLevel
    CheckRankingUser UserIndex, TopOro
    CheckRankingUser UserIndex, TopRetos
    CheckRankingUser UserIndex, TopTorneos
    CheckRankingUser UserIndex, TopClanes
Ahora vamos a buscar :

Código:
CancelOfferItem
Abajo Ponemos:

Código:
EnviarDatosRanking
Ahora buscamos :

Código:
Consultation
Abajo ponemos :

Código:
SolicitaRranking
Buscamos :

Código:
Case ClientPacketID.Consultation
        Call HandleConsultation(UserIndex)
Abajo :

Código:
Case ClientPacketID.SolicitaRranking
        Call HandleSolicitarRanking(UserIndex)
En el modulo protocol Ponen:

Código:
Private Sub HandleSolicitarRanking(ByVal UserIndex As Integer)
    With UserList(UserIndex)
        Call .incomingData.ReadByte

        Dim TipoRank As eRanking

        TipoRank = .incomingData.ReadByte

        ' @ Enviamos el ranking
        Call WriteEnviarRanking(UserIndex, TipoRank)

    End With
End Sub
Public Sub WriteEnviarRanking(ByVal UserIndex As Integer, ByVal Rank As eRanking)

'@ Shak
    On Error GoTo Errhandler
    Call UserList(UserIndex).outgoingData.WriteByte(ServerPacketID.EnviarDatosRanking)

    Dim i      As Integer
    Dim Cadena As String
    Dim Cadena2 As String

    For i = 1 To MAX_TOP
        If i = 1 Then
            Cadena = Cadena & Ranking(Rank).Nombre(i)
            Cadena2 = Cadena2 & Ranking(Rank).value(i)
        Else
            Cadena = Cadena & "-" & Ranking(Rank).Nombre(i)
            Cadena2 = Cadena2 & "-" & Ranking(Rank).value(i)
        End If
    Next i


    ' @ Enviamos la cadena
    Call UserList(UserIndex).outgoingData.WriteASCIIString(Cadena)
    Call UserList(UserIndex).outgoingData.WriteASCIIString(Cadena2)
    Exit Sub

Errhandler:
    If Err.Number = UserList(UserIndex).outgoingData.NotEnoughSpaceErrCode Then
        Call FlushBuffer(UserIndex)
        Resume
    End If
End Sub
#################################CLIENTE~~############################################################

En el modulo Declaraciones debajo del option explicit ponemos

Código:
Public Type tRanking
    value(0 To 9) As Long
    Nombre(0 To 9) As String
End Type


Public Ranking As tRanking

Public Enum eRanking
    TopFrags = 1
    TopTorneos = 2
    TopLevel = 3
    TopOro = 4
    TopRetos = 5
    TopClanes = 6
End Enum
Buscamos :

Código:
Consulta
Abajo ponemos :

Código:
SolicitaRranking
Buscamos :

Código:
Case ServerPacketID.CancelOfferItem
        Call HandleCancelOfferItem
Debajo :

Código:
Case ServerPacketID.RecibirRanking
        Call HandleRecibirRanking
Buscamos :

Código:
CancelOfferItem
Abajo ponemos :

Código:
RecibirRanking
En el modulo protocol ponemos:

Código:
Public Sub WriteSolicitarRanking(ByVal Tipo As eRanking)
    With outgoingData
        Call .WriteByte(ClientPacketID.SolicitaRranking)
        Call .WriteByte(Tipo)
    End With
End Sub

Public Sub HandleRecibirRanking()
'Author: Benjamin Barrera
'Recibimos el ranking
'
'
    If incomingData.Length < 3 Then
        Err.Raise incomingData.NotEnoughDataErrCode
        Exit Sub
    End If

    On Error GoTo ErrHandler
    Dim Buffer As New clsByteQueue
    Call Buffer.CopyBuffer(incomingData)

    Dim Arrai() As String
    Dim Arrai2() As String
    Dim Mensaje As String
    Dim i      As Integer

    Dim Cadena As String
    Dim Cadena1 As String

    'Leemos el id del paquete
    Call Buffer.ReadByte

    'Leemos el string
    Cadena = Buffer.ReadASCIIString
    Cadena1 = Buffer.ReadASCIIString

    Arrai = Split(Cadena, "-")


    'redimensiono el array de listaprocesos
    ReDim Arrai2(LBound(Arrai()) To UBound(Arrai()))

    For i = 0 To 9
        Arrai2(i) = Arrai(i)
        Ranking.Nombre(i) = Arrai2(i)
    Next i

    Arrai = Split(Cadena1, "-")

    For i = 0 To 9
        Arrai2(i) = Arrai(i)
        Ranking.value(i) = Arrai(i)
    Next i

    For i = 0 To 9
        If Ranking.Nombre(i) = vbNullString Then
            FrmRanking2.Label1(i).Caption = "<Vacante>"
        Else
            FrmRanking2.Label1(i).Caption = Ranking.Nombre(i) & " : " & Ranking.value(i)
        End If
        'Call ShowConsoleMsg(Ranking.Nombre(i) & "-" & Ranking.value(i))
    Next i

    Call FrmRanking2.Show(vbModeless, frmMain)

    'Copiamos de vuelta el buffer
    Call incomingData.CopyBuffer(Buffer)

ErrHandler:
    Dim error  As Long
    error = Err.number
    On Error GoTo 0

    'Destroy auxiliar buffer
    Set Buffer = Nothing

    If error <> 0 Then _
       Err.Raise error
End Sub
Ahora descargamos Estos 2 Formularios y los ponen en la Carpeta "CODIGOS" De su Cliente, y los abrimos en el visual Basic.

https://www.mediafire.com/file/vbeneov01f3h1yg/CODIGO.rar/file

CTRL + D (Buscamos los 2 formularios, que estarian en la carpeta "Codigos" de su Cliente)(Los formularios son de DolwurAO)

Edit : Dejo las imagenes de los formularios por si acaso jaja (yo las pegue en la carpeta del cliente con una carpeta llamada Recursos)
https://www.mediafire.com/file/o4jdy24utgn36df/Recursos.rar/file
 
Última edición:

Dr. Miqueas150

The Prophet
Ex-Staff
'Author: Benjamin Barrera
'Recibimos el ranking
'

aww que chuchi, hace cuanto no veia un comentario de gente robandole la autoria a otra persona :')
Me recordo al foro en 2012 - 2014 :'D

En fin el codigo este es de Shak y esta posteado en el foro tmb. Gracias por la actitud igual
 

IgNaah14.-

Newbie Lvl 1
Yo deje los creditos y dije que lo extrai jaja y si supongo que es de shak y no lo vi en el foro lee un poco mas la proxima si queres ademas lo hago con toda la onda:guiño:
 

Berraco

Newbie Lvl 1
'Author: Benjamin Barrera
'Recibimos el ranking
'

aww que chuchi, hace cuanto no veia un comentario de gente robandole la autoria a otra persona :')
Me recordo al foro en 2012 - 2014 :'D

En fin el codigo este es de Shak y esta posteado en el foro tmb. Gracias por la actitud igual
CTRL+H
Pablo Márquez
x
Pepito
replace all
jsjsjs
 

Dr. Miqueas150

The Prophet
Ex-Staff
Seguramente poniendo sistema de ranking 13.0 en google no sale..
Pobre de los bots de google que hacen su trabajo al pedo :'(
 
Arriba