Deathmatch automático [13.0]

Ir abajo

Deathmatch automático [13.0]

Mensaje por Toyz el 14/12/2016, 6:59 pm

Programé esto de 0, espero que les sea de utilidad Razz

ACLARACIÓN: Para poder implementar este aporte deben tener conocimientos de protocolo binario, como hacer llamadas, como hacer variables y leer el módulo completo Razz

Código:
Option Explicit
 '***************
 'AUTOR: Toyz - Luciano
 'FECHA: 11/12/16 - 23:00
 '***************
Private Const Tiempo_Cancelamiento As Integer = 180
Private Const Banquero As Byte = 24

Private Type tUsuario
    ID As Integer
    Posicion As WorldPos
End Type

Private Type tDeathmatch
    Activo As Boolean
    Usuarios() As tUsuario
    Objetos As Boolean
    Conteo As Integer
    Cupos As Byte
    Coordenadas As WorldPos
    Premio As Long
    Inscripcion As Long
    Total As Byte
    Restantes As Byte
    Pos_Banquero As WorldPos
End Type

Private Deathmatch As tDeathmatch

Public Sub Carga_Death()
    Dim Leer As clsIniReader
    Set Leer = New clsIniReader
    Call Leer.Initialize(App.Path & "\Dat\DeathMatch.dat")
    With Deathmatch.Coordenadas
        .Map = CInt(Leer.GetValue("EVENTO", "Mapa"))
        .X = CByte(Leer.GetValue("EVENTO", "X"))
        .Y = CByte(Leer.GetValue("EVENTO", "Y"))
    End With
End Sub

Public Sub Armar_Death(ByVal ID As Integer, ByVal Cupos As Byte, ByVal Objetos As Boolean, ByVal Premio As Long, ByVal Inscripcion As Long)
    With Deathmatch
        If .Activo = True Then
            Call WriteConsoleMsg(ID, "Deathmatch> El evento ya está en curso.", FontTypeNames.FONTTYPE_GUILD)
            Exit Sub
        End If
        If Cupos > 40 Then Cupos = 40
        If Cupos < 2 Then Cupos = 2
        .Cupos = Cupos
        .Inscripcion = Inscripcion
        .Objetos = Objetos
        .Premio = Premio
        .Total = .Cupos
        .Restantes = .Total
        .Activo = True
        .Conteo = Tiempo_Cancelamiento
        ReDim .Usuarios(1 To .Cupos) As tUsuario
        Call SendData(SendTarget.ToAll, 0, PrepareMessageConsoleMsg("Deathmatch> " & .Cupos & " Cupos, Incripción" & IIf(.Inscripcion > 0, " de: " & .Inscripcion & " Monedas de oro, ", " Gratis, ") & IIf(Objetos = True, "Caen items, ", "No caen items, ") & IIf(.Premio > 0, "Premio de: " & .Premio & " Monedas de oro.", " No hay premio.") & " Manden/DEATHMATCH si desean participar.", FontTypeNames.FONTTYPE_GUILD))
    End With
End Sub

Public Sub Entrar_Death(ByVal ID As Integer)
    Dim ID_Death As Byte
    With Deathmatch
        If Puede_Entrar(ID) = False Then Exit Sub
        Call WriteConsoleMsg(ID, "Has ingresado al evento" & IIf(.Inscripcion > 0, ", se te han descontado " & .Inscripcion & " monedas de oro.", vbNullString) & ". Espera a que el cupo se complete. ¡Suerte en el campo de batalla!", FontTypeNames.FONTTYPE_GUILD)
        UserList(ID).Stats.GLD = UserList(ID).Stats.GLD - .Inscripcion
        .Cupos = .Cupos - 1
        ID_Death = Death_ID
        UserList(ID).flags.EnDeathmatch = ID_Death
        .Usuarios(ID_Death).ID = ID
        .Usuarios(ID_Death).Posicion = UserList(ID).Pos
        With Deathmatch.Coordenadas
            If Deathmatch.Cupos = Deathmatch.Total - 1 Then
                WarpUserChar ID, .Map, .X, .Y, False
            Else
                WarpUserChar ID, .Map, .X - Deathmatch.Cupos * 2, .Y - Deathmatch.Cupos * 2, False
            End If
        End With
        WritePauseToggle ID
        WriteUpdateGold ID
        If .Cupos = 0 Then
            Call SendData(SendTarget.ToAll, 0, PrepareMessageConsoleMsg("Deathmatch> El cupo ha sido completado!", FontTypeNames.FONTTYPE_GUILD))
            .Conteo = 10
        End If
    End With
End Sub

Private Function Death_ID() As Byte
    Dim LoopC As Long
    With Deathmatch
        For LoopC = 1 To .Total
            If .Usuarios(LoopC).ID = 0 Then
                Death_ID = LoopC
                Exit Function
            End If
        Next LoopC
    End With
End Function

