Colores en clanes a elección del usuario. 13.0

Ir abajo

Colores en clanes a elección del usuario. 13.0

Mensaje por Toyz el 16/7/2016, 8:12 pm

Un vídeo: (En el video aparece para escribir los colores por RGB, eso cambio, ahora se hace desde un ComboBox)



Empezamos:

Servidor:

En el modGuilds agregan:

Código:

Public Function ColorValidate(ByVal Red As Byte, ByVal Green As Byte, ByVal Blue As Byte) As Boolean

    Dim i   As Integer
  
    ColorValidate = False
  
    Dim R(1 To 12) As Byte
    Dim G(1 To 12) As Byte
    Dim B(1 To 12) As Byte
  
    For i = 1 To 12

        R(i) = val(GetVar(DatPath & "ColorsGuilds.txt", "RED", Red & i))
        G(i) = val(GetVar(DatPath & "ColorsGuilds.txt", "GREEN", Green & i))
        B(i) = val(GetVar(DatPath & "ColorsGuilds.txt", "BLUE", Blue & i))

        If Red <> R(i) Or Green <> G(i) Or Blue <> B(i) Then Exit Function
  
    Next i

    ColorValidate = True

End Function


Public Function GuildColor(ByVal GuildIndex As Integer)

    If GuildIndex <= 0 Or GuildIndex > CANTIDADDECLANES Then _
        Exit Function
      
        GuildColor = guilds(GuildIndex).GuildColor
      
End Function




Reemplazan la Función UpdateTagAndStatus, por esta:

Código:

''
' Prepares the "UpdateTagAndStatus" message and returns it.
'
' @param    CharIndex Character which is moving.
' @param    X X coord of the character's new position.
' @param    Y Y coord of the character's new position.
' @return   The formated message ready to be writen as is on outgoing buffers.
' @remarks  The data is not actually sent until the buffer is properly flushed.

Public Function PrepareMessageUpdateTagAndStatus(ByVal UserIndex As Integer, ByVal NickColor As Byte, _
                                                ByRef Tag As String, ByVal color As Long) As String
'***************************************************
'Author: Alejandro Salvo (Salvito)
'Last Modification: 04/07/07
'Last Modified By: Juan Martín Sotuyo Dodero (Maraxus)
'Prepares the "UpdateTagAndStatus" message and returns it
'15/01/2010: ZaMa - Now sends the nick color instead of the status.
'***************************************************
    With auxiliarBuffer
        Call .WriteByte(ServerPacketID.UpdateTagAndStatus)
      
        Call .WriteInteger(UserList(UserIndex).Char.CharIndex)
        Call .WriteByte(NickColor)
        Call .WriteASCIIString(Tag)
      
        Call .WriteByte(color Mod 256)  'red
        Call .WriteByte((color \ 256) Mod 256) 'green
        Call .WriteByte((color \ 256 \ 256) Mod 256) 'blue
      
        PrepareMessageUpdateTagAndStatus = .ReadASCIIStringFixed(.length)
    End With
End Function


Reemplazan el RefreshCharStatus por este:

Código:

Public Sub RefreshCharStatus(ByVal UserIndex As Integer)
'*************************************************
'Author: Tararira
'Last modified: 04/07/2009
'Refreshes the status and tag of UserIndex.
'04/07/2009: ZaMa - Ahora mantenes la fragata fantasmal si estas muerto.
'*************************************************
    Dim ClanTag As String
    Dim NickColor As Byte
    Dim color As Long
  
    With UserList(UserIndex)
        If .GuildIndex > 0 Then
            ClanTag = modGuilds.GuildName(.GuildIndex)
            ClanTag = " <" & ClanTag & ">"
            color = modGuilds.GuildColor(.GuildIndex)
        End If
      
        NickColor = GetNickColor(UserIndex)
      
        If .showName Then
            Call SendData(SendTarget.ToPCArea, UserIndex, PrepareMessageUpdateTagAndStatus(UserIndex, NickColor, .name & ClanTag, color))
        Else
            Call SendData(SendTarget.ToPCArea, UserIndex, PrepareMessageUpdateTagAndStatus(UserIndex, NickColor, vbNullString, 0))
        End If
      
        'Si esta navengando, se cambia la barca.
        If .flags.Navegando Then
            If .flags.Muerto = 1 Then
                .Char.body = iFragataFantasmal
            Else
                Call ToogleBoatBody(UserIndex)
            End If
          
            Call ChangeUserChar(UserIndex, .Char.body, .Char.Head, .Char.heading, .Char.WeaponAnim, .Char.ShieldAnim, .Char.CascoAnim)
        End If
    End With
