Início
LifeGoldOlá 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 :
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
Agora, na frmMain. Na PicAdmin, crie um botão com o nome cmdAPremium, nele adicione :
- 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
Agora, no final do ModClientTCP adicione :
- 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
No ModDirectDraw7, procure isso :
- Código:
For i = 1 To Action_HighIndex
Call BltActionMsg(i)
Next i
Abaixo adicione :
- Código:
If Premium <> vbNullString Then
Call DrawPremium
End If
Então, no ModEnumerations. Acima disso :
- Código:
' Make sure SMSG_COUNT is below everything else
SMSG_COUNT
Adicione :
- Código:
SPlayerDPremium
SPremiumEditor
Ainda no ModEnumerations, acima disso :
- Código:
' Make sure CMSG_COUNT is below everything else
CMSG_COUNT
Adicione :
- Código:
CRequestEditPremium
CChangePremium
CRemovePremium
Agora, no final do ModGlobals, adicione :
- Código:
' Premium
Public Premium As String
Public RPremium As String
No ModHandleData, procure isso :
- Código:
HandleDataSub(SPartyVitals) = GetAddress(AddressOf HandlePartyVitals)
Abaixo adicione :
- Código:
HandleDataSub(SPlayerDPremium) = GetAddress(AddressOf HandlePlayerDPremium)
HandleDataSub(SPremiumEditor) = GetAddress(AddressOf HandlePremiumEditor)
Então, no final do ModHandleData adicione :
- 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
Agora, no final do ModText adicione :
- 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
Para finalizar o cliente, no ModTypes, procure isso :
- Código:
' Client use only
Acima adicione :
- Código:
' Premium
Premium As String
StartPremium As String
DaysPremium As Long
Server Side
No ModCombat, Na Sub PlayerAttackNpc, ache isso :
No ModCombat, Na Sub PlayerAttackNpc, ache isso :
- Código:
' Calculate exp to give attacker
exp = Npc(npcNum).exp
Abaixo adicione :
- Código:
' Premium
If GetPlayerPremium(attacker) = "Sim" Then
exp = exp * 2
End If
Agora, Na ModEnumerations. Ache isso :
- Código:
' Make sure SMSG_COUNT is below everything else
SMSG_COUNT
Acima, adicione :
- Código:
SPlayerDPremium
SPremiumEditor
Ainda na ModEnumerations, ache isso :
- Código:
' Make sure CMSG_COUNT is below everything else
CMSG_COUNT
Acima, adicione :
- Código:
CRequestEditPremium
CChangePremium
CRemovePremium
Na ModHandleData, ache isso :
- Código:
HandleDataSub(CPartyLeave) = GetAddress(AddressOf HandlePartyLeave)
Abaixo adicione :
- Código:
HandleDataSub(CRequestEditPremium) = GetAddress(AddressOf HandleRequestEditPremium)
HandleDataSub(CChangePremium) = GetAddress(AddressOf HandleChangePremium)
HandleDataSub(CRemovePremium) = GetAddress(AddressOf HandleRemovePremium)
Ainda na ModHandleData, la no final adicione :
- 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
Agora no final da ModPlayer, adicione :
- 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
Agora no final do ModServerTCP, adicione :
- 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
No ModTypes, Na Type PlayerRec, ache isso :
- Código:
Dir As Byte
Abaixo adicione :
- Código:
' Premium
Premium As String
StartPremium As String
DaysPremium As Long
No ModPlayer, ache isso :
- Código:
Call SendWornEquipment(index)
Call SendMapEquipment(index)
Call SendPlayerSpells(index)
Call SendHotbar(index)
Abaixo, adicione :
- Código:
Call CheckPremium(index)
No ModDatabase, Na Sub AddChar, ache isso :
- Código:
Player(index).Class = ClassNum
Abaixo, adicione :
- Código:
Player(index).Premium = "Não"
Player(index).StartPremium = "00/00/0000"
Player(index).DaysPremium = 0
Ainda no ModDatabase, Na Sub ClearPlayer, ache isso :
- Código:
Player(index).Class = 1
Abaixo adicione :
- Código:
Player(index).Premium = "Não"
Player(index).StartPremium = "00/00/0000"
Player(index).DaysPremium = 0
Na ModHandleData, Na Sub HandleLogin, ache isso :
- Código:
' Show the player up on the socket status
Acima, adicione :
- Código:
Call SendDataPremium(index)
Ainda na ModHandleData, na HandleAddChar, ache :
- Código:
Call AddChar(index, Name, Sex, Class, Sprite)
Abaixo adicione :
- Código:
Call SendDataPremium(index)
Créditos : Guardian
