1 Sistema de Premium por data Qua 09 Jan 2013, 12:48
Halt
Administrador
Eduardo01 escreveu: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 SubAgora, 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 SubAgora, 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 SubNo ModDirectDraw7, procure isso :
- Código:
For i = 1 To Action_HighIndex
Call BltActionMsg(i)
Next iAbaixo adicione :
- Código:
If Premium <> vbNullString Then
Call DrawPremium
End IfEntão, no ModEnumerations. Acima disso :
- Código:
' Make sure SMSG_COUNT is below everything else
SMSG_COUNTAdicione :
- Código:
SPlayerDPremium
SPremiumEditorAinda no ModEnumerations, acima disso :
- Código:
' Make sure CMSG_COUNT is below everything else
CMSG_COUNTAdicione :
- Código:
CRequestEditPremium
CChangePremium
CRemovePremiumAgora, no final do ModGlobals, adicione :
- Código:
' Premium
Public Premium As String
Public RPremium As StringNo 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 SubAgora, 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 SubPara 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 LongServer Side
No ModCombat, Na Sub PlayerAttackNpc, ache isso :
- Código:
' Calculate exp to give attacker
exp = Npc(npcNum).expAbaixo adicione :
- Código:
' Premium
If GetPlayerPremium(attacker) = "Sim" Then
exp = exp * 2
End IfAgora, Na ModEnumerations. Ache isso :
- Código:
' Make sure SMSG_COUNT is below everything else
SMSG_COUNTAcima, adicione :
- Código:
SPlayerDPremium
SPremiumEditorAinda na ModEnumerations, ache isso :
- Código:
' Make sure CMSG_COUNT is below everything else
CMSG_COUNTAcima, adicione :
- Código:
CRequestEditPremium
CChangePremium
CRemovePremiumNa 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 SubAgora 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 SubAgora 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 SubNo ModTypes, Na Type PlayerRec, ache isso :
- Código:
Dir As Byte
Abaixo adicione :
- Código:
' Premium
Premium As String
StartPremium As String
DaysPremium As LongNo 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 = 0Ainda 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 = 0Na 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