Character Banning

From VbGORE Visual Basic Online RPG Engine

Introduction

This custom feature by NotExistant, makes it so you can ban characters using the following backslash command. This code will automatically unban the player once their ban is up. <vb> /ban <player> <days> <reason> </vb>

Database

Rename your banned_ips table to banned also add the following columns. char days banon unbanon time

Adding the code

Search for: <vb>data_GM_banip</vb> in you're server select the whole sub and replace it with: <vb>Sub Data_GM_Ban(ByRef rBuf As DataBuffer, ByVal UserIndex As Integer) '***************************************************************** 'GM bans '<Name(S)><Days(I)><Reason(S)> 'More info: http://www.vbgore.com/GameServer.TCP.Data_GM_BanIP '***************************************************************** Dim Char As String Dim Reason As String Dim days As Integer Dim i As Long

   Log "Call Data_GM_Ban([" & ByteArrayToStr(rBuf.Get_Buffer) & "]," & UserIndex & ")", CodeTracker '//\\LOGLINE//\\
   
   'Get the IP and reason
   Char = rBuf.Get_String
   days = rBuf.Get_Integer
   Reason = rBuf.Get_String
   
   'Confirm that the user has a high enough GM level
   If UserList(UserIndex).Flags.GMLevel = 0 Then Exit Sub
   
   'Check if the character exists
   DB_RS.Open "SELECT `name` FROM `users` WHERE `name`='" & Char & "'", DB_Conn, adOpenStatic, adLockOptimistic
   If DB_RS.EOF Then
       'does not exist
       Data_Send ToIndex, UserIndex, cMessage(98).Data
       DB_RS.Close
       Exit Sub
   End If
   DB_RS.Close
   'Check for a reason and IP
   If LenB(Char) = 0 Then Exit Sub
   If LenB(Reason) = 0 Then Exit Sub
   If days <= 0 Then Exit Sub
   
   'Check if the character is in the database
   DB_RS.Open "SELECT * FROM banned WHERE `char`='" & Char & "'", DB_Conn, adOpenStatic, adLockOptimistic
   If Not DB_RS.EOF Then
       'Character already exists
       DB_RS.Close
       Data_Send ToIndex, UserIndex, cMessage(98).Data
       Exit Sub
   End If
   DB_RS.Close
   'Add the IP and reason to the database
   DB_RS.Open "SELECT * FROM banned WHERE 0=1", DB_Conn, adOpenStatic, adLockOptimistic
   DB_RS.AddNew
   DB_RS!Char = Char
   DB_RS!Reason = Reason
   DB_RS!days = days
   DB_RS!banon = Format(Date, "yyyy-mm-dd")
   DB_RS!unbanon = Format(DateAdd("d", days, Date), "yyyy-mm-dd")
   DB_RS!Time = Format(Time, "HH:mm:ss")
   DB_RS.Update
   DB_RS.Close
   
   'Send the success message
   Data_Send ToIndex, UserIndex, cMessage(99).Data
   
   'Check if anyone online is affected by the ban
   For i = 1 To LastUser
       If UserList(i).Flags.UserLogged Then
           If charbanned(UserList(i).Name) Then
               ConBuf.PreAllocate 3 + Len(Reason)
               ConBuf.Put_Byte DataCode.Server_Message
               ConBuf.Put_Byte 100
               ConBuf.Put_String Reason
               Data_Send ToIndex, i, ConBuf.Get_Buffer
               Data_Send_Buffer i
               Server_CloseSocket i
           End If
       End If
   Next i

End Sub </vb>

You will then have to do a search for the following things. Search for: banned_ips Replace all with: banned

Search for: gm_banip Replace with: gm_ban