End Sub

Reemplazan el MakeUserChar por este:
Código:

Public Sub MakeUserChar(ByVal toMap As Boolean, ByVal sndIndex As Integer, ByVal UserIndex As Integer, _
       ByVal Map As Integer, ByVal X As Integer, ByVal Y As Integer, Optional ButIndex As Boolean = False)
'*************************************************
'Author: Unknown
'Last modified: 15/01/2010
'23/07/2009: Budi - Ahora se envía el nick
'15/01/2010: ZaMa - Ahora se envia el color del nick.
'*************************************************

On Error GoTo Errhandler

   Dim CharIndex As Integer
   Dim ClanTag As String
   Dim NickColor As Byte
   Dim UserName As String
   Dim Privileges As Byte
   Dim GuildColor As Long
 
 
   With UserList(UserIndex)
   '                    Call SendData(SendTarget.ToPCArea, UserIndex, PrepareMessageChatOverHead(Chat, .Char.CharIndex, .flags.ChatColor))
       If InMapBounds(Map, X, Y) Then
           'If needed make a new character in list
           If .Char.CharIndex = 0 Then
               CharIndex = NextOpenCharIndex
               .Char.CharIndex = CharIndex
               CharList(CharIndex) = UserIndex
           End If
         
           'Place character on map if needed
           If toMap Then MapData(Map, X, Y).UserIndex = UserIndex
         
           'Send make character command to clients
           If Not toMap Then
               If .GuildIndex > 0 Then
                   ClanTag = modGuilds.GuildName(.GuildIndex)
                   GuildColor = modGuilds.GuildColor(.GuildIndex)
               End If
             
               NickColor = GetNickColor(UserIndex)
               Privileges = .flags.Privilegios
             
             
               'Preparo el nick
               If .showName Then
                   UserName = .name
                 
                   If .flags.EnConsulta Then
                       UserName = UserName & " " & TAG_CONSULT_MODE
                   Else
                       If UserList(sndIndex).flags.Privilegios And (PlayerType.User Or PlayerType.Consejero Or PlayerType.RoleMaster) Then
                           If LenB(ClanTag) <> 0 Then _
                               UserName = UserName & " <" & ClanTag & ">"
                       Else
                           If (.flags.invisible Or .flags.Oculto) And (Not .flags.AdminInvisible = 1) Then
                               UserName = UserName & " " & TAG_USER_INVISIBLE
                           Else
                               If LenB(ClanTag) <> 0 Then _
                                   UserName = UserName & " <" & ClanTag & ">"
                           End If
                       End If
                   End If
               End If
         
               Call WriteCharacterCreate(sndIndex, .Char.body, .Char.Head, .Char.heading, _
                           .Char.CharIndex, X, Y, _
                           .Char.WeaponAnim, .Char.ShieldAnim, .Char.FX, 999, .Char.CascoAnim, _
                           UserName, NickColor, Privileges, GuildColor)
           Else
               'Hide the name and clan - set privs as normal user
                Call AgregarUser(UserIndex, .Pos.Map, ButIndex)
           End If
       End If
   End With
Exit Sub

Errhandler:
   LogError ("MakeUserChar: num: " & Err.Number & " desc: " & Err.description)
   'Resume Next
   Call CloseSocket(UserIndex)
End Sub
Reemplazan el PrepareMessageCharacterCreate por este:

Código:

''
' Writes the "CharacterCreate" message to the given user's outgoing data buffer.
'
' @param    body Body index of the new character.
' @param    head Head index of the new character.
' @param    heading Heading in which the new character is looking.
' @param    CharIndex The index of the new character.
' @param    X X coord of the new character's position.
' @param    Y Y coord of the new character's position.
' @param    weapon Weapon index of the new character.
' @param    shield Shield index of the new character.
' @param    FX FX index to be displayed over the new character.
' @param    FXLoops Number of times the FX should be rendered.
' @param    helmet Helmet index of the new character.
' @param    name Name of the new character.
' @param    NickColor Determines if the character is a criminal or not, and if can be atacked by someone
' @param    privileges Sets if the character is a normal one or any kind of administrative character.
' @return   The formated message ready to be writen as is on outgoing buffers.
' @remarks  The data is not actually sent until the buffer is properly flushed.

Public Function PrepareMessageCharacterCreate(ByVal body As Integer, ByVal Head As Integer, ByVal heading As eHeading, _
                                ByVal CharIndex As Integer, ByVal X As Byte, ByVal Y As Byte, ByVal weapon As Integer, ByVal shield As Integer, _
                                ByVal FX As Integer, ByVal FXLoops As Integer, ByVal helmet As Integer, ByVal name As String, ByVal NickColor As Byte, _
                                ByVal Privileges As Byte, ByVal GuildColor As Long) As String
'***************************************************
'Author: Juan Martín Sotuyo Dodero (Maraxus)
'Last Modification: 05/17/06
'Prepares the "CharacterCreate" message and returns it
'***************************************************
    With auxiliarBuffer
        Call .WriteByte(ServerPacketID.CharacterCreate)
      
        Call .WriteInteger(CharIndex)
        Call .WriteInteger(body)
        Call .WriteInteger(Head)
        Call .WriteByte(heading)
        Call .WriteByte(X)
        Call .WriteByte(Y)
        Call .WriteInteger(weapon)
        Call .WriteInteger(shield)
        Call .WriteInteger(helmet)
        Call .WriteInteger(FX)
        Call .WriteInteger(FXLoops)
        Call .WriteASCIIString(name)
        Call .WriteByte(NickColor)
        Call .WriteByte(Privileges)
      
        Call .WriteByte(GuildColor Mod 256) 'Red
        Call .WriteByte((GuildColor \ 256) Mod 256) 'Green
        Call .WriteByte((GuildColor \ 256 \ 256) Mod 256) 'Blue
      
        PrepareMessageCharacterCreate = .ReadASCIIStringFixed(.length)
    End With
End Function

Reemplanzan el Public Sub WriteCharacterCreate por este:

Código:
''
' Writes the "CharacterCreate" message to the given user's outgoing data buffer.
'
' @param    UserIndex User to which the message is intended.
' @param    body Body index of the new character.
' @param    head Head index of the new character.
' @param    heading Heading in which the new character is looking.
' @param    CharIndex The index of the new character.
' @param    X X coord of the new character's position.
' @param    Y Y coord of the new character's position.
' @param    weapon Weapon index of the new character.
' @param    shield Shield index of the new character.
' @param    FX FX index to be displayed over the new character.
' @param    FXLoops Number of times the FX should be rendered.
' @param    helmet Helmet index of the new character.
' @param    name Name of the new character.
' @param    criminal Determines if the character is a criminal or not.
' @param    privileges Sets if the character is a normal one or any kind of administrative character.
' @remarks  The data is not actually sent until the buffer is properly flushed.

Public Sub WriteCharacterCreate(ByVal UserIndex As Integer, ByVal body As Integer, ByVal Head As Integer, ByVal heading As eHeading, _
                               ByVal CharIndex As Integer, ByVal X As Byte, ByVal Y As Byte, ByVal weapon As Integer, ByVal shield As Integer, _
                               ByVal FX As Integer, ByVal FXLoops As Integer, ByVal helmet As Integer, ByVal name As String, ByVal NickColor As Byte, _
                               ByVal Privileges As Byte, ByVal GuildColor As Long)
