[Aportes indexados] Subastas

Lagalot · Oct 19, 2006

Este codigo lo postee en el foro alkon con El user "ThunderBolt".

Subastas

Este codigo lo cree yo para mi server blizzardao, y hoy lo comparto con uds para que puedan mejorar sus servidores, y comprender mas algunas funciones del visual basic.

Como funciona? Yo lo que hice fue medio raro, para no complicarme las cosas cree un modulo aparte y un ini donde se guarde la informacion de vendedores y compradores.

En el servidor

En el frmmain creamos un timer de nombre:

Código:

SubastaTIMER

con un intervalo de

Código:

de codigo le ponemos:

Código:

Dim LagaHubOfertaB
LagaHubOfertaB = GetVar(App.Path & "\Dat\" & "Subasta.ini", "Subasta", "Ofertaron")
If LagaHubOfertaB = 0 Then
'Call SendData(ToAll, 0, 0, "||Si nadie hace una oferta, la subasta se cierra en " & frmMain.SubastaLabel.Caption & " Segundos." & FONTTYPE_INFO)
 
If frmMain.SubastaLabel > 0 Then
    'If frmMain.SubastaLabel = 240 Then
        'Call SendData(ToAll, 0, 0, "||La subasta terminara en 4 minutos." & FONTTYPE_SUBASTA)
    'ElseIf frmMain.SubastaLabel = 180 Then
        'Call SendData(ToAll, 0, 0, "||La subasta terminara en 3 minutos." & FONTTYPE_SUBASTA)
    If frmMain.SubastaLabel = 120 Then
        Call SendData(ToAll, 0, 0, "||La subasta terminara en 2 minutos." & FONTTYPE_SUBASTA)
    ElseIf frmMain.SubastaLabel = 60 Then
        Call SendData(ToAll, 0, 0, "||La subasta terminara en 1 minuto." & FONTTYPE_SUBASTA)
    End If
frmMain.SubastaLabel = frmMain.SubastaLabel - 1
Else
Call SendData(ToAll, 0, 0, "||La subasta se a cerrado, disculpen las molestias." & FONTTYPE_SUBASTA)
Call WriteVar(App.Path & "\Dat\" & "Subasta.ini", "Subasta", "Activa", "0")
frmMain.SubastaTIMER.Enabled = False
End If
 
Else
 
Dim LagaNombreA
LagaNombreA = GetVar(App.Path & "\Dat\" & "Subasta.ini", "Subasta", "Comprador")
Dim LagaNombreB
LagaNombreB = GetVar(App.Path & "\Dat\" & "Subasta.ini", "Subasta", "Vendedor")
 
Dim LagaCompradorB
LagaCompradorB = NameIndex(LagaNombreA)
Dim LagaVendedorB
LagaVendedorB = NameIndex(LagaNombreB)
 
Dim LagaValorFinalB
LagaValorFinalB = GetVar(App.Path & "\Dat\" & "Subasta.ini", "Subasta", "Valor")
 
If frmMain.SubastaLabel > 0 Then
    If frmMain.SubastaLabel = 240 Then
        Call SendData(ToAll, 0, 0, "||La subasta terminara en 4 minutos." & FONTTYPE_SUBASTA)
    'ElseIf frmMain.SubastaLabel = 180 Then
        'Call SendData(ToAll, 0, 0, "||La subasta terminara en 3 minutos." & FONTTYPE_SUBASTA)
    ElseIf frmMain.SubastaLabel = 120 Then
        Call SendData(ToAll, 0, 0, "||La subasta terminara en 2 minutos." & FONTTYPE_SUBASTA)
    ElseIf frmMain.SubastaLabel = 60 Then
        Call SendData(ToAll, 0, 0, "||La subasta terminara en 1 minuto." & FONTTYPE_SUBASTA)
    End If
frmMain.SubastaLabel = frmMain.SubastaLabel - 1
Else
 
If EstaConectado(LagaVendedorB) And EstaConectado(LagaCompradorB) Then
If TieneObjetos(LagaObj.ObjIndex, LagaObj.Amount, LagaVendedorB) Then
If TieneOro(LagaCompradorB, LagaValorFinalB) Then
 
'Call SendData(ToAll, 0, 0, "||Se esta transferiendo el item y el oro." & FONTTYPE_SUBASTA)
Call PasarItemsyOro(LagaCompradorB, LagaVendedorB, LagaValorFinalB)
        
Else
    Call SendData(ToAll, 0, 0, "||La subasta se a cancelado debido a que el usuario " & LagaNombreA & " ya no posee las " & LagaValorFinalB & " Monedas de oro acordadas para esta venta." & FONTTYPE_SUBASTA)
    Call WriteVar(App.Path & "\Dat\" & "Subasta.ini", "Subasta", "Activa", "0")
frmMain.SubastaTIMER.Enabled = False
    Exit Sub
End If
 
Else
    Call SendData(ToAll, 0, 0, "||La subasta se a cancelado debido a que el usuario " & LagaNombreB & " ya no posee los Items acordados para esta venta." & FONTTYPE_SUBASTA)
    Call WriteVar(App.Path & "\Dat\" & "Subasta.ini", "Subasta", "Activa", "0")
frmMain.SubastaTIMER.Enabled = False
    Exit Sub
End If
 
Else
    Call SendData(ToAll, 0, 0, "||La subasta se a cancelado debido a el o los usuarios que acordaron la venta se han desconectado." & FONTTYPE_SUBASTA)
    Call WriteVar(App.Path & "\Dat\" & "Subasta.ini", "Subasta", "Activa", "0")
frmMain.SubastaTIMER.Enabled = False
    Exit Sub
End If
 
 
Call WriteVar(App.Path & "\Dat\" & "Subasta.ini", "Subasta", "Activa", "0")
frmMain.SubastaTIMER.Enabled = False
 
        
End If
 
End If
End Sub

Esto lo que hace es leer el comprador, el vendedor, el item, el precio y la cantidad de oro acordada de un archivo de texto, y despues revisar si se poseen todavia los objetos acordados, tambien avisar en cuanto tiempo terminara la subasta.

Creamos un nuevo modulo, y en el pondremos las siguientes funciones que son IMPORTANTES para que la transaccion se lleve a cabo.

Código:

Function EstaConectado(ByVal User As Integer) As Boolean
 
If UserList(User).ConnID <> -1 And UserList(User).flags.UserLogged Then
EstaConectado = True
Exit Function
End If
 
EstaConectado = False
End Function
 
Function TieneOro(ByVal User As Integer, ByVal oro As Long) As Boolean
 
If UserList(User).Stats.GLD >= oro Then
TieneOro = True
Exit Function
End If
 
TieneOro = False
End Function
 
Sub PasarItemsyOro(ByVal Comprador As Integer, ByVal Vendedor As Integer, ByVal oro As Long)
 
Dim LagaObjB As Obj
LagaObjB.ObjIndex = GetVar(App.Path & "\Dat\" & "Subasta.ini", "Subasta", "Objeto")
LagaObjB.Amount = GetVar(App.Path & "\Dat\" & "Subasta.ini", "Subasta", "Cantidad")
 
    UserList(Comprador).Stats.GLD = UserList(Comprador).Stats.GLD - oro
    UserList(Vendedor).Stats.GLD = UserList(Vendedor).Stats.GLD + oro
    Call MeterItemEnInventario(Comprador, LagaObjB)
    Call QuitarObjetos(LagaObjB.ObjIndex, LagaObjB.Amount, Vendedor)
    Call SendData(ToAll, 0, 0, "||El usuario " & UserList(Comprador).Name & " a comprado " & LagaObjB.Amount & " " & ObjData(LagaObjB.ObjIndex).Name & " a " & oro & " Monedas de oro!!!" & FONTTYPE_SUBASTA)
    Call SendUserStatsBox(Comprador)
    Call SendUserStatsBox(Vendedor)
    Call UpdateUserInv(True, Vendedor, 0)
Exit Sub
 
End Sub

Estas funciones revisan si se posee el oro, si los usuarios estan conectados y tambien producen es traslado de los items y el oro.

Luego cuando termina el

Código:

Case "Boveda"

ponemos esto:

Código:

Case "/INFOSUBASTA"
            Dim LagaSubActivaC
        LagaSubActivaC = GetVar(App.Path & "\Dat\" & "Subasta.ini", "Subasta", "Activa")
    If LagaSubActivaC = 0 Then
        Call SendData(ToIndex, UserIndex, 0, "||No hay ninguna subasta activa!." & FONTTYPE_INFO)
        Exit Sub
    End If
Dim LagaPrecioC
Dim LagaObjC As Obj
Dim LagaCompradorC
Dim LagaVendedorC
LagaObjC.ObjIndex = GetVar(App.Path & "\Dat\" & "Subasta.ini", "Subasta", "Objeto")
LagaObjC.Amount = GetVar(App.Path & "\Dat\" & "Subasta.ini", "Subasta", "Cantidad")
LagaPrecioC = GetVar(App.Path & "\Dat\" & "Subasta.ini", "Subasta", "Valor")
LagaVendedorC = GetVar(App.Path & "\Dat\" & "Subasta.ini", "Subasta", "Vendedor")
LagaCompradorC = GetVar(App.Path & "\Dat\" & "Subasta.ini", "Subasta", "Comprador")
Call SendData(ToIndex, UserIndex, 0, "||" & LagaVendedorC & " esta vendiendo " & LagaObj.Amount & " " & ObjData(LagaObj.ObjIndex).Name & "" & FONTTYPE_SUBASTA)
Call SendData(ToIndex, UserIndex, 0, "||Hasta ahora " & LagaCompradorC & " lidera la subasta ofertando " & LagaPrecioC & " Monedas de oro" & FONTTYPE_SUBASTA)
Call SendData(ToIndex, UserIndex, 0, "||Para ofertar escribe /Cantidad." & FONTTYPE_SUBASTA)
            Exit Sub
        Case "/CERRARSUBASTA"
            If UserList(UserIndex).flags.Privilegios < 2 Then
                If Not UserList(UserIndex).Name = GetVar(App.Path & "\Dat\" & "Subasta.ini", "Subasta", "Vendedor") Then
                    Call SendData(ToIndex, UserIndex, 0, "||No puedes cerrar la subasta si no eres el creador de la misma." & FONTTYPE_SUBASTA)
                Else
                    Call SendData(ToIndex, UserIndex, 0, "||La subasta se a cerrado debido a la descicion de su creador." & FONTTYPE_SUBASTA)
                    Call WriteVar(App.Path & "\Dat\" & "Subasta.ini", "Subasta", "Activa", "0")
                    frmMain.SubastaTIMER.Enabled = False
                End If
            Else
                Call SendData(ToIndex, UserIndex, 0, "||La subasta se a cerrado debido a la descicion de " & UserList(UserIndex).Name & "." & FONTTYPE_SUBASTA)
                Call WriteVar(App.Path & "\Dat\" & "Subasta.ini", "Subasta", "Activa", "0")
                frmMain.SubastaTIMER.Enabled = False
            End If
            Exit Sub

Esto lo que hace es cerrar la subasta si sos el dueño, o brindar informacion de la misma a los posibles compradores.

Ahora hay que hacer lo siguente
1* Al SubastaTimer ponerle de propiedad

Código:

Enabled = False

2* Crear un label "SubastaActivada" con caption

Código:

3* Crear un label "SubastaLabel" con caption

Código:

4* Crear un label "SubastaLabel2" con caption

Código:

5* Creamos un .ini que contenga esta informacion:

Código:

[Subasta]
Activa=0
Ofertaron=0
Valor=0
Vendedor=0
Comprador=0
Objeto=0
Cantidad=0

SIGUE ABAJO

Lagalot · Oct 19, 2006

Ahora lo que nos falta hacer es el comando para crear subastas, para participar en una subasta, para cerrar una subasta y para ver la informacion de la subasta asi que ahora hacemos esto.

Abajo del comando:

Código:

If UCase$(Left$(rdata, 6)) = "/PMSG " Then
        Call mdParty.BroadCastParty(UserIndex, Mid$(rdata, 7))
        Exit Sub
    End If

ponemos estos comandos:

Código:

'Subastar
If UCase$(Left$(rdata, 10)) = "/SUBASTAR " Then
rdata = Right$(rdata, Len(rdata) - 10)
 
    If Not UserList(UserIndex).Stats.UserSkills(Comerciar) >= 50 Then
        Call SendData(ToIndex, UserIndex, 0, "||Nesesitas almenos 50 puntos en comercio para poder subastar." & FONTTYPE_INFO)
        Exit Sub
    End If
 
    If frmMain.subastaActivada.Caption = 0 Then
        Call SendData(ToIndex, UserIndex, 0, "||Los gms han desactivado el sistema de subastas, porfavor espera un rato y vuelve a intentar." & FONTTYPE_INFO)
        Exit Sub
    End If
    
    If UserList(UserIndex).Stats.ELV < 15 Then
    Call SendData(ToIndex, UserIndex, 0, "||Nesesitas nivel 25 para organizar una subasta." & FONTTYPE_INFO)
    Exit Sub
    End If
 
'Gracias gs por la ayuda con algunos parametros.
' [GS]
    If InStr(rdata, "@") = False Then
    Call SendData(ToIndex, UserIndex, 0, "||Debes usar @ para separar los terminos." & FONTTYPE_INFO)
    Exit Sub
    End If
    If Numeric(ReadField(1, rdata, Asc("@"))) = False Or Numeric(ReadField(2, rdata, Asc("@"))) = False Or Numeric(ReadField(3, rdata, Asc("@"))) = False Then
    Call SendData(ToIndex, UserIndex, 0, "||Uno de tus parametros no es numericos." & FONTTYPE_INFO)
    Exit Sub
    End If
    If ReadField(1, rdata, Asc("@")) < 1 Or ReadField(1, rdata, Asc("@")) > 20 Or ReadField(2, rdata, Asc("@")) < 1 Or ReadField(2, rdata, Asc("@")) > 10000 Or ReadField(3, rdata, Asc("@")) < 1 Then
    Call SendData(ToIndex, UserIndex, 0, "||Uno de tus parametros es invalido." & FONTTYPE_INFO)
    Exit Sub
    End If
' [/GS]
 
 
    Dim LagaIndex
    LagaIndex = ReadField(1, rdata, Asc("@")) ' SLOT
    
    If UserList(UserIndex).Invent.Object(LagaIndex).Amount > 0 Then
        LagaObj.ObjIndex = UserList(UserIndex).Invent.Object(LagaIndex).ObjIndex
    Else
        Call SendData(ToIndex, UserIndex, 0, "||No hay ningun item en ese slot!." & FONTTYPE_INFO)
        Exit Sub
    End If
    
    If UserList(UserIndex).Invent.Object(LagaIndex).Equipped > 0 Then
        Call SendData(ToIndex, UserIndex, 0, "||No puedes subastar ese item porque lo estas usando!." & FONTTYPE_INFO)
        Exit Sub
    End If
        
    LagaObj.Amount = ReadField(2, rdata, Asc("@")) ' CANTIDAD
    
    Dim LagaInicial
    LagaInicial = ReadField(3, rdata, Asc("@")) ' VALOR INICIAL
 
 
'If (Not IsNumeric(ReadField(1, rdata, Asc("@")))) Or LagaObj.Amount = "" Or LagaInicial = "" Then
'        Call SendData(ToIndex, UserIndex, 0, "||Utilice /Subastar [email protected]@Precio" & FONTTYPE_INFO)
'        Exit Sub
'    End If
 
Dim LagaSubActivaA
LagaSubActivaA = GetVar(App.Path & "\Dat\" & "Subasta.ini", "Subasta", "Activa")
 
If LagaSubActivaA = 1 Then
    Call SendData(ToIndex, UserIndex, 0, "||Ya hay una subasta activa en estos momentos!." & FONTTYPE_INFO)
    Exit Sub
End If
 
If Not ObjData(LagaObj.ObjIndex).Subastable = 1 Then
    Call SendData(ToIndex, UserIndex, 0, "||Este objeto no puede ser subastado!." & FONTTYPE_INFO)
    Exit Sub
End If
If Not TieneObjetos(LagaObj.ObjIndex, LagaObj.Amount, UserIndex) Then
    Call SendData(ToIndex, UserIndex, 0, "||No posees el objeto o la cantidad que deseas subastar." & FONTTYPE_INFO)
    Exit Sub
End If
    
Dim LagaNombre
    LagaNombre = ObjData(LagaObj.ObjIndex).Name
 
frmMain.SubastaLabel2 = 180
frmMain.SubastaLabel = 180
 
Call WriteVar(App.Path & "\Dat\" & "Subasta.ini", "Subasta", "Activa", "1")
Call WriteVar(App.Path & "\Dat\" & "Subasta.ini", "Subasta", "Ofertaron", "0")
Call WriteVar(App.Path & "\Dat\" & "Subasta.ini", "Subasta", "Valor", "" & LagaInicial & "")
Call WriteVar(App.Path & "\Dat\" & "Subasta.ini", "Subasta", "Vendedor", "" & UserList(UserIndex).Name & "")
Call WriteVar(App.Path & "\Dat\" & "Subasta.ini", "Subasta", "Comprador", "0")
Call WriteVar(App.Path & "\Dat\" & "Subasta.ini", "Subasta", "Objeto", "" & LagaObj.ObjIndex & "")
Call WriteVar(App.Path & "\Dat\" & "Subasta.ini", "Subasta", "Cantidad", "" & LagaObj.Amount & "")
 
Call SendData(ToAll, 0, 0, "||" & UserList(UserIndex).Name & " esta subastando " & LagaObj.Amount & " " & LagaNombre & " con un valor inicial de " & LagaInicial & " monedas de oro, Para participar escribe /Ofertar Cantidad, les recuerdo que solamente tienen 5 minuto para ofertar." & FONTTYPE_SUBASTA)
frmMain.SubastaTIMER.Enabled = True
 
Exit Sub
End If
 
If UCase$(Left$(rdata, 9)) = "/OFERTAR " Then
    Dim LagaOro As Long
        LagaOro = Right$(rdata, Len(rdata) - 9)
    
    Dim LagaSubActiva
        LagaSubActiva = GetVar(App.Path & "\Dat\" & "Subasta.ini", "Subasta", "Activa")
    Dim LagaValorFinalXI As Long
        LagaValorFinalXI = GetVar(App.Path & "\Dat\" & "Subasta.ini", "Subasta", "Valor")
    
    If UserList(UserIndex).Stats.ELV < 15 Then
        Call SendData(ToIndex, UserIndex, 0, "||Nesesitas almenos tener nivel 15 para poder participar en una subasta." & FONTTYPE_INFO)
        Exit Sub
    End If
    
    If Not UserList(UserIndex).Stats.UserSkills(Comerciar) >= 20 Then
        Call SendData(ToIndex, UserIndex, 0, "||Nesesitas tener almenos 20 puntos en comercio para poder participar en una subasta." & FONTTYPE_INFO)
        Exit Sub
    End If
 
    If LagaSubActiva = 0 Then
        Call SendData(ToIndex, UserIndex, 0, "||No hay ninguna subasta activa!." & FONTTYPE_INFO)
        Exit Sub
    End If
    
    If LagaOro > UserList(UserIndex).Stats.GLD Then
        Call SendData(ToIndex, UserIndex, 0, "||No posees esa cantidad de oro." & FONTTYPE_INFO)
        Exit Sub
    End If
    
    If Not LagaOro > LagaValorFinalXI + 499 Then
        Call SendData(ToIndex, UserIndex, 0, "||Debe haber almenos una diferencia de 500 monedas a la ultima oferta!." & FONTTYPE_INFO)
        Exit Sub
    End If
    
    If LagaOro > LagaValorFinalXI Then
 
    
    LagaValorFinalXI = LagaOro
    Call WriteVar(App.Path & "\Dat\" & "Subasta.ini", "Subasta", "Valor", "" & LagaValorFinalXI & "")
    
    Call WriteVar(App.Path & "\Dat\" & "Subasta.ini", "Subasta", "Comprador", "" & UserList(UserIndex).Name & "")
    
    Call SendData(ToAll, 0, 0, "||" & UserList(UserIndex).Name & " a superado la oferta anterior ofreciendo " & LagaValorFinalXI & " Monedas de oro, Para participar escribe /Ofertar Cantidad." & FONTTYPE_SUBASTA)
 
    Call WriteVar(App.Path & "\Dat\" & "Subasta.ini", "Subasta", "Ofertaron", "1")
    
    Else
    Call SendData(ToIndex, UserIndex, 0, "||Losiento, ya hay una oferta mayor o igual a la tuya." & FONTTYPE_INFO)
        Exit Sub
    End If
    
Exit Sub
End If

Estos comandos lo que hacen son almacenar informacion en el ini del cual se va a leer la informacion cuando termine la subasta.

Vamos a modulo Declaraciones y ponemos:

Código:

Public LagaObj as obj

y luego vamos al sub LoadObjData y abajo de:

Código:

ObjData(Object).Newbie = val(Leer.DarValor("OBJ" & Object, "Newbie"))

ponemos:

Código:

ObjData(Object).Subastable = val(Leer.DarValor("OBJ" & Object, "Subastable"))

Esto hara que lea del obj.dat si el objeto puede ser subastado o no, tambien estamos declarando LagaObj.

FALTA 1 COSA

Buscamos:

Código:

Public Const FONTTYPE_SERVER = "~0~185~0~0~0"

y abajo ponemos:

Código:

Public Const FONTTYPE_SUBASTA = "~255~255~0~1~1"

Y listo, terminamos..

Para subastar se hace /Subastar [email protected]@PRECIO
Para ofertar /Ofertar CANTIDAD
Para ver informacion /Infosubasta
Para cerrar la subasta /CerrarSubasta
El obj tiene que tener subastable=1 para poder ser subastado.

Zymeth · Oct 19, 2006

ThunderBolt = Lagalot no?.

Muy buen code.

Lagalot · Oct 19, 2006

Zymeth dijo:
ThunderBolt = Lagalot no?.

Muy buen code.

Mis 3 apodos son ThunderBolt, Lagalot y ZpM.

Zymeth · Oct 19, 2006

El codigo esta muy bueno , pero le buscaste mas complicaciones

.

Tu tercer apodo es feo

.

Locura · Oct 20, 2006

Lagalot dijo:
Zymeth dijo:

ThunderBolt = Lagalot no?.

Muy buen code.

Haz clic para expandir...

Mis 3 apodos son ThunderBolt, Lagalot y ZpM.

Lego lee el otro foro que te puse algo que faltaba, y si queres pasame tu msn por MP tengo un par de preguntas para hacerte:$

Saludos,
LocuriTa.

DiCHANHO · Ene 18, 2007

bueno probé el code pero me da error de compilación en esta parte:

[vb]<div class="vb" id="{CB}" style="font-family: monospace;"><ol><li style="" class="li1">ObjData(Object).[color=red]Subastable =[/color] val(Leer.DarValor("OBJ" & Object, "Subastable"))</li></ol></div>[/vb]

te lo puse en rojo.. sabrías que es?

[Aportes indexados] Subastas

Lagalot

Newbie Lvl 6

Lagalot

Newbie Lvl 6

Zymeth

Newbie Lvl 1

Lagalot

Newbie Lvl 6

Zymeth

Newbie Lvl 1

Locura

Newbie Lvl 1

DiCHANHO

by cimsp.net