Lastly in the client find: <vb> ElseIf Input_GetCommand("/BANIP") Then</vb> Replace section with: <vb> ElseIf Input_GetCommand("/BAN") Then

       s = Input_GetBufferArgs 'Remove the command
       If LenB(s) < 4 Then 'Not enough information entered
           Engine_AddToChatTextBuffer Message(92), FontColor_Info
           GoTo CleanUp
       End If
       TempS = Split(s, " ", 3) 'Split up the IP and reason
       If IsNumeric(TempS(1)) = False Then
           Engine_AddToChatTextBuffer Message(92), FontColor_Info
           GoTo CleanUp
       End If
       s = TempS(0)
       s2 = TempS(1)
       s3 = TempS(2)
       sndBuf.Put_Byte DataCode.GM_Ban
       sndBuf.Put_String Trim$(s)
       sndBuf.Put_Integer Val(Trim$(s2))
       sndBuf.Put_String Trim$(s3)</vb>

and find <vb>Private Sub Input_HandleCommands()</vb> replace all variable declarations with <vb>Dim TempS() As String Dim s As String Dim s2 As Integer Dim s3 As String Dim i As Long Dim j As Long</vb>

Edit oh yeah I forgot a part lol... find:<vb>Sub User_Connect</vb> Replace whole section with:<vb>Sub User_Connect(ByVal UserIndex As Integer, ByVal strName As String, ByVal Password As String, Optional ByVal NewUser As Boolean = False) '***************************************************************** 'Reads the users .chr file and loads into Userlist array 'More info: http://www.vbgore.com/GameServer.TCP.User_Connect '***************************************************************** Dim TempPass As String Dim CharIndex As Integer Dim TempPos As WorldPos Dim LoopC As Byte Dim Count As Byte Dim IPs() As String Dim CurrIP As String Dim s As String Dim i As Byte Dim j As Long

   Log "Call User_Connect(" & UserIndex & "," & strName & "," & Password & "," & NewUser & ")", CodeTracker '//\\LOGLINE//\\

   'Make sure the user is not in use
   If UserList(UserIndex).Flags.UserLogged Then
       Log "User_Connect: User already logged in", CodeTracker '//\\LOGLINE//\\
       Exit Sub
   End If
   
   'Check for valid name and password
   If Not Server_LegalString(strName) Then
       Log "User_Connect: User name (" & strName & ") not legal", CodeTracker '//\\LOGLINE//\\
       Exit Sub
   End If
   If Not Server_LegalString(Password) Then
       Log "User_Connect: Password (" & Password & ") not legal", CodeTracker '//\\LOGLINE//\\
       Exit Sub
   End If
   If Len(strName) > 10 Then
       Log "User_Connect: Name too long", CodeTracker '//\\LOGLINE//\\
       Exit Sub
   End If
   If Len(Password) > 10 Then
       Log "User_Connect: Password too long", CodeTracker '//\\LOGLINE//\\
       Exit Sub
   End If
   If Len(strName) < 3 Then
       Log "User_Connect: Name too short", CodeTracker '//\\LOGLINE//\\
       Exit Sub
   End If
   If Len(Password) < 3 Then
       Log "User_Connect: Password too short", CodeTracker '//\\LOGLINE//\\
       Exit Sub
   End If
   
   If Not NewUser Then
   
       'Check if the character exists (we know that those marked NewUser = True exist since we just made them)
       If Not Server_UserExist(strName) Then
   
           'Tell the client we're disconnecting
           UserList(UserIndex).Flags.UserLogged = 1    'This is required to make the packet go through
           ConBuf.PreAllocate 3 + Len(strName)
           ConBuf.Put_Byte DataCode.Server_Message
           ConBuf.Put_Byte 80
           ConBuf.Put_String strName
           Data_Send ToIndex, UserIndex, ConBuf.Get_Buffer
           Data_Send_Buffer UserIndex
           Exit Sub
           
       End If
   
       'Set up the variables - we only have to do this if not a new char
       ZeroMemory UserList(UserIndex), LenB(UserList(UserIndex))   'Empty the character variables
       UserList(UserIndex).BufferSize = -1                         'Set the buffer start position (-1 = no buffer)
       Set UserList(UserIndex).Stats = New UserStats               'Create the stats class
       UserList(UserIndex).Flags.CreatedStats = 1
       UserList(UserIndex).Stats.UserIndex = UserIndex             'Set the user index
       
   End If
   
   'Set the user as logged in
   UserList(UserIndex).Flags.UserLogged = 1
   
   'Check if the user is on the correct server (pass the map just in case its a new char since they have the map already)
   If User_CorrectServer(strName, UserIndex, UserList(UserIndex).Pos.Map) = 0 Then
       Exit Sub
   End If
   
   'Store the user's IP in a temp variable
   CurrIP = frmMain.GOREsock.Address(UserIndex)
   
   'Check if the user is banned
   If charbanned(strName) Then
       ConBuf.PreAllocate 3 + Len(s)
       ConBuf.Put_Byte DataCode.Server_Message
       ConBuf.Put_Byte 100
       ConBuf.Put_String s
       Data_Send ToIndex, UserIndex, ConBuf.Get_Buffer
       Data_Send_Buffer UserIndex
   End If
   
   'Check if the user is IP banned
   'If Server_IPisBanned(CurrIP, s) Then
   '    ConBuf.PreAllocate 3 + Len(s)
   '    ConBuf.Put_Byte DataCode.Server_Message
   '    ConBuf.Put_Byte 100
   '    ConBuf.Put_String s
   '    Data_Send ToIndex, UserIndex, ConBuf.Get_Buffer
   '    Data_Send_Buffer UserIndex
   '    Exit Sub
   'End If

   'Check to see is user already logged with name
   j = Server_CheckForSameName(UserIndex, strName)
   If j > 0 Then

       'Tell the client we're disconnecting
       Data_Send ToIndex, UserIndex, cMessage(79).Data
       Data_Send_Buffer UserIndex
       
       'Disconnect the user currently on
       UserList(j).Flags.Disconnecting = 1
       
       Exit Sub
       
   End If
   
   'Get the password
   DB_RS.Open "SELECT password FROM users WHERE `name`='" & strName & "'", DB_Conn, adOpenStatic, adLockOptimistic
   TempPass = DB_RS!Password
   DB_RS.Close
   If LenB(TempPass) = 0 Then
   
       'Error getting the password
       Data_Send ToIndex, UserIndex, cMessage(81).Data
       Data_Send_Buffer UserIndex
       Exit Sub
       
   End If
   
   'Check password
   If MD5_String(Password) <> TempPass Then

       'Tell the client we're disconnecting
       Data_Send ToIndex, UserIndex, cMessage(82).Data
       Data_Send_Buffer UserIndex
       Exit Sub
       
   End If
   
   'Update the IP list
   'DB_RS.Open "SELECT ip FROM users WHERE `name`='" & strName & "'", DB_Conn, adOpenStatic, adLockOptimistic

   'First IP entered into the list
   'If LenB(DB_RS!IP) = 0 Then
   '    DB_RS!IP = CurrIP
   '    DB_RS.Update
   
   'Enter in a new IP into the list if its not already in there
   'Else
   '    IPs() = Split(DB_RS!IP, vbNewLine)  'Create the IP list
   '    Count = UBound(IPs)
   '    For LoopC = 0 To Count
   '        If IPs(LoopC) = CurrIP Then
   '            LoopC = 250
   '            Exit For    'IP already in list, abort!
   '        End If
   '    Next LoopC
   '    If LoopC < 250 Then 'Check if we have a unique value
   '        If Count >= 9 Then  'If we have too many IPs already, just add to the bottom of the list
   '            For LoopC = 1 To Count
   '                IPs(LoopC - 1) = IPs(LoopC)
   '            Next LoopC
   '        Else
   '            Count = Count + 1
   '            ReDim Preserve IPs(0 To Count)
   '        End If
   '        IPs(Count) = CurrIP 'Add the new IP to the end of the list
   '        s = vbNullString    'Clear out the string
   '        For LoopC = 0 To Count
   '            s = s & IPs(LoopC)  'Add the IP onto the string
   '            If LoopC < Count Then s = s & vbNewLine 'If not the last entry, add the line break
   '        Next LoopC
   '        DB_RS!IP = s
   '        DB_RS.Update
   '    End If
   'End If
   'DB_RS.Close

   'Load character information from file
   Load_User UserIndex, strName

   'Clear the idle and last packet counter
   UserList(UserIndex).Counters.IdleCount = timeGetTime
   UserList(UserIndex).Counters.LastPacket = timeGetTime

   'Update inventory
   User_UpdateInv True, UserIndex, 0

   'Update number of users
   NumUsers = NumUsers + 1

   'Update map and connection groups data
   MapInfo(UserList(UserIndex).Pos.Map).NumUsers = MapInfo(UserList(UserIndex).Pos.Map).NumUsers + 1

   'Check if it's the first user on the map
   If MapInfo(UserList(UserIndex).Pos.Map).DataLoaded = 0 Or MapInfo(UserList(UserIndex).Pos.Map).NumUsers = 1 Then
       Load_Maps_Temp UserList(UserIndex).Pos.Map
       ReDim MapUsers(UserList(UserIndex).Pos.Map).Index(1 To 1)
   Else
       ReDim Preserve MapUsers(UserList(UserIndex).Pos.Map).Index(1 To MapInfo(UserList(UserIndex).Pos.Map).NumUsers)
   End If
   MapUsers(UserList(UserIndex).Pos.Map).Index(MapInfo(UserList(UserIndex).Pos.Map).NumUsers) = UserIndex

   'Get closest legal pos
   Server_ClosestLegalPos UserList(UserIndex).Pos, TempPos
   If Not Server_LegalPos(TempPos.Map, TempPos.X, TempPos.Y, 0) Then

       'Tell the client we're disconnecting
       Data_Send ToIndex, UserIndex, cMessage(83).Data
       Data_Send_Buffer UserIndex
       User_Close UserIndex
       Exit Sub
       
   End If
   UserList(UserIndex).Pos = TempPos
   
   'Tell the user they have successfully connected
   ConBuf.PreAllocate 7
   ConBuf.Put_Byte DataCode.Server_Connect

   'Tell client to try switching maps
   ConBuf.Put_Byte DataCode.Map_LoadMap
   ConBuf.Put_Integer UserList(UserIndex).Pos.Map
   ConBuf.Put_Integer MapInfo(UserList(UserIndex).Pos.Map).MapVersion
   Data_Send ToIndex, UserIndex, ConBuf.Get_Buffer()

   'Give user a charindex
   CharIndex = Server_NextOpenCharIndex
   UserList(UserIndex).Char.CharIndex = CharIndex
   CharList(CharIndex).Index = UserIndex
   CharList(CharIndex).CharType = CharType_PC

   'Show Character to others
   User_MakeChar ToMap, UserIndex, UserIndex, UserList(UserIndex).Pos.Map, UserList(UserIndex).Pos.X, UserList(UserIndex).Pos.Y

   'Refresh tooltip
   TrayModify ToolTip, Server_BuildToolTipString

   'Send the MOTD
   Data_Send ToIndex, UserIndex, MOTDBuffer()
   
   'If the user already has a weapon equiped with a range, tell what that range is
   If UserList(UserIndex).WeaponEqpObjIndex > 0 Then
       If ObjData.WeaponRange(UserList(UserIndex).WeaponEqpObjIndex) > 0 Then
           ConBuf.PreAllocate 2
           ConBuf.Put_Byte DataCode.User_SetWeaponRange
           ConBuf.Put_Byte ObjData.WeaponRange(UserList(UserIndex).WeaponEqpObjIndex)
           Data_Send ToIndex, UserIndex, ConBuf.Get_Buffer
       End If
   End If

   'Tell the user if they have new mail
   Count = 0
   For LoopC = 1 To MaxMailPerUser
       If UserList(UserIndex).MailID(LoopC) <> 0 Then
           DB_RS.Open "SELECT new FROM mail WHERE id=" & UserList(UserIndex).MailID(LoopC), DB_Conn, adOpenStatic, adLockOptimistic
           If Val(DB_RS!New) = 1 Then Count = Count + 1
           DB_RS.Close
       End If
   Next LoopC
   
   'Send the appropriate message according to how much mail they have
   If Count > 1 Then
       ConBuf.PreAllocate 3
       ConBuf.Put_Byte DataCode.Server_Message
       ConBuf.Put_Byte 71
       ConBuf.Put_Byte Count
       Data_Send ToIndex, UserIndex, ConBuf.Get_Buffer
   ElseIf Count = 1 Then
       Data_Send ToIndex, UserIndex, cMessage(70).Data
   Else
       Data_Send ToIndex, UserIndex, cMessage(69).Data
   End If
   
   'Send the user their quest information for their active quests
   Quest_SendText UserIndex  'Default quest index (0) means send all

   'Send list of known skills
   User_SendKnownSkills UserIndex

   'Connect message
   ConBuf.PreAllocate 3 + Len(UserList(UserIndex).Name)
   ConBuf.Put_Byte DataCode.Server_Message
   ConBuf.Put_Byte 72
   ConBuf.Put_String UserList(UserIndex).Name
   Data_Send ToAll, 0, ConBuf.Get_Buffer, , PP_Connect
   
   'For multiple servers, send to all the servers
   If NumServers > 1 Then
       For i = 1 To NumServers
           If ServerID <> i Then
               Server_ConnectToServer i
               If frmMain.ServerSocket(i).State = sckConnected Then frmMain.ServerSocket(i).SendData ConBuf.Get_Buffer
           End If
       Next i
   End If