Private Function Puede_Entrar(ByVal ID As Integer) As Boolean
    Puede_Entrar = False
    If UserList(ID).flags.Muerto > 0 Then
        Call WriteConsoleMsg(ID, "Estás muerto.", FontTypeNames.FONTTYPE_GUILD)
        Exit Function
    End If
    If UserList(ID).flags.EnJDH > 0 Then
        Call WriteConsoleMsg(ID, "Estás en los Juegos del Hambre.", FontTypeNames.FONTTYPE_GUILD)
        Exit Function
    End If
    If UserList(ID).flags.EnDeathmatch > 0 Then
        Call WriteConsoleMsg(ID, "Ya estás en el Deathmatch.", FontTypeNames.FONTTYPE_GUILD)
        Exit Function
    End If
    If Deathmatch.Activo = False Then
        Call WriteConsoleMsg(ID, "El evento no está en curso.", FontTypeNames.FONTTYPE_GUILD)
        Exit Function
    End If
    If Deathmatch.Cupos = 0 Then
        Call WriteConsoleMsg(ID, "El evento ya no tiene cupos disponibles.", FontTypeNames.FONTTYPE_GUILD)
        Exit Function
    End If
    If UserList(ID).Stats.GLD < Deathmatch.Inscripcion Then
        Call WriteConsoleMsg(ID, "No tienes el oro suficiente.", FontTypeNames.FONTTYPE_GUILD)
        Exit Function
    End If
    If Not UserList(ID).Pos.Map = 1 Then
        Call WriteConsoleMsg(ID, "Tienes que estar en Ullathorpe para poder ingresar al evento", FontTypeNames.FONTTYPE_GUILD)
        Exit Function
    End If
    Puede_Entrar = True
End Function

Public Sub Contar_Death()
    Dim LoopC As Long
    Dim loopX As Long
    Dim ID_Death As Byte
    With Deathmatch
        If .Conteo = 0 Then
            .Conteo = -1
            If .Activo = True Then
                If .Premio > 0 Then
                    For LoopC = 1 To .Total
                        WritePauseToggle .Usuarios(LoopC).ID
                    Next LoopC
                End If
                If .Cupos = 0 And .Premio > 0 Then
                    SendData SendTarget.ToAll, 0, PrepareMessageConsoleMsg("Deathmatch> Ya!", FontTypeNames.FONTTYPE_FIGHT)
                ElseIf .Premio > 0 Then
                    SendData SendTarget.ToAll, 0, PrepareMessageConsoleMsg("Deathmatch> Evento cancelado por falta de participantes, se ha devuelto el oro por la inscripción.", FontTypeNames.FONTTYPE_GUILD)
                    Cancelar_Death
                End If
                If .Premio = 0 And .Activo = True Then
                    ID_Death = ID_Usuario
                    WarpUserChar .Usuarios(ID_Death).ID, .Usuarios(ID_Death).Posicion.Map, .Usuarios(ID_Death).Posicion.X, .Usuarios(ID_Death).Posicion.Y, False
                    QuitarNPC (MapData(.Pos_Banquero.Map, .Pos_Banquero.X, .Pos_Banquero.Y).NpcIndex)
                    Limpiar
                    m_Limpieza.CleanWorld_Clear
                End If
            End If
        End If
        If .Conteo > 0 Then
            If .Cupos = 0 And .Premio > 0 Then _
                SendData SendTarget.ToAll, 0, PrepareMessageConsoleMsg("Deathmatch> " & .Conteo, FontTypeNames.FONTTYPE_GUILD)
            .Conteo = .Conteo - 1
        End If
    End With
End Sub

Private Function ID_Usuario() As Byte
    Dim LoopC As Long
    For LoopC = 1 To Deathmatch.Total
            If Deathmatch.Usuarios(LoopC).ID > 0 Then
                ID_Usuario = LoopC
                Exit For
            End If
    Next LoopC
End Function

Public Sub Muere_Death(ByVal ID As Integer)
    Dim ID_Death As Byte
    ID_Death = UserList(ID).flags.EnDeathmatch
    If ID_Death = 0 Then Exit Sub
    UserList(ID).flags.EnDeathmatch = 0
    With Deathmatch
        .Restantes = .Restantes - 1
        If .Restantes > 1 Then SendData SendTarget.ToAll, 0, PrepareMessageConsoleMsg("Deathmatch> Quedan " & .Restantes & " luchadores.", FontTypeNames.FONTTYPE_GUILD)
        If .Objetos = True Then TirarTodo ID
        Call WriteConsoleMsg(ID, "Deathmatch> ¡Has perdido, has sido descalificado. ¡Suerte para la próxima!", FontTypeNames.FONTTYPE_GUILD)
        WarpUserChar ID, .Usuarios(ID_Death).Posicion.Map, .Usuarios(ID_Death).Posicion.X, .Usuarios(ID_Death).Posicion.Y, False
        .Usuarios(ID_Death).ID = 0
        If .Restantes = 1 Then Finalizar
    End With
End Sub

