[EO 2.0]Premium System

[eddy34]

Hello Guys!

Today I am here to teach you how to create a system for your game Premium where the Premium is withdrawn automatically by date. The system is a system Premium many know, only the name system VIP. In this tutorial System Premium gives only two times more experience than the normal player. Other features should be added for you.

We go to the tutorial.

**Client Side**

Client creates a new Form with the name frmEditor_Premium. Let it as follows:


If you do not want to create this form, download it here: [Click Here](http://www.mediafire.com/?q98hsr7l96sc2bp)

Give the following properties for the textbox in order from top to bottom:

**Name : txtPlayer**
**Name : txtSPremium**
**Name : txtDPremium**

Now, take the following properties for commands buttons in order from left to right:

**Name : cmdPremium**
**Name : cmdRPremium**
**Name : cmdExit**

Now enter this code in frmEditor_Premium:

```
' Premium System By : GuardianBR
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
```
Create a button on PicAdmin. She is in frmMain. Put the name cmdAPremium. Then Add :

```
' 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
```
Now, at the end of ModClientTCP add:

```
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
```
In ModDirectDraw7, try this:

```
For i = 1 To Action_HighIndex
        Call BltActionMsg(i)
    Next i
```
Below add:

```
If Premium <> vbNullString Then
    Call DrawPremium
    End If
```
Then, in ModEnumerations. Above that:

```
' Make sure SMSG_COUNT is below everything else
    SMSG_COUNT
```
Add:

```
SPlayerDPremium
    SPremiumEditor
```
Also in ModEnumerations above that:

```
' Make sure CMSG_COUNT is below everything else
    CMSG_COUNT
```
Add :

```
CRequestEditPremium
    CChangePremium
    CRemovePremium
```
Now, at the end of ModGlobals, add:

```
' Premium
Public Premium As String
Public RPremium As String
```
In ModHandleData, try this:

```
HandleDataSub(SPartyVitals) = GetAddress(AddressOf HandlePartyVitals)
```
Below add:

```
HandleDataSub(SPlayerDPremium) = GetAddress(AddressOf HandlePlayerDPremium)
    HandleDataSub(SPremiumEditor) = GetAddress(AddressOf HandlePremiumEditor)
```
Then, at the end of ModHandleData add:

```
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
```
Now, at the end of ModText add:

```
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
```
Finally the customer, in ModTypes, try this:

```
' Client use only
```
Add up:

```
' Premium
    Premium As String
    StartPremium As String
    DaysPremium As Long
```

**Server Side**

In ModCombat, In Sub PlayerAttackNpc, find this:

```
' Calculate exp to give attacker
        exp = Npc(npcNum).exp
```
Below add:

```
' Premium
        If GetPlayerPremium(attacker) = "Sim" Then
        exp = exp * 2
        End If
```
Now In ModEnumerations. Find it:

```
' Make sure SMSG_COUNT is below everything else
    SMSG_COUNT
```
Above, add:

```
SPlayerDPremium
    SPremiumEditor
```
Also in ModEnumerations, find this:

```
' Make sure CMSG_COUNT is below everything else
    CMSG_COUNT
```
Above, add:

```
CRequestEditPremium
    CChangePremium
    CRemovePremium
```
In ModHandleData, find this:

```
HandleDataSub(CPartyLeave) = GetAddress(AddressOf HandlePartyLeave)
```
Below add:

```
HandleDataSub(CRequestEditPremium) = GetAddress(AddressOf HandleRequestEditPremium)
    HandleDataSub(CChangePremium) = GetAddress(AddressOf HandleChangePremium)
    HandleDataSub(CRemovePremium) = GetAddress(AddressOf HandleRemovePremium)
```
Also in ModHandleData, add it at the end:

```
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
```
Now the end of ModPlayer, add:

```
' 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
```
Now the end of ModServerTCP, add:

```
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
```
In ModTypes, PlayerRec In Type, find this:

```
Dir As Byte
```
Below add:

```
' Premium
    Premium As String
    StartPremium As String
    DaysPremium As Long
```
In ModPlayer, find this:

```
Call SendWornEquipment(index)
    Call SendMapEquipment(index)
    Call SendPlayerSpells(index)
    Call SendHotbar(index)
```
Below, add:

```
Call CheckPremium(index)
```
In ModDatabase, In Sub AddChar, find this:

```
Player(index).Class = ClassNum
```
Below, add:

```
Player(index).Premium = "Não"
        Player(index).StartPremium = "00/00/0000"
        Player(index).DaysPremium = 0
```
Also in ModDatabase, In Sub ClearPlayer, find this:

```
Player(index).Class = 1
```
Below add:

```
Player(index).Premium = "Não"
    Player(index).StartPremium = "00/00/0000"
    Player(index).DaysPremium = 0
```
In ModHandleData, In Sub HandleLogin, find this:

```
' Show the player up on the socket status
```
Above, add:

```
Call SendDataPremium(index)
```
Also in ModHandleData in HandleAddChar, find:

```
Call AddChar(index, Name, Sex, Class, Sprite)
```
Below add:

```
Call SendDataPremium(index)
```
Credits: GuardianBR

[Wortel Angels]

Looks very cool :D Thanks for the release ;-)
Nice Second post