End Sub </vb>

And add this function to your tcp.bas <vb>Private Function charbanned(ByVal User As String) As Boolean

   Dim days As Integer
   Dim bannedon As String
   Dim bantime As String
   Dim hms() As String
   Dim i As Integer
   Dim box As String
   DB_RS.Open "SELECT * FROM `banned` WHERE `char`='" & User & "'", DB_Conn, adOpenStatic, adLockOptimistic
   If Not DB_RS.EOF Then
       days = DB_RS!days
       bannedon = DB_RS!banon
       bantime = DB_RS!Time
       DB_RS.Update
       DB_RS.Close
   Else
       charbanned = False
       DB_RS.Close
       Exit Function
   End If
   If DateDiff("d", bannedon, Date) = days Then 'check if the number of days banned has passed
   hms = Split(Format(bantime, "HH:mm:ss"), ":")
       If Val(hms(0)) < Val(Format(Time, "HH")) Or Val(hms(0)) = Val(Format(Time, "HH")) And Val(hms(1)) < Val(Format(Time, "MM")) Then
       'their ban is up remove it from the database
       DB_RS.Open "SELECT `char` FROM `banned` WHERE `char`='" & User & "'", DB_Conn, adOpenStatic, adLockOptimistic
       DB_RS.Delete
       DB_RS.Update
       DB_RS.Close
       charbanned = False
       Else
       charbanned = True
       End If
   ElseIf DateDiff("d", bannedon, Date) > days Then
   'their ban is up remove it from the database
   DB_RS.Open "SELECT `char` FROM `banned` WHERE `char`='" & User & "'", DB_Conn, adOpenStatic, adLockOptimistic
   DB_RS.Delete
   DB_RS.Update
   DB_RS.Close
   charbanned = False
   Else
   charbanned = True
   End If

End Function</vb>