Private Sub Finalizar()
    Dim LoopC As Long
    Dim Dame_ID As Byte
    Dim ID As Integer
    With Deathmatch
        Dame_ID = ID_Usuario
        ID = .Usuarios(Dame_ID).ID
        .Pos_Banquero = UserList(ID).Pos
        .Pos_Banquero.Y = .Pos_Banquero.Y
        SendData SendTarget.ToAll, 0, PrepareMessageConsoleMsg("Deathmatch> Ganador del evento: " & UserList(ID).name & " se lleva una cantidad de " & .Premio & " monedas de oro" & IIf(.Objetos = True, " y los items recaudados.", vbNullString) & ", felicitaciones!", FontTypeNames.FONTTYPE_GUILD)
        UserList(ID).Stats.GLD = UserList(ID).Stats.GLD + .Premio
        WriteUpdateGold ID
        UserList(ID).flags.EnDeathmatch = 0
        .Premio = 0
        If .Objetos = True Then
            .Conteo = 60
            'Call WriteConsoleMsg(ID, "Tienes 60 segundos para recoger los items del piso.", FontTypeNames.FONTTYPE_GUILD)
            WarpUserChar ID, .Pos_Banquero.Map, .Pos_Banquero.X, .Pos_Banquero.Y + 1, False
            Call SpawnNpc(Banquero, .Pos_Banquero, True, False)
            Call SendData(SendTarget.ToPCArea, ID, PrepareMessageChatOverHead("Tienes 60 segundos para recoger los items del piso.", MapData(.Pos_Banquero.Map, .Pos_Banquero.X, .Pos_Banquero.Y).NpcIndex, vbWhite))
        Else
            WarpUserChar ID, .Usuarios(Dame_ID).Posicion.Map, .Usuarios(Dame_ID).Posicion.X, .Usuarios(Dame_ID).Posicion.Y, False
            Limpiar
        End If
    End With
End Sub

Public Sub Cancelar_Death()
    Dim LoopC As Long
    With Deathmatch
        If .Activo = False Then Exit Sub
        For LoopC = 1 To .Total
            If .Usuarios(LoopC).ID > 0 Then
                WarpUserChar .Usuarios(LoopC).ID, .Usuarios(LoopC).Posicion.Map, .Usuarios(LoopC).Posicion.X, .Usuarios(LoopC).Posicion.Y, False
                UserList(.Usuarios(LoopC).ID).flags.EnDeathmatch = 0
                UserList(.Usuarios(LoopC).ID).Stats.GLD = UserList(.Usuarios(LoopC).ID).Stats.GLD + .Inscripcion
                WriteConsoleMsg .Usuarios(LoopC).ID, "El evento ha sido cancelado, se te ha devuelto el costo de la inscripción.", FontTypeNames.FONTTYPE_GUILD
                WriteUpdateGold .Usuarios(LoopC).ID
            End If
        Next LoopC
    End With
    SendData SendTarget.ToAll, 0, PrepareMessageConsoleMsg("Deathmatch> Evento fue cancelado por un Game Master.", FontTypeNames.FONTTYPE_GUILD)
    Limpiar
End Sub

Public Sub Desconexion_Death(ByVal ID As Integer)
    If UserList(ID).flags.EnDeathmatch = 0 Then Exit Sub
    With Deathmatch
        WarpUserChar ID, .Usuarios(UserList(ID).flags.EnDeathmatch).Posicion.Map, .Usuarios(UserList(ID).flags.EnDeathmatch).Posicion.X, .Usuarios(UserList(ID).flags.EnDeathmatch).Posicion.Y, True
        .Usuarios(UserList(ID).flags.EnDeathmatch).ID = 0
        UserList(ID).flags.EnDeathmatch = 0
        .Cupos = .Cupos + 1
        WritePauseToggle ID
    End With
End Sub

Private Sub Limpiar()
    With Deathmatch
        .Activo = False
        .Conteo = -1
        .Cupos = 0
        .Inscripcion = 0
        .Objetos = False
        .Premio = 0
        .Restantes = 0
        .Total = 0
        Erase .Usuarios()
    End With
End Sub


_______________

Como saben yo aporto bastante en Servers-Argentum y les quiero decir que todos tienen derecho de usar y de aportar en otra comunidad mis aportes pero sólo con un requisito y es tan simple que dejar los créditos. Gracias.
Si conocen otra comunidad y en esa misma mis aportes no están aportados, si tenés tiempo y ganas, aportalo! A mucha gente le puede servir. No te olvides del requisito Razz

MIS MEJORES APORTES:

Compra/venta de personajes:
https://goo.gl/A44Av0

Juegos del Hambre:
https://goo.gl/u6aNUG

Deathmatch automático:
https://goo.gl/GQF4fK

Sistema de retos vía MMR con búsqueda, emparejamiento, etc:
https://goo.gl/40uP0f

Sistemas de eventos automáticos de 1vs1 hasta 10vs10:
https://goo.gl/XYKygc

1VS1 - AIM - MELEE - Gana Sigue (Se liberan cupos)
https://goo.gl/qq83wx

Retos 3vs3 - [Items, 2 rounds, múltiples arenas, oro]
https://goo.gl/x8SMnV

Eliminar sistema de Skill (COMPLETO)
https://goo.gl/mKxHzC
avatar
Toyz
Administrador
Administrador

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

Ver perfil de usuario

Volver arriba Ir abajo

Volver arriba

- Temas similares

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