Sistema de Premium por Data

por Eduardo01 Qui Jul 26, 2012 4:23 pm

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 :

Sistema de Premium por Data TutorialPremium

Sistema de Premium por Data TutorialPremium

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 :

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

por Corrupted Qui Jan 26, 2017 6:18 am

Como faço pra apenas quem é premium quado clicar em um botão que aparece um picturebox mas precisa ser premium
e se não for premium aparecer uma mensagem " você não é Premium"?
Edit: Desculpa reviver o topico, é que não achei o codigo.

por gui408 Qui Jan 26, 2017 4:12 pm

Parceiro olha a data do topico, area errada, vai em duvidas e pedidos, e se vc procurar em tutoriais vc vai achar isso que vc quer, da uma pesquisada antes Very Happy

por Conteúdo patrocinado

Hitskin.com

Sistema de Premium por Data

Sistema de Premium por Data

Re: Sistema de Premium por Data

Re: Sistema de Premium por Data

Re: Sistema de Premium por Data