'***************************************************
'Author: Juan Martín Sotuyo Dodero (Maraxus)
'Last Modification: 05/17/06
'Writes the "CharacterCreate" message to the given user's outgoing data buffer
'***************************************************
On Error GoTo Errhandler
   Call UserList(UserIndex).outgoingData.WriteASCIIStringFixed(PrepareMessageCharacterCreate(body, Head, heading, CharIndex, X, Y, weapon, shield, FX, FXLoops, _
                                                           helmet, name, NickColor, Privileges, GuildColor))
Exit Sub

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

Reemplazan:

Código:
       Call WriteCharacterCreate(sndIndex, Npclist(NpcIndex).Char.body, Npclist(NpcIndex).Char.Head, Npclist(NpcIndex).Char.heading, Npclist(NpcIndex).Char.CharIndex, X, Y, 0, 0, 0, 0, 0, vbNullString, 0, 0)

Por este:

Código:
       Call WriteCharacterCreate(sndIndex, Npclist(NpcIndex).Char.body, Npclist(NpcIndex).Char.Head, Npclist(NpcIndex).Char.heading, Npclist(NpcIndex).Char.CharIndex, X, Y, 0, 0, 0, 0, 0, vbNullString, 0, 0,0)

Reemplazan el LoadGuildsDB por este:

Código:

Public Sub LoadGuildsDB()
'***************************************************
'Author: Unknown
'Last Modification: -
'
'***************************************************

Dim CantClanes  As String
Dim i           As Integer
Dim TempStr     As String
Dim Alin        As ALINEACION_GUILD
Dim color       As Long

    GUILDINFOFILE = App.Path & "\guilds\guildsinfo.inf"

    CantClanes = GetVar(GUILDINFOFILE, "INIT", "nroGuilds")
  
    If IsNumeric(CantClanes) Then
        CANTIDADDECLANES = CInt(CantClanes)
    Else
        CANTIDADDECLANES = 0
    End If
  
    For i = 1 To CANTIDADDECLANES
  
        Set guilds(i) = New clsClan
      
        TempStr = GetVar(GUILDINFOFILE, "GUILD" & i, "GUILDNAME")
        Alin = String2Alineacion(GetVar(GUILDINFOFILE, "GUILD" & i, "Alineacion"))
      
        color = GetVar(GUILDINFOFILE, "GUILD" & i, "Color")
      
        Call guilds(i).Inicializar(TempStr, i, Alin, color)
      
    Next i
  
End Sub

Reemplazan el Public Function CrearNuevoClan por este:
Código:

Public Function CrearNuevoClan(ByVal FundadorIndex As Integer, ByRef desc As String, ByRef GuildName As String, ByRef URL As String, ByRef codex() As String, ByVal Alineacion As ALINEACION_GUILD, ByRef refError As String, ByVal Red As Byte, ByVal Green As Byte, ByVal Blue As Byte) As Boolean
'***************************************************
'Author: Unknown
'Last Modification: -
'
'***************************************************

