Sistema de Premium por Data

Olá Galera!

Hoje estou aqui para ensinar vocês a como criar um sistema de Premium para seu jogo onde o Premium é retirado automaticamente por datas. O sistema de Premium é um sistema que muitos conhecem, só que pelo nome Sistema Vip. Neste tutorial o Sistema Premium dá somente duas vezes mais experiência do que o player normal. Outras características devem ser adicionadas por vocês.

Vamos ao tutorial.

Cliente Side

No Cliente crie uma nova Form com o nome frmEditor_Premium. Deixe-a da seguinte forma :



Dê as seguintes propriedades para os textbox na ordem de cima para baixo :

Name : txtPlayer
Name : txtSPremium
Name : txtDPremium

Agora, dê as seguintes propriedades para os commands buttons na ordem da esquerda pra direita :

Name : cmdPremium
Name : cmdRPremium
Name : cmdExit

Agora insira esse código na frmEditor_Premium :

Código:

' Sistema de Premium By : Guardian
Option Explicit

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

Me.Visible = False

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

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

    'Check Access
    If GetPlayerAccess(MyIndex) < ADMIN_DEVELOPER Then
        Exit Sub
    End If
    
    'Check for blanks fields
    If txtPlayer.text = vbNullString Or txtSPremium.text = vbNullString Or txtDPremium.text = vbNullString Then
        MsgBox ("There are blank fields, please fill out.")
        Exit Sub
    End If
    
    'If all right, go for the Premium
    Call SendChangePremium(txtPlayer.text, txtSPremium.text, txtDPremium.text)
    
' Error handler
    Exit Sub
errorhandler:
    HandleError "cmdPremium_Click", "frmEditor_Premium", Err.Number, Err.Description, Err.Source, Err.HelpContext
    Err.Clear
    Exit Sub
End Sub

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

    'Check Access
    If GetPlayerAccess(MyIndex) < ADMIN_DEVELOPER Then
        Exit Sub
    End If
    
    'Check for blanks fields
    If txtPlayer.text = vbNullString Then
        MsgBox ("The name of the player is required for this operation.")
        Exit Sub
    End If
    
    'If all is right, remove the Premium
    Call SendRemovePremium(txtPlayer.text)
    
' Error handler
    Exit Sub
errorhandler:
    HandleError "cmdRPremium_Click", "frmEditor_Premium", Err.Number, Err.Description, Err.Source, Err.HelpContext
    Err.Clear
    Exit Sub
End Sub

Código:

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

    ' Check Access
    If GetPlayerAccess(MyIndex) < ADMIN_DEVELOPER Then
        Exit Sub
    End If

    Call SendRequestEditPremium
    
    ' Error handler
    Exit Sub
errorhandler:
    HandleError "cmdAPremium_Click", "frmMain", Err.Number, Err.Description, Err.Source, Err.HelpContext
    Err.Clear
    Exit Sub

Código:

Sub SendRequestEditPremium()
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 CRequestEditPremium
    SendData Buffer.ToArray()
    Set Buffer = Nothing

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

