Sistema de Rank Funcional

Código:

Private Sub cmdRefresh_Click()

End Sub

Código:

Private Sub cmdRefresh_Click()
    ' If debug mode, handle error then exit out
    If Options.Debug = 1 Then On Error GoTo errorhandler
   
    SendRequestRank
   
    ' Error handler
    Exit Sub
errorhandler:
    HandleError "cmdRefresh_Click", "frmMain", Err.Number, Err.Description, Err.Source, Err.HelpContext
    Err.Clear
    Exit Sub
End Sub

Código:

Public Const MAX_PARTY_MEMBERS As Long = 4

Código:

Public Const MAX_RANK As Long = 10

Código:

Public Sub SendRequestRank()
Dim Buffer As clsBuffer

    ' If debug mode, handle error then exit out
    If Options.Debug = 1 Then On Error GoTo errorhandler
   
    Set Buffer = New clsBuffer
    Buffer.WriteLong CRequestRank
    SendData Buffer.ToArray()
    Set Buffer = Nothing
   
    ' Error handler
    Exit Sub
errorhandler:
    HandleError "SendRequestRank", "modClientTCP", Err.Number, Err.Description, Err.Source, Err.HelpContext
    Err.Clear
    Exit Sub
End Sub

Código:

' Make sure CMSG_COUNT is below everything else

Código:

CPartyLeave

Código:

CRequestRank

Código:

' Make sure SMSG_COUNT is below everything else

Código:

SPartyVitals

Código:

SRankUpdate

Código:

HandleDataSub(SPartyVitals) = GetAddress(AddressOf HandlePartyVitals)

Código:

HandleDataSub(SRankUpdate) = GetAddress(AddressOf HandleRankUpdate)

Código:

Private Sub HandleRankUpdate(ByVal Index As Long, ByRef Data() As Byte, ByVal StartAddr As Long, ByVal ExtraVar As Long)
Dim Buffer As clsBuffer, i As Byte

    ' If debug mode, handle error then exit out
    If Options.Debug = 1 Then On Error GoTo errorhandler
   
    Set Buffer = New clsBuffer
    Buffer.WriteBytes Data()
   
    frmMain.lstRank.Clear
   
    For i = 1 To MAX_RANK
        frmMain.lstRank.AddItem i & ":Nível: " & Buffer.ReadLong & ", Nome: " & Trim$(Buffer.ReadString)
    Next i
   
    Set Buffer = Nothing
   
    ' Error handler
    Exit Sub
errorhandler:
    HandleError "HandleRankUpdate", "modHandleData", Err.Number, Err.Description, Err.Source, Err.HelpContext
    Err.Clear
    Exit Sub
End Sub

Código:

                    ' Whos Online
                Case "/who"
                    SendWhosOnline

Código:

                    ' Request Rank
                Case "/rank"
                    SendRequestRank
                    frmMain.picRank.Visible = Not frmMain.picRank.Visible

Código:

frmMain.picParty.Visible = False

Código:

frmMain.picRank.Visible = False

Código:

Public Const MAX_PARTY_MEMBERS As Long = 4

Código:

Public Const MAX_RANK As Long = 10

Código:

' Make sure SMSG_COUNT is below everything else

Código:

SPartyVitals

Código:

SRankUpdate

Código:

' Make sure CMSG_COUNT is below everything else

Código:

CPartyLeave

Código:

CRequestRank

Código:

HandleDataSub(CPartyLeave) = GetAddress(AddressOf HandlePartyLeave)

Código:

HandleDataSub(CRequestRank) = GetAddress(AddressOf HandleRequestRank)

Código:

Sub HandleRequestRank(ByVal index As Long, ByRef Data() As Byte, ByVal StartAddr As Long, ByVal ExtraVar As Long)
    SendRankUpdate index
End Sub

Código:

Sub SendRankUpdate(ByVal index As Long)
    Dim i As Byte
    Dim Buffer As clsBuffer
    Set Buffer = New clsBuffer
    Buffer.WriteLong SRankUpdate
    For i = 1 To MAX_RANK
        Buffer.WriteLong Rank(i).Level
        Buffer.WriteString Trim$(Rank(i).Name)
    Next i
    SendDataTo index, Buffer.ToArray()
    Set Buffer = Nothing
End Sub

Código:

Sub CheckPlayerLevelUp(ByVal index As Long)

Código:

Dim level_count As Long

Código:

Dim RankPos As Byte

Código:

SendPlayerData index

Código:

        ' check rank
        RankPos = CheckRank(index)
        If RankPos > 0 Then
            ChangeRank index, RankPos
        End If

Código:

Private Function CheckRank(ByVal index As Long) As Byte
Dim i As Byte
    For i = 1 To MAX_RANK
        If GetPlayerLevel(index) > Rank(i).Level Then
            CheckRank = i
            Exit Function
        End If
    Next i
End Function

Private Sub ChangeRank(ByVal index As Long, RankPos As Byte)
Dim i As Long, ClearPos As Byte

    ' if not change position in rank
    If GetPlayerName(index) = Trim$(Rank(RankPos).Name) Then
        Rank(RankPos).Level = GetPlayerLevel(index)
        SaveRank
        Exit Sub
    End If

    ' search player in rank
    For i = 1 To MAX_RANK
        If GetPlayerName(index) = Trim$(Rank(i).Name) Then
            Rank(i).Name = vbNullString
            Rank(i).Level = 0
            ClearPos = i
            Exit For
        End If
    Next i

    ' down clear position
    If ClearPos > 0 Then
        For i = ClearPos To MAX_RANK
            If i = MAX_RANK Then
                Rank(i).Name = vbNullString
                Rank(i).Level = 0
            Else
                Rank(i).Name = Rank(i + 1).Name
                Rank(i).Level = Rank(i + 1).Level
            End If
        Next i
    End If
   
    ' open space in rank to player
    For i = MAX_RANK To RankPos Step -1
        If i > RankPos Then
            Rank(i).Name = Rank(i - 1).Name
            Rank(i).Level = Rank(i - 1).Level
        End If
    Next i
   
    ' put player in rank
    Rank(RankPos).Name = GetPlayerName(index)
    Rank(RankPos).Level = GetPlayerLevel(index)
   
    SaveRank