[marlongb]

Thank you, very nice tutorial.

How do I create a button to call the "frmEditor_Premium" in "picAdmin"?

[Synergy]

Can you drop the orange first letter.. I know you're trying to make your posts seem that little bit special, but orange on cream/white isn't very contrasting.

Cool tutorial though. :P

[Notsu]

Is this similar to "Membership System" by Richy?

[eddy34]

@marlongb:

> Thank you, very nice tutorial.
>
> How do I create a button to call the "frmEditor_Premium" in "picAdmin"?

I'm sorry, I forgot to put it in the tutorial.

In picAdmin, create a button with the name **cmdAPremium**. Add this to it:

```
' 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
```
Already added to the Tutorial.

@Mortal:

> Looks very cool :D Thanks for the release ;-)
> Nice Second post

Thank You =D

@Synergy:

> Can you drop the orange first letter.. I know you're trying to make your posts seem that little bit special, but orange on cream/white isn't very contrasting.
>
> Cool tutorial though. :P

It is the intent is to make it more beautiful. And I already was thinking about taking it, the hard work. : P

@Notsu:

> Is this similar to "Membership System" by Richy?

I had not seen the tutorial, but is rather similar. Although I think this is more complete.

[Likestodraw]

They both are pretty much the same, though I like this form a LITTLE better. Great work!

[eddy34]

@Likestodraw:

> They both are pretty much the same, though I like this form a LITTLE better. Great work!

Thank You.

It was reported a bug to me where it goes Premium for players who are offline. The error in the server.

So who made ​​the tutorial, I ask you to replace its Sub HandleChangePremium and HandleRemovePremium by these:

```
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
```
I just added a isPlaying If there. :)
Already added in Tutorial.

[DepTa]

I have not tried the tutorial above,
and who would I ask here,

> The system is a system Premium many know, only the name system VIP. In this tutorial System Premium gives only two times more experience than the normal player. Other features should be added for you.

Only two times more experience than the normal player ??
how to add the other, and how?

sorry if this noob question :(

[eddy34]

@DepTa:

> I have not tried the tutorial above,
> and who would I ask here,
>
> Only two times more experience than the normal player ??
> how to add the other, and how?
>
> sorry if this noob question :(

I'm sorry but I do not quite understand your question. It is a system "VIP" where a person who purchases the plan takes two times more experience than normal players. And this system is taken automatically by date.

[DepTa]

Only give more experience if i make Premium System, ?
can i add more item for Premium System , for example item, spirite, equip, and other?

[eddy34]

You will only gain more experience if you do the premium system. What defines it is this code:

```
' Premium
        If GetPlayerPremium(attacker) = "Sim" Then
        exp = exp * 2
        End If
```
You can cut it if you want. ;)
How to add items, equips, sprites, etc.. Yes you can, but you'll have to schedule more things. For example, if you want to add the item application only for premium players, you can. But you have to do it, you know?

Someone can help too, of course. =D

It has the functions GetPlayerPremium on the server only. Then he will do something for the system, just make the server using this function.

[bielcations]

Nice tuto Guard o/
HAHA' Thanks for share your ideas

[tslusny]

Why just dont add access level VIP like i added to my game (and i added my VIP system too) and you can have items and spells required for vip without any work.

And you dont added anything to Sub ServerLoop so bassically if they dont logout, their Premium just wont reset

[eddy34]

I did not apply for access because it is unnecessary. Already have a function outside the GetPlayerPremium would not be necessary for access. The premium to be removed, I put only log out yourself. It was deliberate. :)