Dim CantCodex       As Integer
Dim i               As Integer
Dim DummyString     As String

    CrearNuevoClan = False
    If Not PuedeFundarUnClan(FundadorIndex, Alineacion, DummyString) Then
        refError = DummyString
        Exit Function
    End If

    If GuildName = vbNullString Or Not GuildNameValido(GuildName) Then
        refError = "Nombre de clan inválido."
        Exit Function
    End If
  
    If YaExiste(GuildName) Then
        refError = "Ya existe un clan con ese nombre."
        Exit Function
    End If

    If ColorValidate(Red, Green, Blue) = False Then
        refError = "Color de clan invalido"
        Exit Function
    End If
  
    CantCodex = UBound(codex()) + 1

    'tenemos todo para fundar ya
    If CANTIDADDECLANES < UBound(guilds) Then
        CANTIDADDECLANES = CANTIDADDECLANES + 1
        'ReDim Preserve Guilds(1 To CANTIDADDECLANES) As clsClan

        'constructor custom de la clase clan
        Set guilds(CANTIDADDECLANES) = New clsClan
      
        With guilds(CANTIDADDECLANES)
            Call .Inicializar(GuildName, CANTIDADDECLANES, Alineacion, RGB(Red, Green, Blue))
          
            'Damos de alta al clan como nuevo inicializando sus archivos
            Call .InicializarNuevoClan(UserList(FundadorIndex).name)
          
            'seteamos codex y descripcion
            For i = 1 To CantCodex
                Call .SetCodex(i, codex(i - 1))
            Next i
            Call .SetDesc(desc)
            Call .SetGuildNews("Clan creado con alineación: " & Alineacion2String(Alineacion))
            Call .SetLeader(UserList(FundadorIndex).name)
            Call .SetURL(URL)
          
          
          
            '"conectamos" al nuevo miembro a la lista de la clase
            Call .AceptarNuevoMiembro(UserList(FundadorIndex).name)
            Call .ConectarMiembro(FundadorIndex)
        End With
      
        UserList(FundadorIndex).GuildIndex = CANTIDADDECLANES
        Call RefreshCharStatus(FundadorIndex)
      
        For i = 1 To CANTIDADDECLANES - 1
            Call guilds(i).ProcesarFundacionDeOtroClan
        Next i
    Else
        refError = "No hay más slots para fundar clanes. Consulte a un administrador."
        Exit Function
    End If
  
    CrearNuevoClan = True
End Function

Reemplazan el Sub CreateNewGuild por este:

Código:

''
' Handles the "CreateNewGuild" message.
'
' @param    userIndex The index of the user sending the message.

Private Sub HandleCreateNewGuild(ByVal UserIndex As Integer)
'***************************************************
'Author: Juan Martín Sotuyo Dodero (Maraxus)
'Last Modification: 05/11/09
'05/11/09: Pato - Ahora se quitan los espacios del principio y del fin del nombre del clan
'***************************************************
    If UserList(UserIndex).incomingData.length < 12 Then
        Err.Raise UserList(UserIndex).incomingData.NotEnoughDataErrCode
        Exit Sub
    End If
  
On Error GoTo Errhandler
    With UserList(UserIndex)
        'This packet contains strings, make a copy of the data to prevent losses if it's not complete yet...
        Dim buffer As New clsByteQueue
        Call buffer.CopyBuffer(.incomingData)
      
        'Remove packet ID
        Call buffer.ReadByte
      
        Dim desc As String
        Dim GuildName As String
        Dim site As String
        Dim codex() As String
        Dim errorStr As String
        Dim R As Byte
        Dim G As Byte
        Dim B As Byte
        'Dim color As Long
      
        desc = buffer.ReadASCIIString()
        GuildName = Trim$(buffer.ReadASCIIString())
        site = buffer.ReadASCIIString()
        R = buffer.ReadByte()
        G = buffer.ReadByte()
        B = buffer.ReadByte()
       ' color = RGB(r, g, b)
        codex = Split(buffer.ReadASCIIString(), SEPARATOR)
      
        If modGuilds.CrearNuevoClan(UserIndex, desc, GuildName, site, codex, .FundandoGuildAlineacion, errorStr, R, G, B) Then
            Call SendData(SendTarget.ToAll, UserIndex, PrepareMessageConsoleMsg(.name & " fundó el clan " & GuildName & " de alineación " & modGuilds.GuildAlignment(.GuildIndex) & ".", FontTypeNames.FONTTYPE_GUILD))
            Call SendData(SendTarget.ToAll, 0, PrepareMessagePlayWave(44, NO_3D_SOUND, NO_3D_SOUND))

          
            'Update tag
             Call RefreshCharStatus(UserIndex)
        Else
            Call WriteConsoleMsg(UserIndex, errorStr, FontTypeNames.FONTTYPE_GUILD)
        End If
      
        'If we got here then packet is complete, copy data back to original queue
        Call .incomingData.CopyBuffer(buffer)
    End With
  
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

En la ClsClan declaran:

Código:
Private p_GuildColor                As Long 'color


Reemplazan el Sub Incializar, de la ClsClan por este:
Código:

Public Sub Inicializar(ByVal GuildName As String, _
                       ByVal GuildNumber As Integer, _
                       ByVal Alineacion As ALINEACION_GUILD, ByVal color As Long)
Dim i As Integer

    p_GuildName = GuildName
    p_GuildNumber = GuildNumber
    p_Alineacion = Alineacion
    p_GuildColor = color
  
    Set p_OnlineMembers = New Collection
    Set p_GMsOnline = New Collection
    Set p_PropuestasDePaz = New Collection
    Set p_PropuestasDeAlianza = New Collection
    'ALLIESFILE = GUILDPATH & p_GuildName & "-Allied.all"
    'ENEMIESFILE = GUILDPATH & p_GuildName & "-enemys.ene"
    RELACIONESFILE = GUILDPATH & p_GuildName & "-relaciones.rel"
    MEMBERSFILE = GUILDPATH & p_GuildName & "-members.mem"
    PROPUESTASFILE = GUILDPATH & p_GuildName & "-propositions.pro"
    SOLICITUDESFILE = GUILDPATH & p_GuildName & "-solicitudes.sol"
    VOTACIONESFILE = GUILDPATH & p_GuildName & "-votaciones.vot"
    p_IteradorOnlineMembers = 0
    p_IteradorPropuesta = 0
    p_IteradorOnlineGMs = 0
    p_IteradorRelaciones = 0
    ReDim Preserve p_Relaciones(1 To CANTIDADDECLANES) As RELACIONES_GUILD
    For i = 1 To CANTIDADDECLANES
        p_Relaciones(i) = String2Relacion(GetVar(RELACIONESFILE, "RELACIONES", CStr(i)))
    Next i
    For i = 1 To CANTIDADDECLANES
        If Trim$(GetVar(PROPUESTASFILE, CStr(i), "Pendiente")) = "1" Then
            Select Case String2Relacion(Trim$(GetVar(PROPUESTASFILE, CStr(i), "Tipo")))
                Case RELACIONES_GUILD.ALIADOS
                    p_PropuestasDeAlianza.Add i
                Case RELACIONES_GUILD.PAZ
                    p_PropuestasDePaz.Add i
            End Select
        End If
    Next i
End Sub

Buscan en la ClsClan:

Código:
   Call WriteVar(GUILDINFOFILE, "GUILD" & NewQ, "Alineacion", Alineacion2String(p_Alineacion))

Abajo:

Código:
   Call WriteVar(GUILDINFOFILE, "GUILD" & NewQ, "Color", p_GuildColor)

Agregan en la ClsClan:

Código:

Public Property Get GuildColor() As Long
    GuildColor = p_GuildColor
End Property

Cliente:
de
Reemplazan el HandleUpdateTagAndStatus por este:

Código:

''
' Handles the UpdateTag message.

Private Sub HandleUpdateTagAndStatus()
'***************************************************
'Author: Juan Martín Sotuyo Dodero (Maraxus)
'Last Modification: 05/17/06
'
'***************************************************
    If incomingData.length < 9 Then
        Err.Raise incomingData.NotEnoughDataErrCode
        Exit Sub
    End If
  
On Error GoTo ErrHandler
    'This packet contains strings, make a copy of the data to prevent losses if it's not complete yet...
    Dim Buffer As New clsByteQueue
    Call Buffer.CopyBuffer(incomingData)
  
    'Remove packet ID
    Call Buffer.ReadByte
  
    Dim CharIndex As Integer
    Dim NickColor As Byte
    Dim UserTag As String
    Dim color As Long
  
    CharIndex = Buffer.ReadInteger()
    NickColor = Buffer.ReadByte()
    UserTag = Buffer.ReadASCIIString()
    color = RGB(Buffer.ReadByte(), Buffer.ReadByte(), Buffer.ReadByte())
  
    If color > 0 Then GuildColor = color
  
    'Update char status adn tag!
    With charlist(CharIndex)
        If (NickColor And eNickColor.ieCriminal) <> 0 Then
            .Criminal = 1
        Else
            .Criminal = 0
        End If
      
        .Atacable = (NickColor And eNickColor.ieAtacable) <> 0
      
        .Nombre = UserTag
    End With
  
    'If we got here then packet is complete, copy data back to original queue
    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