End Sub

Código:

Public Sub SaveRank()
Dim filename As String, i As Byte

    filename = App.Path & "\data\rank.ini"
   
    For i = 1 To MAX_RANK
        PutVar filename, "RANK", "Name" & i, Trim$(Rank(i).Name)
        PutVar filename, "RANK", "Level" & i, Val(Rank(i).Level)
    Next i
End Sub

Public Sub LoadRank()
Dim filename As String, i As Byte

    filename = App.Path & "\data\rank.ini"
   
    If FileExist(filename, True) Then
        For i = 1 To MAX_RANK
            Rank(i).Name = GetVar(filename, "RANK", "Name" & i)
            Rank(i).Level = Val(GetVar(filename, "RANK", "Level" & i))
        Next i
    Else
        SaveRank
    End If
End Sub

Código:

Public Party(1 To MAX_PARTYS) As PartyRec

Código:

Public Rank(1 To MAX_RANK) As RankRec

Código:

Private Type OptionsRec
    Game_Name As String
    MOTD As String
    Port As Long
    Website As String
End Type

Código:

Private Type RankRec
    Name As String * ACCOUNT_LENGTH
    Level As Long
End Type

Código:

    ' Send Resource cache
    For i = 0 To ResourceCache(GetPlayerMap(index)).Resource_Count
        SendResourceCacheTo index, i
    Next

Código:

    ' Check Rank
    For i = 1 To MAX_RANK
        If Trim$(Rank(i).Name) = GetPlayerName(index) Then
            Exit For
        End If
        If GetPlayerLevel(index) > Rank(i).Level Then
            Rank(i).Name = GetPlayerName(index)
            Rank(i).Level = GetPlayerLevel(index)
            SaveRank
            Exit For
        End If
    Next i

Código:

    Call SetStatus("Loading animations...")
    Call LoadAnimations

Código:

    Call SetStatus("Loading rank...")
    Call LoadRank

Código:

RankPos = CheckRank(Index)
        If Getplayerlevel(index) > RankPos Then
            ChangeRank Index, RankPos
        Else
  Exit sub
        End If


Código:


For x = 1 to Max_Rank
RankPos(x) = CheckRank(Index)
        If Getplayerlevel(index) > RankPos(x) Then
            ChangeRank Index, RankPos(x)
        Else
  Exit sub
        End If
Next x


lucas100vzs escreveu: Valentine, tem só um probleminha neste sistema....

Cara quando o player passa de level dá muito "LAG" no servidor....acho que é pelo fato de ele fazer aquela checagem....tipo eu abri meu painel Administrador e apertei rápido(5 vezes seguidas) no botão "level up" e deu um pequeno travamento server~cliente.....acho que vai dar problema com mais players online mudando de level ao mesmo tempo...

Teria como colocar o check da "Sub CheckPlayerLevelUp" pra ser tipo:

Código:

RankPos = CheckRank(Index)
        If Getplayerlevel(index) > RankPos Then
            ChangeRank Index, RankPos
        Else
  Exit sub
        End If


Sendo que o RankPos seja os levels do Rank...Assim ele só faria o check no rank se realmente o player tivesse level maior que os já existentes, e não a cada Level Up....Você acha que funcionaria?
Pra isso eu acho teria que colocar "Rank(1 to Max_Rank) as Rankrec"
Depois colocar:

Código:


For x = 1 to Max_Rank
RankPos(x) = CheckRank(Index)
        If Getplayerlevel(index) > RankPos(x) Then
            ChangeRank Index, RankPos(x)
        Else
  Exit sub
        End If
Next x


Eu não sei, mas acho que dessa forma ele checaria de 1 até 10 no rank pra saber o level....
No mais gostei do Rank...se o problema for só aqui a partir do "LAG" , eu vejo um jeito melhor de consertar....Senão se quiser me ajudar a dinamizar o meu caso no código, agradeceria....
+1 pra você, e obrigado por contribuir, continue assim !!!

Código:

For i = 1 To MAX_RANK

Código:

For x = 1 to Max_Rank
RankPos(x) = CheckRank(Index)

Código:


' check rank
        RankPos = CheckRank(Index)
        If RankPos > 0 Then
            ChangeRank Index, RankPos
        Else
        End If


Código:

If GetPlayerAccess(Index) > ADMIN_MONITOR Then Exit Sub

Código:

    ' if not change position in rank
    If GetPlayerName(index) = Trim$(Rank(RankPos).Name) Then
        Rank(RankPos).Level = GetPlayerLevel(index)
        SaveRank
        Exit Sub
    End If

xurana321 escreveu:aqui nao ta abrindo quando eu COLOCO /rank

@EDIT
e nao adianta falar que eu fiz alguma COISA errado pq eu nao fiz, ta tudo CERTO..

Código:

                    ' Request Rank
                Case "/rank"
                    SendRequestRank
                    frmMain.picRank.Visible = Not frmMain.picRank.Visible