Sub SendChangePremium(ByVal Name As String, ByVal Start As String, ByVal Days 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 CChangePremium
    Buffer.WriteString Name
    Buffer.WriteString Start
    Buffer.WriteLong Days
    SendData Buffer.ToArray()
    Set Buffer = Nothing

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

Sub SendRemovePremium(ByVal Name 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.WriteLong CRemovePremium
    Buffer.WriteString Name
    SendData Buffer.ToArray()
    Set Buffer = Nothing

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

Código:

For i = 1 To Action_HighIndex
        Call BltActionMsg(i)
    Next i

Código:

If Premium <> vbNullString Then
    Call DrawPremium
    End If

Código:

' Make sure SMSG_COUNT is below everything else
    SMSG_COUNT

Código:

SPlayerDPremium
    SPremiumEditor

Código:

' Make sure CMSG_COUNT is below everything else
    CMSG_COUNT

Código:

CRequestEditPremium
    CChangePremium
    CRemovePremium

Código:

' Premium
Public Premium As String
Public RPremium As String

Código:

HandleDataSub(SPartyVitals) = GetAddress(AddressOf HandlePartyVitals)

Código:

HandleDataSub(SPlayerDPremium) = GetAddress(AddressOf HandlePlayerDPremium)
    HandleDataSub(SPremiumEditor) = GetAddress(AddressOf HandlePremiumEditor)

Código:

Private Sub HandlePlayerDPremium(ByVal Index As Long, ByRef Data() As Byte, ByVal StartAddr As Long, ByVal ExtraVar As Long)
Dim Buffer As clsBuffer
Dim A As String
Dim B As Long, c As Long

    ' If debug mode, handle error then exit out
    If Options.Debug = 1 Then On Error GoTo errorhandler
    
    Set Buffer = New clsBuffer
    Buffer.WriteBytes Data()
    
    ' Catch Data
    A = Buffer.ReadString
    B = Buffer.ReadLong
    c = Buffer.ReadLong
    
    ' Changing global variables
    If A = "Sim" Then
    Premium = "Premium : " & A
    RPremium = "You have : " & c - B & " days of Premium."
    Else
    Premium = vbNullString
    RPremium = vbNullString
    End If
    
    ' Error handler
    Exit Sub
errorhandler:
    HandleError "HandlePlayerDPremium", "modHandleData", Err.Number, Err.Description, Err.Source, Err.HelpContext
    Err.Clear
    Exit Sub
End Sub

Private Sub HandlePremiumEditor()
Dim i As Long

    ' If debug mode, handle error then exit out
    If Options.Debug = 1 Then On Error GoTo errorhandler
    
    ' Check Access
    If GetPlayerAccess(MyIndex) < ADMIN_DEVELOPER Then
    Exit Sub
    End If
    
    ' If you have everything right, up the Editor.
    With frmeditor_Premium
    .Visible = True
    End With
    
    ' Error handler
    Exit Sub
errorhandler:
    HandleError "HandlePremiumEditor", "modHandleData", Err.Number, Err.Description, Err.Source, Err.HelpContext
    Err.Clear
    Exit Sub
End Sub

Código:

Public Sub DrawPremium()
Dim x As Long
Dim x2 As Long
Dim y As Long

x = Camera.Left + ((MAX_MAPX + 1) * PIC_X / 2) - getWidth(TexthDC, Trim$(Premium))
x2 = Camera.Left + ((MAX_MAPX + 1) * PIC_X / 2) - getWidth(TexthDC, Trim$(RPremium))
y = Camera.top + 1

Call DrawText(TexthDC, x - 190, y, Premium, QBColor(BrightBlue))
Call DrawText(TexthDC, x2 - 145, y + 20, RPremium, QBColor(BrightRed))
End Sub

Código:

' Client use only

Código:

' Premium
    Premium As String
    StartPremium As String
    DaysPremium As Long

Código:

' Calculate exp to give attacker
        exp = Npc(npcNum).exp

Código:

' Premium
        If GetPlayerPremium(attacker) = "Sim" Then
        exp = exp * 2
        End If

Código:

' Make sure SMSG_COUNT is below everything else
    SMSG_COUNT

Código:

SPlayerDPremium
    SPremiumEditor

Código:

' Make sure CMSG_COUNT is below everything else
    CMSG_COUNT

Código:

CRequestEditPremium
    CChangePremium
    CRemovePremium

Código:

HandleDataSub(CPartyLeave) = GetAddress(AddressOf HandlePartyLeave)

Código:

HandleDataSub(CRequestEditPremium) = GetAddress(AddressOf HandleRequestEditPremium)
    HandleDataSub(CChangePremium) = GetAddress(AddressOf HandleChangePremium)
    HandleDataSub(CRemovePremium) = GetAddress(AddressOf HandleRemovePremium)

Código:

Sub HandleRequestEditPremium(ByVal index As Long, ByRef Data() As Byte, ByVal StartAddr As Long, ByVal ExtraVar As Long)

' Check Access
If GetPlayerAccess(index) < ADMIN_DEVELOPER Then
    Call PlayerMsg(index, "You do not have access to complete this action!", White)
    Exit Sub
End If

Call SendPremiumEditor(index)
End Sub

Sub HandleChangePremium(ByVal Index As Long, ByRef Data() As Byte, ByVal StartAddr As Long, ByVal ExtraVar As Long)
Dim Buffer As clsBuffer
Dim A As String
Dim B As String
Dim C As Long
Dim D As String
    
    Set Buffer = New clsBuffer
    Buffer.WriteBytes Data()
    
    A = Buffer.ReadString
    B = Buffer.ReadString
    C = Buffer.ReadLong
    
    D = FindPlayer(A)
    
    If IsPlaying(D) Then
            
    ' Check access if everything is right, change Premium
    If GetPlayerAccess(Index) < ADMIN_DEVELOPER Then
        Call PlayerMsg(Index, "You do not have access to complete this action!", White)
        Exit Sub
    Else
        Call SetPlayerPremium(D, "Sim")
        Call SetPlayerStartPremium(D, B)
        Call SetPlayerDaysPremium(D, C)
        GlobalMsg "The player " & GetPlayerName(D) & " became Premium. Congratulations!", BrightCyan
    End If
    
    SendPlayerData D
    SendDataPremium D
    
    End If
    
    Set Buffer = Nothing
End Sub

Sub HandleRemovePremium(ByVal Index As Long, ByRef Data() As Byte, ByVal StartAddr As Long, ByVal ExtraVar As Long)
Dim Buffer As clsBuffer
Dim A As String
Dim B As String
    
    Set Buffer = New clsBuffer
    Buffer.WriteBytes Data()
    
    A = Buffer.ReadString
    
    B = FindPlayer(A)
    
    If IsPlaying(B) Then
            
    ' Check access if everything is right, change Premium
    If GetPlayerAccess(Index) < ADMIN_DEVELOPER Then
        Call PlayerMsg(Index, "You do not have access to complete this action!", White)
        Exit Sub
    Else
        Call SetPlayerPremium(B, "Não")
        Call SetPlayerStartPremium(B, vbNullString)
        Call SetPlayerDaysPremium(B, 0)
        PlayerMsg B, "His days of premium sold out.", BrightCyan
    End If
    
    SendPlayerData B
    SendDataPremium B
    
    End If
    
    Set Buffer = Nothing
End Sub

Código:

' Premium
Function GetPlayerPremium(ByVal index As Long) As String
    GetPlayerPremium = Trim$(Player(index).Premium)
End Function
 
Sub SetPlayerPremium(ByVal index As Long, ByVal Premium As String)
    Player(index).Premium = Premium
End Sub
 
' Start Premium
Function GetPlayerStartPremium(ByVal index As Long) As String
    GetPlayerStartPremium = Trim$(Player(index).StartPremium)
End Function
 
Sub SetPlayerStartPremium(ByVal index As Long, ByVal StartPremium As String)
    Player(index).StartPremium = StartPremium
End Sub
 
' Days Premium
Function GetPlayerDaysPremium(ByVal index As Long) As Long
    GetPlayerDaysPremium = Player(index).DaysPremium
End Function
 
Sub SetPlayerDaysPremium(ByVal index As Long, ByVal DaysPremium As Long)
    Player(index).DaysPremium = DaysPremium
End Sub

Sub CheckPremium(ByVal index As Long)

    ' Check Premium
    If GetPlayerPremium(index) = "Sim" Then
        If DateDiff("d", GetPlayerStartPremium(index), Date) < GetPlayerDaysPremium(index) Then
            If GetPlayerPremium(index) = "Sim" Then
                Call PlayerMsg(index, "Thank you for purchasing the Premium Plan, Good Game!", White)
            End If
        ElseIf DateDiff("d", GetPlayerStartPremium(index), Date) >= GetPlayerDaysPremium(index) Then
            If GetPlayerPremium(index) = "Sim" Then
                Call SetPlayerPremium(index, "Não")
                Call PlayerMsg(index, "His days with the Premium plan exhausted, Good Game!", White)
            End If
        End If
    End If
End Sub

Código:

Sub SendDataPremium(ByVal index As Long)
Dim Buffer As clsBuffer
Dim A As Long

    If GetPlayerPremium(index) = "Sim" Then
        A = DateDiff("d", GetPlayerStartPremium(index), Now)
    Else
        A = 0
    End If

    Set Buffer = New clsBuffer
    Buffer.WriteLong SPlayerDPremium
    Buffer.WriteString GetPlayerPremium(index)
    Buffer.WriteLong A
    Buffer.WriteLong GetPlayerDaysPremium(index)
    
    SendDataTo index, Buffer.ToArray()
    Set Buffer = Nothing
End Sub

Sub SendPremiumEditor(ByVal index As Long)
Dim Buffer As clsBuffer

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

Código:

Dir As Byte

Código:

' Premium
    Premium As String
    StartPremium As String
    DaysPremium As Long

Código:

Call SendWornEquipment(index)
    Call SendMapEquipment(index)
    Call SendPlayerSpells(index)
    Call SendHotbar(index)

Código:

Call CheckPremium(index)

Código:

Player(index).Class = ClassNum

Código:

Player(index).Premium = "Não"
        Player(index).StartPremium = "00/00/0000"
        Player(index).DaysPremium = 0

Código:

Player(index).Class = 1

Código:

Player(index).Premium = "Não"
    Player(index).StartPremium = "00/00/0000"
    Player(index).DaysPremium = 0

Código:

' Show the player up on the socket status

Código:

Call SendDataPremium(index)

Código:

Call AddChar(index, Name, Sex, Class, Sprite)

Código:

Call SendDataPremium(index)

Código:


If frmEditor_Premium.visible = True Then
frmEditor_Premium.visible = False
Else
frmEditor_Premium.visible = True
End If


Código:

Sub SetPlayerPremium(ByVal index As Long, ByVal Premium As String)
    Player(index).Premium = Premium
End Sub

Código:

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

    ' Check Access
    If GetPlayerAccess(MyIndex) < ADMIN_DEVELOPER Then
        Exit Sub
    End If

    Call SendRequestEditPremium
   
    ' Error handler
    Exit Sub
errorhandler:
    HandleError "cmdAPremium_Click", "frmMain", Err.Number, Err.Description, Err.Source, Err.HelpContext
    Err.Clear
    Exit Sub

Código:

Sub HandleChangePremium(ByVal Index As Long, ByRef Data() As Byte, ByVal StartAddr As Long, ByVal ExtraVar As Long)
Dim Buffer As clsBuffer
Dim A As String
Dim B As String
Dim C As Long
Dim D As String
   
    Set Buffer = New clsBuffer
    Buffer.WriteBytes Data()
   
    A = Buffer.ReadString
    B = Buffer.ReadString
    C = Buffer.ReadLong
   
    D = FindPlayer(A)
   
    If IsPlaying(D) Then
           
    ' Check access if everything is right, change Premium
    If GetPlayerAccess(Index) < ADMIN_DEVELOPER Then
        Call PlayerMsg(Index, "You do not have access to complete this action!", White)
        Exit Sub
    Else
        Call SetPlayerPremium(D, "Sim")
        Call SetPlayerStartPremium(D, B)
        Call SetPlayerDaysPremium(D, C)
        GlobalMsg "The player " & GetPlayerName(D) & " became Premium. Congratulations!", BrightCyan
    End If
   
    SendPlayerData D
    SendDataPremium D
   
    End If
   
    Set Buffer = Nothing
End Sub

Sub HandleRemovePremium(ByVal Index As Long, ByRef Data() As Byte, ByVal StartAddr As Long, ByVal ExtraVar As Long)
Dim Buffer As clsBuffer
Dim A As String
Dim B As String
   
    Set Buffer = New clsBuffer
    Buffer.WriteBytes Data()
   
    A = Buffer.ReadString
   
    B = FindPlayer(A)
   
    If IsPlaying(B) Then
           
    ' Check access if everything is right, change Premium
    If GetPlayerAccess(Index) < ADMIN_DEVELOPER Then
        Call PlayerMsg(Index, "You do not have access to complete this action!", White)
        Exit Sub
    Else
        Call SetPlayerPremium(B, "Não")
        Call SetPlayerStartPremium(B, vbNullString)
        Call SetPlayerDaysPremium(B, 0)
        PlayerMsg B, "His days of premium sold out.", BrightCyan
    End If
   
    SendPlayerData B
    SendDataPremium B
   
    End If
   
    Set Buffer = Nothing
End Sub

Valentine escreveu:Isso é muito bom cara, você realmente sabe trabalhar muito bem com tempo, você está de parabéns, eu fiz algo do tipo, mas esse seu sistema de premmy trabalha com horas também? por exemplo: eu adiciono 2 dias de premmy no dia 15 de julho as 17:21 e ela acabar dia 17 as 17:21?

Eu sei que você pode usar DateDiff para fazer uma segunda condição, mas não tem alguma condição única?

Código:

If DateDiff("d", GetPlayerStartPremium(index), Date) < GetPlayerDaysPremium(index) Then

Código:

If Time > Player(Index).Time Then
SetPlayerPremium(Index, "Não")
End If

Código:

Public Sub DrawPremium()
Dim x As Long
Dim y As Long

x = Camera.Left + ((MAX_MAPX + 1) * PIC_X / 2) - getWidth(TexthDC, Trim$(Map.Name))
y = Camera.top + 1

Call DrawText(TexthDC, x - 235, y, Premium, QBColor(BrightBlue))
Call DrawText(TexthDC, x - 235, y + 20, RPremium, QBColor(BrightRed))
End Sub

Código:

Public Sub DrawPremium()
Dim x As Long
Dim x2 As Long
Dim y As Long

x = Camera.Left + ((MAX_MAPX + 1) * PIC_X / 2) - getWidth(TexthDC, Trim$(Premium))
x2 = Camera.Left + ((MAX_MAPX + 1) * PIC_X / 2) - getWidth(TexthDC, Trim$(RPremium))
y = Camera.top + 1

Call DrawText(TexthDC, x - 190, y, Premium, QBColor(BrightBlue))
Call DrawText(TexthDC, x2 - 145, y + 20, RPremium, QBColor(BrightRed))
End Sub

Guardian escreveu:

Valentine escreveu:Isso é muito bom cara, você realmente sabe trabalhar muito bem com tempo, você está de parabéns, eu fiz algo do tipo, mas esse seu sistema de premmy trabalha com horas também? por exemplo: eu adiciono 2 dias de premmy no dia 15 de julho as 17:21 e ela acabar dia 17 as 17:21?

Eu sei que você pode usar DateDiff para fazer uma segunda condição, mas não tem alguma condição única?

Valeu Valentine.
Este sistema exatamente não trabalha com Horas, ele só vai tirar por dia. Se você adicionou um Premium no dia 15 de julho as 17:21. Ele só será retirado no dia 16 de Julho.

Mas claro, como você mesmo disse... Eu posso usar o DateDiff pra fazer uma segunda condição. Mas tem uma solução melhor.

Criar na Estrutura do player isso : Player(Index).Time

Então no HandleChangeVip, você vai por pra Player(Index).Time = Time. Visual Basic 6 por padrão vai pegar o "Time" que é o horário atual de quem ta hosteando o Servidor.

Então você pode usar o CheckPremium que tem neste tutorial. Só que ai você vai adicionar o CheckPremium em vários locais primordiais do jogo pra checar a todo momento. Entende ?

Ai na Sub CheckPremium, você cria uma condição dentro dessa condição :

Código:

If DateDiff("d", GetPlayerStartPremium(index), Date) < GetPlayerDaysPremium(index) Then

Ai nessa condição ai em cima ao invés de deixar : <
Você coloca : <=

Porque ai você estaria no dia, então você cria a condição do timer, que seria algo do tipo :

Código:

If Time > Player(Index).Time Then
SetPlayerPremium(Index, "Não")
End If

Espero que tenha respondido. kkkk'
E isso foi quase um tutorial... LOL

+1 credito pra tu xD

lucas1802012 escreveu:aki de tudo certo mas quando um player ganha o vip quando ele sai do jogo e entra o vip some pq ?
me ajuda aki pfv