Aldeia RPG

Gostaria de reagir a esta mensagem? Crie uma conta em poucos cliques ou inicie sessão para continuar.

Suporte ao desenvolvimento de jogos


+6
Motodark
Snoopy
Spooky
Valentine
Hashirama
Dooolly
10 participantes

    [GL]Titulos 0.1.0

    Dooolly
    Dooolly
    Colaborador
    Colaborador


    Medalhas : [GL]Titulos 0.1.0 Trophy12
    Mensagens : 1227
    Créditos : 153

    Ficha do personagem
    Nível: 1
    Experiência:
    [GL]Titulos 0.1.0 Left_bar_bleue0/0[GL]Titulos 0.1.0 Empty_bar_bleue  (0/0)
    Vida:
    [GL]Titulos 0.1.0 Left_bar_bleue30/30[GL]Titulos 0.1.0 Empty_bar_bleue  (30/30)

    [GL]Titulos 0.1.0 Empty [GL]Titulos 0.1.0

    Mensagem por Dooolly Seg Jan 19, 2015 10:52 am


    Nome: Sistema de Títulos
    Versão: 0.1.0
    Criador: GameLoop
    Creditos: Dooolly

    Informações
    Esse sistema dá títulos para os jogadores, e cada titulo
    poderia ter uma bonificação diferente.

    Exemplo

    Spoiler:
    Spoiler:

    Tutorial

    Server-Side

    Em modCombat procure por:
    Código:
    Function GetPlayerMaxVital(ByVal index As Long, ByVal Vital As Vitals) As Long
     
        If index > MAX_PLAYERS Then Exit Function

    Abaixo adicione:
    Código:
    Dim AddHP As Byte
        
        If Player(index).UseTitulo > 0 Then
            AddHP = Titulo(Player(index).UseTitulo).AddHP
        End If

    Em modConstant procure por:
    Código:
    Public Const MAX_PARTY_MEMBERS As Long = 4

    Abaixo adicione:
    Código:
    Public Const MAX_TITULOS As Long = 50

    No final de modDatabase adicione:
    Código:

    ' *************
    ' ** Titulos **
    ' *************
    Sub SaveTitulo(ByVal TituloNum As Long)
        Dim filename As String
        Dim F As Long
        filename = App.Path & "\data\titulos\titulo" & TituloNum & ".dat"
        F = FreeFile
        Open filename For Binary As #F
        Put #F, , Titulo(TituloNum)
        Close #F
    End Sub

    Sub SaveTitulos()
        Dim i As Long
        Call SetStatus("Salvando Titulos... ")

        For i = 1 To MAX_TITULOS
            Call SaveTitulo(i)
        Next

    End Sub

    Sub LoadTitulos()
        Dim filename As String
        Dim i As Long
        Dim F As Long
        Call CheckTitulos

        For i = 1 To MAX_TITULOS
            filename = App.Path & "\data\titulos\titulo" & i & ".dat"
            F = FreeFile
            Open filename For Binary As #F
            Get #F, , Titulo(i)
            Close #F
        Next

    End Sub

    Sub CheckTitulos()
        Dim i As Long

        For i = 1 To MAX_TITULOS

            If Not FileExist("\Data\titulos\titulo" & i & ".dat") Then
                Call SaveTitulo(i)
            End If

        Next

    End Sub

    Sub ClearTitulo(ByVal index As Long)
        Call ZeroMemory(ByVal VarPtr(Titulo(index)), LenB(Titulo(index)))
        Titulo(index).Nome = vbNullString
    End Sub

    Sub ClearTitulos()
        Dim i As Long

        For i = 1 To MAX_TITULOS
            Call ClearTitulo(i)
        Next

    End Sub

    Em modEnumerations antes de SMSG_COUNT adicione:
    Código:
    STitulos
        SUpdateTitulo
        STituloEditor

    Ainda em modEnumerations antes de CMSG_COUNT adicione:
    Código:
    CRequestTitulos
        CSaveTitulo
        CRequestEditTitulo
        CTitulos
        CUseTitulo

    Em modGeneral procure por:
    Código:
    ChkDir App.Path & "\Data", "spells"

    Abaixo adicione:
    Código:
    ChkDir App.Path & "\Data", "titulos"

    Ainda em modGeneral procure por:
    Código:
    Call ClearAnimations

    Abaixo adicione:
    Código:
    Call SetStatus("Limpando Titulos...")
        Call ClearTitulos

    Ainda em modGeneral procure por:
    Código:
    Call LoadAnimations

    Abaixo adicione:
    Código:
    Call SetStatus("Carregando Titulos...")
        Call LoadTitulos

    Em modHandleData procure por:
    Código:
    HandleDataSub(CPartyLeave) = GetAddress(AddressOf HandlePartyLeave)

    Abaixo adicione:
    Código:
    HandleDataSub(CRequestTitulos) = GetAddress(AddressOf HandleRequestTitulos)
        HandleDataSub(CSaveTitulo) = GetAddress(AddressOf HandleSaveTitulo)
        HandleDataSub(CRequestEditTitulo) = GetAddress(AddressOf HandleRequestEditTitulo)
        HandleDataSub(CTitulos) = GetAddress(AddressOf HandleTitulos)
        HandleDataSub(CUseTitulo) = GetAddress(AddressOf HandleUseTitulo)

    No final de modHandleData adicione:
    Código:
    ' Titulos
    Sub HandleRequestTitulos(ByVal index As Long, ByRef Data() As Byte, ByVal StartAddr As Long, ByVal ExtraVar As Long)
        SendTitulos index
    End Sub

    Sub HandleSaveTitulo(ByVal index As Long, ByRef Data() As Byte, ByVal StartAddr As Long, ByVal ExtraVar As Long)
        Dim TituloNum As Long
        Dim Buffer As clsBuffer
        Dim TituloSize As Long
        Dim TituloData() As Byte

        ' Prevent hacking
        If GetPlayerAccess(index) < ADMIN_DEVELOPER Then
            Exit Sub
        End If

        Set Buffer = New clsBuffer
        Buffer.WriteBytes Data()
        TituloNum = Buffer.ReadLong

        ' Prevent hacking
        If TituloNum < 0 Or TituloNum > MAX_TITULOS Then
            Exit Sub
        End If

        TituloSize = LenB(Titulo(TituloNum))
        ReDim TituloData(TituloSize - 1)
        TituloData = Buffer.ReadBytes(TituloSize)
        CopyMemory ByVal VarPtr(Titulo(TituloNum)), ByVal VarPtr(TituloData(0)), TituloSize
        ' Save it
        Call SendUpdateTituloToAll(TituloNum)
        Call SaveTitulo(TituloNum)
        Call AddLog(GetPlayerName(index) & " saved Titulo #" & TituloNum & ".", ADMIN_LOG)
    End Sub

    Sub HandleRequestEditTitulo(ByVal index As Long, ByRef Data() As Byte, ByVal StartAddr As Long, ByVal ExtraVar As Long)
        Dim Buffer As clsBuffer

        ' Prevent hacking
        If GetPlayerAccess(index) < ADMIN_DEVELOPER Then
            Exit Sub
        End If

        Set Buffer = New clsBuffer
        Buffer.WriteLong STituloEditor
        SendDataTo index, Buffer.ToArray()
        Set Buffer = Nothing
    End Sub

    Sub HandleTitulos(ByVal index As Long, ByRef Data() As Byte, ByVal StartAddr As Long, ByVal ExtraVar As Long)
        Call SendPlayerTitulos(index)
    End Sub

    Sub HandleUseTitulo(ByVal index As Long, ByRef Data() As Byte, ByVal StartAddr As Long, ByVal ExtraVar As Long)
        Dim n As Long
        Dim Player As Long
        Dim Buffer As clsBuffer
        Set Buffer = New clsBuffer
        Buffer.WriteBytes Data()

        ' The sprite
        n = Buffer.ReadLong 'CLng(Parse(1))
        Player = Buffer.ReadLong
        Set Buffer = Nothing
        Call SetPlayerTitulo(Player, n)
        Call SendPlayerData(index)
        Exit Sub
    End Sub

    Em modPlayer procure por:
    Código:
    Call SendHotbar(index)

    Abaixo adicione:
    Código:
    Call SendTitulos(index)

    No final de modPlayer adicione:
    Código:
    Sub SetPlayerTitulo(ByVal index As Long, ByVal TituloNum As Long)
     If Player(index).UseTitulo > 0 Then
      Player(index).Vital(1) = Player(index).Vital(1) - Titulo(Player(index).UseTitulo).AddHP
     End If
     
     Player(index).UseTitulo = TituloNum
     
     If Titulo(Player(index).UseTitulo).AddHP > 0 Then
      Player(index).Vital(1) = Player(index).Vital(1) + Titulo(Player(index).UseTitulo).AddHP
     End If
    End Sub

    Function GetPlayerTitulos(ByVal index As Long, ByVal TituloSlot As Long) As Long

        If index > MAX_PLAYERS Then Exit Function
        GetPlayerTitulos = Player(index).Titulos(TituloSlot)
    End Function

    Function GetPlayerTitulo(ByVal index As Long) As Long

        If index > MAX_PLAYERS Then Exit Function
        GetPlayerTitulo = Player(index).UseTitulo
    End Function

    Sub AddPlayerTitulo(ByVal index As Long, ByVal TituloNum As Long)
    Dim i As Long

     If index > MAX_PLAYERS Then Exit Sub
     
      For i = 1 To MAX_TITULOS
       If Player(index).Titulos(i) = TituloNum Then
          PlayerMsg index, "Você já tem esse titulo!", BrightRed
          Exit Sub
       End If
      
       If Player(index).Titulos(i) <= 0 Then
          Player(index).Titulos(i) = TituloNum
          PlayerMsg index, "Parabéns você ganhou um novo titulo: " & Titulo(TituloNum).Nome, BrightGreen
          Exit Sub
       End If
      Next
    End Sub

    Em modServerTCP procure por:
    Código:
    Buffer.WriteLong GetPlayerClass(index)

    Abaixo adicione:
    Código:
    Buffer.WriteLong GetPlayerTitulo(index)

    No final de modServerTCP adicione:
    Código:
    '///////////////////////////////////////////////
    '///// Titulos /////////////////////////////////
    '///////////////////////////////////////////////

    Sub SendTitulos(ByVal index As Long)
        Dim i As Long

        For i = 1 To MAX_TITULOS

            If LenB(Trim$(Titulo(i).Nome)) > 0 Then
                Call SendUpdateTituloTo(index, i)
            End If

        Next

    End Sub

    Sub SendUpdateTituloToAll(ByVal TituloNum As Long)
        Dim packet As String
        Dim Buffer As clsBuffer
        Set Buffer = New clsBuffer
        Dim TituloSize As Long
        Dim TituloData() As Byte
        
        Set Buffer = New clsBuffer
        
        TituloSize = LenB(Titulo(TituloNum))
        ReDim TituloData(TituloSize - 1)
        CopyMemory TituloData(0), ByVal VarPtr(Titulo(TituloNum)), TituloSize
        
        Buffer.WriteLong SUpdateTitulo
        Buffer.WriteLong TituloNum
        Buffer.WriteBytes TituloData
        
        SendDataToAll Buffer.ToArray()
        Set Buffer = Nothing
    End Sub

    Sub SendUpdateTituloTo(ByVal index As Long, ByVal TituloNum As Long)
        Dim packet As String
        Dim Buffer As clsBuffer
        Dim TituloSize As Long
        Dim TituloData() As Byte
        
        Set Buffer = New clsBuffer
        
        TituloSize = LenB(Titulo(TituloNum))
        ReDim TituloData(TituloSize - 1)
        CopyMemory TituloData(0), ByVal VarPtr(Titulo(TituloNum)), TituloSize
        
        Buffer.WriteLong SUpdateTitulo
        Buffer.WriteLong TituloNum
        Buffer.WriteBytes TituloData
        
        SendDataTo index, Buffer.ToArray()
        Set Buffer = Nothing
    End Sub

    Sub SendPlayerTitulos(ByVal index As Long)
        Dim packet As String
        Dim i As Long
        Dim Buffer As clsBuffer
        Set Buffer = New clsBuffer
        Buffer.WriteLong STitulos

        For i = 1 To MAX_TITULOS
            Buffer.WriteLong GetPlayerTitulos(index, i)
        Next

        SendDataTo index, Buffer.ToArray()
        Set Buffer = Nothing
    End Sub

    '//////////////////////////////////////////////

    Em modTypes procure por:
    Código:
    Public Party(1 To MAX_PARTYS) As PartyRec

    Abaixo adicione:
    Código:
    Public Titulo(1 To MAX_TITULOS) As TitulosRec

    Ainda na modTypes logo na PlayeRec procure por:
    Código:
    Dir As Byte

    Abaixo adicione:
    Código:

        ' Titulos
        UseTitulo As Long
        Titulos(1 To MAX_TITULOS) As Long

    No final da modTypes adicione:
    Código:
    Public Type TitulosRec
        Nome As String * NAME_LENGTH
        Cor As Byte
        AddHP As Byte
    End Type

    Servidor Terminado!

    Client-Side

    Baixe esse arquivo antes: Titulo Files.rar

    Adicione as duas forms em seu projeto!

    Dê um CTRL + X no picTitulos que está dentro do Form1
    Depois dê um CTRL + V na frmMain
    Posicione onde você quiser. Lembre-se de verificar se você está com
    o frmMain selecionado, você não pode por dentro de outra coisa, apenas no frmMain


    Crie um botão e adicione:
    Código:
    picCharacter.Visible = False
                picInventory.Visible = False
                picSpells.Visible = False
                picOptions.Visible = False
                picParty.Visible = False
                ' picQuestLog.Visible = False
                picTitulo.Visible = True
                ' send packet
                    Set Buffer = New clsBuffer
                    Buffer.WriteLong CTitulos
                    SendData Buffer.ToArray()
                    Set Buffer = Nothing
                    ' show the window
                PlaySound Sound_ButtonClick

    Abra o código dá frmMain e no final adicione:
    Código:
    ' Titulos
    Private Sub cmbUsarTitulo_Click()
    Dim Titulo As Long
        ' If debug mode, handle error then exit out
        If Options.Debug = 1 Then On Error GoTo errorhandler

        If Trim$(lstTitulo.text) = vbNullString Then Exit Sub
           Titulo = GetTituloNum(lstTitulo.text)
           UseTitulo MyIndex, Titulo
        
        ' Error handler
        Exit Sub
    errorhandler:
        HandleError "cmbUsarTitulo_Click", "frmMain", Err.Number, Err.Description, Err.Source, Err.HelpContext
        Err.Clear
        Exit Sub
    End Sub

    Em modConstant procure por:
    Código:
    Public Const MAX_PARTY_MEMBERS As Long = 4

    Abaixo adicione:
    Código:
    Public Const MAX_TITULOS As Long = 50

    Ainda em modConstant procure por:
    Código:
    Public Const EDITOR_ANIMATION As Byte = 6

    Abaixo adicione:
    Código:
    Public Const EDITOR_TITULOS As Byte = 7

    Em modEnumerations antes de SMSG_COUNT adicione:
    Código:
    STitulos
        SUpdateTitulo
        STituloEditor

    Ainda em modEnumerations antes de CMSG_COUNT adicione:
    Código:
    CRequestTitulos
        CSaveTitulo
        CRequestEditTitulo
        CTitulos
        CUseTitulo

    No final do modClientTCP adicione:
    Código:
    ' ##### Titulo #####
    Public Sub UseTitulo(ByVal Index As Long, ByVal TituloNum As Long)
    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 CUseTitulo
        Buffer.WriteLong TituloNum
        Buffer.WriteLong Index
        SendData Buffer.ToArray()
        Set Buffer = Nothing
        
        ' Error handler
        Exit Sub
    errorhandler:
        HandleError "UseTitulo", "modClientTCP", Err.Number, Err.Description, Err.Source, Err.HelpContext
        Err.Clear
        Exit Sub
    End Sub

    Public Sub SendRequestEditTitulo()
    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 CRequestEditTitulo
        SendData Buffer.ToArray()
        Set Buffer = Nothing
        
        ' Error handler
        Exit Sub
    errorhandler:
        HandleError "SendRequestEditTitulo", "modClientTCP", Err.Number, Err.Description, Err.Source, Err.HelpContext
        Err.Clear
        Exit Sub
    End Sub

    Public Sub SendSaveTitulo(ByVal TituloNum As Long)
    Dim Buffer As clsBuffer
    Dim TituloSize As Long
    Dim TituloData() As Byte
        
        ' If debug mode, handle error then exit out
        If Options.Debug = 1 Then On Error GoTo errorhandler
        
        Set Buffer = New clsBuffer
        TituloSize = LenB(Titulo(TituloNum))
        ReDim TituloData(TituloSize - 1)
        CopyMemory TituloData(0), ByVal VarPtr(Titulo(TituloNum)), TituloSize
        
        Buffer.WriteLong CSaveTitulo
        Buffer.WriteLong TituloNum
        Buffer.WriteBytes TituloData
        SendData Buffer.ToArray()
        
        Set Buffer = Nothing
        
        ' Error handler
        Exit Sub
    errorhandler:
        HandleError "SendSaveTitulo", "modClientTCP", Err.Number, Err.Description, Err.Source, Err.HelpContext
        Err.Clear
        Exit Sub
    End Sub

    Sub SendRequestTitulos()
    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 CRequestTitulos
        SendData Buffer.ToArray()
        Set Buffer = Nothing
        
        ' Error handler
        Exit Sub
    errorhandler:
        HandleError "SendRequestTitulos", "modClientTCP", Err.Number, Err.Description, Err.Source, Err.HelpContext
        Err.Clear
        Exit Sub
    End Sub
    ' #################

    No final de modDatabase adicione:
    Código:
    ' ##### Titulos #####

    Sub ClearTitulos()
    Dim i As Long

        ' If debug mode, handle error then exit out
        If Options.Debug = 1 Then On Error GoTo errorhandler

        For i = 1 To MAX_TITULOS
            Call ClearTitulo(i)
        Next

        ' Error handler
        Exit Sub
    errorhandler:
        HandleError "ClearTitulos", "modDatabase", Err.Number, Err.Description, Err.Source, Err.HelpContext
        Err.Clear
        Exit Sub
    End Sub

    Sub ClearTitulo(ByVal Index As Long)
        ' If debug mode, handle error then exit out
        If Options.Debug = 1 Then On Error GoTo errorhandler

        Call ZeroMemory(ByVal VarPtr(Titulo(Index)), LenB(Titulo(Index)))
        Titulo(Index).Nome = vbNullString
        
        ' Error handler
        Exit Sub
    errorhandler:
        HandleError "ClearTitulo", "modDatabase", Err.Number, Err.Description, Err.Source, Err.HelpContext
        Err.Clear
        Exit Sub
    End Sub

    Sub SetPlayerTitulo(ByVal Index As Long, ByVal Titulo As String)
        ' If debug mode, handle error then exit out
        If Options.Debug = 1 Then On Error GoTo errorhandler

        If Index > MAX_PLAYERS Then Exit Sub
        Player(Index).UseTitulo = Titulo
        
        ' Error handler
        Exit Sub
    errorhandler:
        HandleError "SetPlayerTitulo", "modDatabase", Err.Number, Err.Description, Err.Source, Err.HelpContext
        Err.Clear
        Exit Sub
    End Sub

    Public Function GetTituloNum(ByVal TituloName As String) As Long
        Dim i As Long
        GetTituloNum = 0
        
        For i = 1 To MAX_TITULOS
            If Trim$(Titulo(i).Nome) = Trim$(TituloName) Then
                GetTituloNum = i
                Exit For
            End If
        Next
    End Function
    '###############

    No final de modGameEditors adicione:
    Código:
    ' ////////////////////
    ' // Titulos Editor //
    ' ////////////////////
    Public Sub TituloEditorInit()
        
        ' If debug mode, handle error then exit out
        If Options.Debug = 1 Then On Error GoTo errorhandler

        If frmEditor_Titulos.Visible = False Then Exit Sub
        EditorIndex = frmEditor_Titulos.lstIndex.ListIndex + 1
        
        With frmEditor_Titulos
            ' set values
            .txtNome.text = Trim$(Titulo(EditorIndex).Nome)
            .optCor(Titulo(EditorIndex).Cor).Value = True
            .scrlHP.Value = Titulo(EditorIndex).AddHP
        End With
        
        Titulo_Changed(EditorIndex) = True
        
        ' Error handler
        Exit Sub
    errorhandler:
        HandleError "TituloEditorInit", "modGameEditors", Err.Number, Err.Description, Err.Source, Err.HelpContext
        Err.Clear
        Exit Sub
    End Sub

    Public Sub TitulosEditorOk()
    Dim i As Long

        ' If debug mode, handle error then exit out
        If Options.Debug = 1 Then On Error GoTo errorhandler

        For i = 1 To MAX_TITULOS
            If Titulo_Changed(i) Then
                Call SendSaveTitulo(i)
            End If
        Next
        
        Unload frmEditor_Titulos
        Editor = 0
        ClearChanged_Titulo
        
        ' Error handler
        Exit Sub
    errorhandler:
        HandleError "TitulosEditorOk", "modGameEditors", Err.Number, Err.Description, Err.Source, Err.HelpContext
        Err.Clear
        Exit Sub
    End Sub

    Public Sub TituloEditorCancel()
        ' If debug mode, handle error then exit out
        If Options.Debug = 1 Then On Error GoTo errorhandler

        Editor = 0
        Unload frmEditor_Titulos
        ClearChanged_Titulo
        ClearTitulos
        SendRequestTitulos
        
        ' Error handler
        Exit Sub
    errorhandler:
        HandleError "TituloEditorCancel", "modGameEditors", Err.Number, Err.Description, Err.Source, Err.HelpContext
        Err.Clear
        Exit Sub
    End Sub

    Public Sub ClearChanged_Titulo()
        ' If debug mode, handle error then exit out
        If Options.Debug = 1 Then On Error GoTo errorhandler

        ZeroMemory Titulo_Changed(1), MAX_TITULOS * 2 ' 2 = boolean length
        
        ' Error handler
        Exit Sub
    errorhandler:
        HandleError "ClearChanged_Titulo", "modGameEditors", Err.Number, Err.Description, Err.Source, Err.HelpContext
        Err.Clear
        Exit Sub
    End Sub

    No final de modGlobals adicione:
    Código:
    ' Titulos
    Public PlayerTitulos(1 To MAX_TITULOS) As Long
    Public Titulo_Changed(1 To MAX_TITULOS) As Boolean

    Em modHandledata procure por:
    Código:
    HandleDataSub(SPartyVitals) = GetAddress(AddressOf HandlePartyVitals)

    Abaixo adicione:
    Código:
    '/////////////////////
        HandleDataSub(STitulos) = GetAddress(AddressOf HandleTitulos)
        HandleDataSub(SUpdateTitulo) = GetAddress(AddressOf HandleUpdateTitulo)
        HandleDataSub(STituloEditor) = GetAddress(AddressOf HandleTituloEditor)

    Ainda em modHandledata procure por:
    Código:
    Call SetPlayerClass(i, Buffer.ReadLong)

    Abaixo adicione:
    Código:
    Call SetPlayerTitulo(i, Buffer.ReadLong)

    No final do modHandledata adicione:
    Código:
    ' ##### Titulos #####
    Private Sub HandleUpdateTitulo(ByVal Index As Long, ByRef Data() As Byte, ByVal StartAddr As Long, ByVal ExtraVar As Long)
    Dim TituloNum As Long
    Dim Buffer As clsBuffer
    Dim TituloSize As Long
    Dim TituloData() 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()
        
        TituloNum = Buffer.ReadLong
        
        TituloSize = LenB(Titulo(TituloNum))
        ReDim TituloData(TituloSize - 1)
        TituloData = Buffer.ReadBytes(TituloSize)
        CopyMemory ByVal VarPtr(Titulo(TituloNum)), ByVal VarPtr(TituloData(0)), TituloSize
        Set Buffer = Nothing
        
        ' Update the spells on the pic
        Set Buffer = New clsBuffer
        Buffer.WriteLong CTitulos
        SendData Buffer.ToArray()
        Set Buffer = Nothing
        
        ' Error handler
        Exit Sub
    errorhandler:
        HandleError "HandleUpdateTitulo", "modHandleData", Err.Number, Err.Description, Err.Source, Err.HelpContext
        Err.Clear
        Exit Sub
    End Sub

    Private Sub HandleTituloEditor()
    Dim i As Long

        ' If debug mode, handle error then exit out
        If Options.Debug = 1 Then On Error GoTo errorhandler
        
        With frmEditor_Titulos
            Editor = EDITOR_TITULOS
            .lstIndex.Clear

            ' Add the names
            For i = 1 To MAX_TITULOS
                .lstIndex.AddItem i & ": " & Trim$(Titulo(i).Nome)
            Next

            .Show
            .lstIndex.ListIndex = 0
            TituloEditorInit
        End With

        ' Error handler
        Exit Sub
    errorhandler:
        HandleError "HandleTituloEditor", "modHandleData", Err.Number, Err.Description, Err.Source, Err.HelpContext
        Err.Clear
        Exit Sub
    End Sub

    Sub HandleTitulos(ByVal Index As Long, ByRef Data() As Byte, ByVal StartAddr As Long, ByVal ExtraVar As Long)
    Dim i As Long, TituloName As String
    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.WriteBytes Data()
        
        frmMain.lstTitulo.Clear
        
        For i = 1 To MAX_TITULOS
            Player(MyIndex).Titulos(i) = Buffer.ReadLong
            If Player(MyIndex).Titulos(i) > 0 Then
             TituloName = Trim$(Titulo(Player(MyIndex).Titulos(i)).Nome)
             frmMain.lstTitulo.AddItem TituloName
             TituloName = vbNullString
            End If
        Next
        
        Set Buffer = Nothing
        
        ' Error handler
        Exit Sub
    errorhandler:
        HandleError "HandleTitulos", "modHandleData", Err.Number, Err.Description, Err.Source, Err.HelpContext
        Err.Clear
        Exit Sub
    End Sub
    ' ###############

    Em modText procure por:
    Código:
    ' Draw name
        Call DrawText(TexthDC, TextX, TextY, Name, color)

    Abaixo adicione:
    Código:
    If Player(Index).UseTitulo > 0 Then
          If GetPlayerSprite(Index) < 1 Or GetPlayerSprite(Index) > NumCharacters Then
            TextY = ConvertMapY(GetPlayerY(Index) * PIC_Y) + Player(Index).YOffset - 16 - 14
          Else
            ' Determine location for text
            TextY = ConvertMapY(GetPlayerY(Index) * PIC_Y) + Player(Index).YOffset - (DDSD_Character(GetPlayerSprite(Index)).lHeight / 4) + 16 - 14
          End If
          
          Select Case Titulo(Player(Index).UseTitulo).Cor
             Case 0
               color = QBColor(BrightRed)
             Case 1
               color = QBColor(BrightBlue)
             Case 2
               color = QBColor(Green)
             Case 3
               color = QBColor(Yellow)
             Case 4
               color = QBColor(Pink)
          End Select
          
          Name = Trim$(Titulo(Player(Index).UseTitulo).Nome)
          TextX = ConvertMapX(GetPlayerX(Index) * PIC_X) + Player(Index).XOffset + (PIC_X \ 2) - getWidth(TexthDC, (Trim$(Name)))
          
          Call DrawText(TexthDC, TextX, TextY, Name, color)
        End If

    Em modTypes procure por:
    Código:
    Public Animation(1 To MAX_ANIMATIONS) As AnimationRec

    Abaixo adicione:
    Código:
    Public Titulo(1 To MAX_TITULOS) As TitulosRec

    Ainda na modTypes procure por:
    Código:
    Dir As Byte

    Abaixo adicione:
    Código:
    ' Titulos
        UseTitulo As Long
        Titulos(1 To MAX_TITULOS) As Long

    No final de modTypes adicione:
    Código:
    Public Type TitulosRec
        Nome As String * NAME_LENGTH
        Cor As Byte
        AddHP As Byte
    End Type

    Cliente Terminado!

    Informações
    Para você adicionar um titulo é só você usar o seguinte codigo no Serve-Side
    Código:
    AddPlayerTitulo index, 1 'Onde tem o numero 1 você muda para o numero do titulo.

    Para abrir a frmTitulos é só utilizar o codigo:
    Código:

        If GetPlayerAccess(MyIndex) < ADMIN_DEVELOPER Then
            Exit Sub
        End If

        SendRequestEditTitulo
        

    O Sistema está na versão 0.1.0 então é só um teste, vou está sempre atualizando o sistema, espero que não tenha erros, se tiver comenta ai!

    Depois faço a parte de ganhar o títulos por item, ou por missões dê sua opinião ai!
    Lembrando que se for por missões terá que ser o sistema de quests do alatar.



    Última edição por Dooolly em Sex Mar 18, 2016 10:20 pm, editado 4 vez(es)
    Hashirama
    Hashirama
    Membro de Honra
    Membro de Honra


    Mensagens : 413
    Créditos : 133

    [GL]Titulos 0.1.0 Empty Re: [GL]Titulos 0.1.0

    Mensagem por Hashirama Seg Jan 19, 2015 5:51 pm

    Gostei =D
    mais 1 crédito por compartilhar


    _________________
    Apoia nosso projeto? use nossa assinatura
    Valentine
    Valentine
    Administrador
    Administrador


    Medalhas : [GL]Titulos 0.1.0 ZgLkiRU
    Mensagens : 5343
    Créditos : 1164

    [GL]Titulos 0.1.0 Empty Re: [GL]Titulos 0.1.0

    Mensagem por Valentine Seg Jan 19, 2015 6:43 pm

    Muito bom, mas seria mais interessante modificar a cor RGB digitando em 3 textboxs e essa cor aparecer em uma picturebox.
    Dooolly
    Dooolly
    Colaborador
    Colaborador


    Medalhas : [GL]Titulos 0.1.0 Trophy12
    Mensagens : 1227
    Créditos : 153

    Ficha do personagem
    Nível: 1
    Experiência:
    [GL]Titulos 0.1.0 Left_bar_bleue0/0[GL]Titulos 0.1.0 Empty_bar_bleue  (0/0)
    Vida:
    [GL]Titulos 0.1.0 Left_bar_bleue30/30[GL]Titulos 0.1.0 Empty_bar_bleue  (30/30)

    [GL]Titulos 0.1.0 Empty Re: [GL]Titulos 0.1.0

    Mensagem por Dooolly Seg Jan 19, 2015 7:38 pm

    Valentine escreveu:Muito bom, mas seria mais interessante modificar a cor RGB digitando em 3 textboxs e essa cor aparecer em uma picturebox.

    as cores RGB funcionaria no DX7?
    se sim me passa o codigo que eu modifico isso, e ainda ponho um exemplo em uma picture box...
    Valentine
    Valentine
    Administrador
    Administrador


    Medalhas : [GL]Titulos 0.1.0 ZgLkiRU
    Mensagens : 5343
    Créditos : 1164

    [GL]Titulos 0.1.0 Empty Re: [GL]Titulos 0.1.0

    Mensagem por Valentine Seg Jan 19, 2015 7:44 pm

    Dooolly escreveu:
    Valentine escreveu:Muito bom, mas seria mais interessante modificar a cor RGB digitando em 3 textboxs e essa cor aparecer em uma picturebox.

    as cores RGB funcionaria no DX7?
    se sim me passa o codigo que eu modifico isso, e ainda ponho um exemplo em uma picture box...
    Cara, cria ai 3 variáveis em byte ai na hora de desenhar o nome usa isso:
    Código:
    color = RGB(color1, color2, color3)
    Pronto....


    Última edição por Valentine em Ter Jan 20, 2015 6:28 pm, editado 1 vez(es)
    Spooky
    Spooky
    Membro Ativo
    Membro Ativo


    Mensagens : 267
    Créditos : 24

    [GL]Titulos 0.1.0 Empty Re: [GL]Titulos 0.1.0

    Mensagem por Spooky Ter Jan 20, 2015 1:35 pm

    Uma Dica, ao usar um item conseguir rank e spell (tipo usa o item na categoria de Spell da cmbtype
    e ganha a spell e título. :)
    +2 Very Happy


    _________________
    Sign
    [GL]Titulos 0.1.0 Hticjn

    Sign¹:

    Sign²:
    Snoopy
    Snoopy
    Iniciante
    Iniciante


    Mensagens : 58
    Créditos : 7

    [GL]Titulos 0.1.0 Empty Re: [GL]Titulos 0.1.0

    Mensagem por Snoopy Dom Mar 01, 2015 12:26 am

    aqui está dando o erro "sub or function not defined" no cliente 
    [GL]Titulos 0.1.0 2psn6vb
    Dooolly
    Dooolly
    Colaborador
    Colaborador


    Medalhas : [GL]Titulos 0.1.0 Trophy12
    Mensagens : 1227
    Créditos : 153

    Ficha do personagem
    Nível: 1
    Experiência:
    [GL]Titulos 0.1.0 Left_bar_bleue0/0[GL]Titulos 0.1.0 Empty_bar_bleue  (0/0)
    Vida:
    [GL]Titulos 0.1.0 Left_bar_bleue30/30[GL]Titulos 0.1.0 Empty_bar_bleue  (30/30)

    [GL]Titulos 0.1.0 Empty Re: [GL]Titulos 0.1.0

    Mensagem por Dooolly Dom Mar 01, 2015 11:55 am

    Snoopy escreveu:aqui está dando o erro "sub or function not defined" no cliente 
    [GL]Titulos 0.1.0 2psn6vb

    Desculpe amigo, erro meu!

    Acima de:
    Código:
    Sub SetPlayerTitulo(ByVal Index As Long, ByVal Titulo As String)

    Adicione:
    Código:
    Public Function GetTituloNum(ByVal TituloName As String) As Long
        Dim i As Long
        GetTituloNum = 0
        
        For i = 1 To MAX_TITULOS
            If Trim$(Titulo(i).Nome) = Trim$(TituloName) Then
                GetTituloNum = i
                Exit For
            End If
        Next
    End Function

    Atualizei o tópico!
    Motodark
    Motodark
    Ocasional
    Ocasional


    Mensagens : 169
    Créditos : 5

    [GL]Titulos 0.1.0 Empty Re: [GL]Titulos 0.1.0

    Mensagem por Motodark Seg Mar 02, 2015 4:47 pm

    Muito legal esse seu tutorial, doolly só queria saber como eu deixo meus graficos melhores ? está muito ruim
    Pablo Kawan
    Pablo Kawan
    Experiente
    Experiente


    Mensagens : 480
    Créditos : 158

    [GL]Titulos 0.1.0 Empty Re: [GL]Titulos 0.1.0

    Mensagem por Pablo Kawan Sáb Mar 07, 2015 10:32 am

    Legal, tudo tão bem feito '-'
    só faltou uma coisa
    Suspense:

    ps: nem testei o sistema, mas pela parte programada não vi nada parecido


    _________________
    Assinatura removida pela Staff
    ^ Tenho nova, surprise
    [GL]Titulos 0.1.0 H2D9a9k

    Conteúdo patrocinado


    [GL]Titulos 0.1.0 Empty Re: [GL]Titulos 0.1.0

    Mensagem por Conteúdo patrocinado


      Data/hora atual: Qui Nov 07, 2024 10:34 am