Reemplazan el Private Sub HandleCharacterCreate por este:
Código:

''
' Handles the CharacterCreate message.

Private Sub HandleCharacterCreate()
'***************************************************
'Author: Juan Martín Sotuyo Dodero (Maraxus)
'Last Modification: 05/17/06
'
'***************************************************

    If incomingData.length < 27 Then
        Err.Raise incomingData.NotEnoughDataErrCode
        Exit Sub
    End If

  
On Error GoTo ErrHandler
    'This packet contains strings, make a copy of the data to prevent losses if it's not complete yet...
    Dim Buffer As New clsByteQueue
    Call Buffer.CopyBuffer(incomingData)
  
    'Remove packet ID
    Call Buffer.ReadByte
  
    Dim CharIndex As Integer
    Dim Body As Integer
    Dim Head As Integer
    Dim Heading As E_Heading
    Dim X As Byte
    Dim Y As Byte
    Dim weapon As Integer
    Dim shield As Integer
    Dim helmet As Integer
    Dim privs As Integer
    Dim NickColor As Byte
    Dim color As Long

    CharIndex = Buffer.ReadInteger()
    Body = Buffer.ReadInteger()
    Head = Buffer.ReadInteger()
    Heading = Buffer.ReadByte()
    X = Buffer.ReadByte()
    Y = Buffer.ReadByte()
    weapon = Buffer.ReadInteger()
    shield = Buffer.ReadInteger()
    helmet = Buffer.ReadInteger()
  
  
    With charlist(CharIndex)
        Call SetCharacterFx(CharIndex, Buffer.ReadInteger(), Buffer.ReadInteger())
      
        .Nombre = Buffer.ReadASCIIString()
        NickColor = Buffer.ReadByte()
      
        If (NickColor And eNickColor.ieCriminal) <> 0 Then
            .Criminal = 1
        Else
            .Criminal = 0
        End If
      
        .Atacable = (NickColor And eNickColor.ieAtacable) <> 0
      
        privs = Buffer.ReadByte()
        color = RGB(Buffer.ReadByte(), Buffer.ReadByte(), Buffer.ReadByte())
      
        If color > 0 Then GuildColor = color
      
        If privs <> 0 Then
            'If the player belongs to a council AND is an admin, only whos as an admin
            If (privs And PlayerType.ChaosCouncil) <> 0 And (privs And PlayerType.User) = 0 Then
                privs = privs Xor PlayerType.ChaosCouncil
            End If
          
            If (privs And PlayerType.RoyalCouncil) <> 0 And (privs And PlayerType.User) = 0 Then
                privs = privs Xor PlayerType.RoyalCouncil
            End If
          
            'If the player is a RM, ignore other flags
            If privs And PlayerType.RoleMaster Then
                privs = PlayerType.RoleMaster
            End If
          
            'Log2 of the bit flags sent by the server gives our numbers ^^
            .priv = Log(privs) / Log(2)
        Else
            .priv = 0
        End If
    End With
  
    Call MakeChar(CharIndex, Body, Head, Heading, X, Y, weapon, shield, helmet)
  
    Call RefreshAllChars
  
    'If we got here then packet is complete, copy data back to original queue
    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

En el modulo declaraciones:

Código:
Public GuildColor As Long

Buscan:

Código:
                           Call RenderTextCentered(PixelOffsetX + TilePixelWidth \ 2 + 5, PixelOffsetY + 45, line, Color, frmMain.font)

Reemplazan toda la linea que aparezca por esta:

Código:
                           Call RenderTextCentered(PixelOffsetX + TilePixelWidth \ 2 + 5, PixelOffsetY + 45, line, GuildColor, frmMain.font)

En el código del frmGuildDetails, al final agregan:
Código:

Private Sub view_color_Click()

    If colors_allowed.Text = "COLORES" Then
        MsgBox "Seleccione un color", vbCritical, "Error"
        Exit Sub
    End If

    'Establecemos colores.
    Select Case colors_allowed.ListIndex
  
        Case 0 'Rojo
            Red = 255
            Green = 0
            Blue = 0
          
        Case 1 'Verde
            Red = 0
            Green = 255
            Blue = 0
          
        Case 2 'Azul
            Red = 0
            Green = 128
            Blue = 255
          
        Case 3 'Violeta
            Red = 140
            Green = 86
            Blue = 138
          
        Case 4 'Amarillo
            Red = 229
            Green = 190
            Blue = 1
          
        Case 5 'Celeste
            Red = 50
            Green = 150
            Blue = 255
          
        Case 6 'Naranja
            Red = 236
            Green = 124
            Blue = 38
          
        Case 7 'Dorado
            Red = 255
            Green = 215
            Blue = 0
          
        Case 8 'Marrón
            Red = 141
            Green = 73
            Blue = 37
          
        Case 9 'Gris
            Red = 100
            Green = 100
            Blue = 100
          
        Case 10 'Verde Oscuro
            Red = 0
            Green = 145
            Blue = 80
          
        Case 11 'Rosa
            Red = 247
            Green = 190
            Blue = 190
          
    End Select
  
    view_color_lbl.BackColor = RGB(Red, Green, Blue)
  
    'Call WriteCreate blbla
  
End Sub

En el mismo modulo, en la parte de arriba en las declaraciones, declaran:

Código:

Private Red As Byte
Private Green As Byte
Private Blue As Byte

Reemplazan el Private Sub imgConfirmar_Click() por este:

Código:

Private Sub imgConfirmar_Click()
    Dim fdesc As String
    Dim Codex() As String
    Dim k As Byte
    Dim Cont As Byte

    fdesc = Replace(txtDesc, vbCrLf, "º", , , vbBinaryCompare)
  
    Cont = 0
    For k = 0 To txtCodex1.UBound
        If LenB(txtCodex1(k).Text) <> 0 Then Cont = Cont + 1
    Next k
  
    If Cont < 4 Then
        MsgBox "Debes definir al menos cuatro mandamientos."
        Exit Sub
    End If
              
    ReDim Codex(txtCodex1.UBound) As String
    For k = 0 To txtCodex1.UBound
        Codex(k) = txtCodex1(k)
    Next k

    If CreandoClan Then
        Call WriteCreateNewGuild(fdesc, ClanName, Site, Codex, Red, Green, Blue)
    Else
        Call WriteClanCodexUpdate(fdesc, Codex)
    End If

    CreandoClan = False
    Unload Me
End Sub

Ahora descargan esto:

http://www.mediafire.com/download/opcw675pkssqu8t/Controles.rar

Y copian el ComboBox, CommandButton y el Label y lo pegan en el formulario frmGuildsDetails.

Ahora en la carpeta server van a dats y hacen un documento de texto llamado: ColorsGuilds

y de contenido le ponen esto:

Código:

[RED]
Red1=254
Red2=0
Red3=0
Red4=140
Red5=229
Red6=50
Red7=236
Red8=255
Red9=141
Red10=100
Red11=0
Red12=247

[GREEN]
Green1=0
Green2=255
Green3=0
Green4=86
Green5=190
Green6=150
Green7=124
Green8=215
Green9=73
Green10=100
Green11=145
Green12=191

[BLUE]
Blue1=0
Blue2=0
Blue3=255
Blue4=138
Blue5=1
Blue6=255
Blue7=38
Blue8=0
Blue9=37
Blue10=100
Blue11=80
Blue12=190

Listo!, cualquier cosa avisan.
avatar
Toyz
Administrador
Administrador

¿BANEADO? : No.
Premios :
[1er puesto] Usuario del año 2016
Cantidad de envíos : 5045
Edad : 17
Localización : Global.
Fecha de inscripción : 28/09/2014

Ver perfil de usuario

Volver arriba Ir abajo

Volver arriba


 
Permisos de este foro:
No puedes responder a temas en este foro.