Imports DevComponents.DotNetBar Namespace Ihabbox.Tool ''' Allows managing a queue of threads easily Class ThreadsQueue Private TQueue As New Queue(Of Threading.Thread), AsyncManager As Threading.Thread, ObjLock As New Object 'class' main variables Private ReadOnly Priority As Threading.ThreadPriority 'define the priority of the queue ''' Initialize a new instance of the class ThreadsQueue ''' Define the priority of the queue Public Sub New(ByVal QueuePriority As Threading.ThreadPriority) Priority = QueuePriority End Sub ''' Add a thread to the queue ''' The thread which has to be added to the queue Public Sub Enqueue(ByVal Thread As Threading.Thread) TQueue.Enqueue(Thread) 'get the thread into the queue If AsyncManager Is Nothing OrElse Not AsyncManager.IsAlive Then 'check if the ElaborateQueue needs to be started (or restarted) AsyncManager = New Threading.Thread(New Threading.ThreadStart(AddressOf ElaborateQueue)) AsyncManager.Priority = Priority AsyncManager.Start() End If End Sub Private Sub ElaborateQueue() SyncLock ObjLock 'only one thread per queue Dim Thread As Threading.Thread Do Until TQueue.Count = 0 Thread = TQueue.Dequeue Thread.Start() Thread.Join() 'wait until the previous thread is terminated Loop End SyncLock End Sub ''' Stop elaborating the queue and destroy the current instance Public Sub Dispose() If AsyncManager IsNot Nothing AndAlso AsyncManager.IsAlive Then AsyncManager.Abort() 'stop the elaboration Finalize() End Sub End Class ''' VL64 and B64 encoding\decoding (modified Jeax.Habbo.Encoding DLL) Module Encoding ''' Encoding schemes of Habbo Hotel Public Enum EncodingScheme ''' VL64 encoding\decoding scheme VL64 ''' B64 encoding\decoding scheme B64 End Enum ''' Returns an encoded value from the specified encoding type ''' Value to encode ''' The encoding system Public Function Encode(ByVal Value As Object, ByVal Type As EncodingScheme) As String If Type = EncodingScheme.VL64 Then Return Jeax.Habbo.Encoding.VL64.encode(CInt(Value)) Else Return Jeax.Habbo.Encoding.B64.encode(Value.ToString) End Function ''' Returns a decoded value from the specified encoding ''' Value to decode ''' The decoding system Public Function Decode(ByVal Value As String, ByVal Type As EncodingScheme) As Int32 If Type = EncodingScheme.VL64 Then Return Jeax.Habbo.Encoding.VL64.decode(Value) Else Return Jeax.Habbo.Encoding.B64.decode(Value) End Function ''' Checks if a string is a VL64 value ''' String to check Public Function IsVL64(ByVal Value As String) As Boolean Try Jeax.Habbo.Encoding.VL64.decode(Value) 'try decoding Return True 'if success Catch ex As IndexOutOfRangeException Return False 'if decoding fails End Try End Function ''' Multi values decoding ''' Values to decode ''' The decoding system Public Function SuperDecode(ByVal Value As String, ByVal Scheme As EncodingScheme) As Int32() 'the decode function decodes just the first value of the input string (ex. "PAHRA" will return 4 because PA=4) Dim Result As New List(Of Int32), SessionDecode As Int32 Do Until Value.Length = 0 SessionDecode = Decode(Value, Scheme) 'decode the first value Result.Add(SessionDecode) 'save this integer value Value = Value.Remove(0, Encode(SessionDecode, Scheme).ToString.Length) 'remove the already elaborated value Loop Return Result.ToArray End Function End Module ''' Various shared methods Module Various ''' Raises an event in a thread safe way ''' The delegate of the event ''' The parameters of the event Public Sub SafeEvent(ByVal MyEvent As [Delegate], ByVal Parameters() As Object) If MyEvent IsNot Nothing Then Dim CurObj As System.ComponentModel.ISynchronizeInvoke For Each MyDel As [Delegate] In MyEvent.GetInvocationList 'get all the delegates CurObj = CType(MyDel.Target, System.ComponentModel.ISynchronizeInvoke) CurObj.BeginInvoke(MyDel, Parameters) Next End If End Sub ''' Executes one or two splits and returns the desired value ''' String to split ''' The value which is used to split the string ''' Index to return ''' Optional value which is used to split for the secondo time ''' Optional index of the split Public Function DoSplit(ByVal Source As String, ByVal FirstString As String, ByVal Index As Byte, _ Optional ByVal SecondString As String = Nothing, Optional ByVal Index2 As Byte = 0) As String Dim FirstSplit() As String = Source.Split({FirstString}, System.StringSplitOptions.None) If SecondString IsNot Nothing Then Dim SecondSplit() As String = FirstSplit(Index).Split({SecondString}, System.StringSplitOptions.None) Return SecondSplit(Index2) Else : Return FirstSplit(Index) End If End Function ''' Returns the specified string without numbers ''' String to filter Public Function RemoveNumbers(ByVal Value As String) As String Dim Builder As New System.Text.StringBuilder For Each Chr As Char In Value.ToCharArray If Not Chr Like "#" Then Builder.Append(Chr) 'if Chr is not a number then write it Next Return Builder.ToString 'result End Function ''' Sendkeys.SendWait method compatible with all strings and all keyboard layouts and adapted to Habbo ''' Characters to send ''' Checks what has to be sended between ENTER and SHIFT+ENTER in order to shout in Habbo ''' Public Sub SendString(ByVal Send As String, ByVal Shout As Boolean) 'replace the invalid chars (http://msdn.microsoft.com/en-us/library/system.windows.forms.sendkeys.sendwait.aspx) If Send.Contains("{"c) Then Send = Send.Replace("{", "{{}") 'fix the {} string bug If Send.Contains("}"c) Then Dim Count As Int16 = CShort(System.Text.RegularExpressions.Regex.Matches(Send, System.Text.RegularExpressions.Regex.Escape("}")).Count) 'count the }s Dim Index As Int32 Do Until Count = 0 Index = Send.IndexOf("}"c, Index) 'get the index If Send.Substring(CInt(IIf(Index > 0, Index - 1, 0)), 1) <> "{"c Then 'if the previous char is a { then it's for the previous replace Send = Send.Remove(Index, 1).Insert(Index, "{}}") 'replace this } with {}} Index += 3 Else : Index += 1 End If Count -= 1S Loop End If If Send.Contains("("c) Then Send = Send.Replace("(", "{(}") If Send.Contains(")"c) Then Send = Send.Replace(")", "{)}") If Send.Contains("+"c) Then Send = Send.Replace("+", "{+}") If Send.Contains("^"c) Then Send = Send.Replace("^", "{^}") If Send.Contains("%"c) Then Send = Send.Replace("%", "{%}") If Send.Contains("~"c) Then Send = Send.Replace("~", "{~}") Dim PreviousLang As InputLanguage = InputLanguage.CurrentInputLanguage 'get the current system language InputLanguage.CurrentInputLanguage = InputLanguage.FromCulture(New Globalization.CultureInfo("en-US")) 'set system language to English (USA) SendKeys.Send("^{BACKSPACE}") 'send ctrl+backspace ,this keys combination will clean the Habbo's speech textbox If Shout Then SendKeys.SendWait(Send & "+{ENTER}") Else SendKeys.SendWait(Send & "{ENTER}") 'sending keys (if shout is true send shift+enter) InputLanguage.CurrentInputLanguage = PreviousLang 'restore the previous system language End Sub ''' Returns the source code of a web page ''' Page's address ''' Optional cookies which will be added to the request Public Function GetURISource(ByVal URI As Uri, Optional ByVal Cookies As Net.CookieCollection = Nothing) As String 'use httpwebrequest and cookiecontainer to get the source code Dim Request As Net.HttpWebRequest, WebReader As IO.StreamReader = Nothing, Source As String = Nothing Try Request = CType(Net.WebRequest.Create(URI), Net.HttpWebRequest) Request.Method = "GET" If Cookies IsNot Nothing Then Request.CookieContainer = New Net.CookieContainer For Each Cookie As Net.Cookie In Cookies Request.CookieContainer.Add(Cookie) Next End If WebReader = New IO.StreamReader(Request.GetResponse.GetResponseStream) Source = WebReader.ReadToEnd Finally If WebReader IsNot Nothing Then WebReader.Close() GetURISource = Source End Try End Function End Module Namespace Connection ''' VirtualMikle's sockets system Class VMSocket #Region "Declarations and Condition property" 'sockets tcp/ip, data stream Private tcpClient As Net.Sockets.TcpClient, tcpListener As Net.Sockets.TcpListener, NetStream As Net.Sockets.NetworkStream ' socket status, thread for data and disconnection checking Private _Condition As Status = Status.Disconnected, TData As Threading.Thread 'events Public Event Connected As EventHandler Public Event ConnectionRequest As System.ComponentModel.CancelEventHandler Public Event DataArrival(ByVal Data() As Byte) Public Event ConnectionLost As EventHandler ''' The status of the socket Public Enum Status ''' The socket is connected Connected ''' The socket is disconnected Disconnected ''' The socket is waiting a connection request Listening ''' The socket is trying to connect Connecting End Enum ''' Returns the current socket status Public ReadOnly Property Condition As Status Get Return _Condition End Get End Property #End Region #Region "Connect" ''' Starts sending an asynchronous connection request to the specified host ''' The host used for the connection ''' The port used for the connection Public Sub BeginConnect(ByVal Host As String, ByVal Port As Int32) If _Condition = Status.Disconnected Then 'if the socket is not disconnected throw the right exception tcpClient = New Net.Sockets.TcpClient _Condition = Status.Connecting tcpClient.BeginConnect(Host, Port, AddressOf SubConnected, Nothing) Else : Throw New Net.Sockets.SocketException(10037) End If End Sub Private Sub SubConnected(ByVal ar As IAsyncResult) tcpClient.EndConnect(ar) 'close the connection request If tcpClient.Connected Then NetStream = tcpClient.GetStream 'get the Networkstream TData = New Threading.Thread(AddressOf GetData) TData.IsBackground = True TData.Start() 'start checking for new data _Condition = Status.Connected 'set the status SafeEvent(ConnectedEvent, {Me, New EventArgs}) 'raise the event in a thread safe way Else : _Condition = Status.Disconnected End If End Sub #End Region #Region "Listen" ''' Starts listening to a specified port asynchronously ''' The port used for the connection Public Sub BeginListen(ByVal Port As Int32) If _Condition = Status.Disconnected Then 'if the socket is not disconnected throw the right exception tcpListener = New Net.Sockets.TcpListener(Net.IPAddress.Any, Port) 'set the listener tcpListener.Start() 'start listening _Condition = Status.Listening 'set the status tcpListener.BeginAcceptTcpClient(AddressOf ListenComplete, Nothing) 'start checking Else : Throw New Net.Sockets.SocketException(10037) End If End Sub Private Sub ListenComplete(ByVal ar As IAsyncResult) Dim Cancel As New System.ComponentModel.CancelEventArgs SafeEvent(ConnectionRequestEvent, {Me, Cancel}) 'raise the event in a thread safe way If Not Cancel.Cancel AndAlso tcpListener IsNot Nothing Then 'check if the user has not aborted the connection tcpClient = tcpListener.EndAcceptTcpClient(ar) 'accept the request tcpListener.Stop() 'stop listening NetStream = tcpClient.GetStream 'get the networkstream _Condition = Status.Connected TData = New Threading.Thread(AddressOf GetData) TData.IsBackground = True TData.Start() 'start getting data SafeEvent(ConnectedEvent, {Me, New EventArgs}) 'raise the event in a thread safe way End If End Sub #End Region #Region "Data and Close" Private Sub GetData() Dim Buffer() As Byte 'create the buffer Do Until tcpClient.Client.Poll(0, Net.Sockets.SelectMode.SelectRead) AndAlso tcpClient.Available = 0 'check if the socket is still connected If tcpClient.Available > 0 Then 'check if there is new data ReDim Buffer(tcpClient.Available - 1) 'adapt the size of the buffer NetStream.Read(Buffer, 0, Buffer.Length) SafeEvent(DataArrivalEvent, {Buffer}) 'raise the event in a thread safe way End If Loop 'restart the operation 'if the socket is no longer connected destroy all the objects If tcpListener IsNot Nothing Then tcpListener.Server.Dispose() : tcpListener = Nothing If tcpClient IsNot Nothing Then tcpClient.Close() : tcpClient = Nothing If NetStream IsNot Nothing Then NetStream.Dispose() : NetStream = Nothing _Condition = Status.Disconnected 'set the status SafeEvent(ConnectionLostEvent, {Me, New EventArgs}) 'raise the event in a thread safe way End Sub ''' Sends a buffer of data to the remote host ''' Bytes to send Public Sub SendData(ByVal Data() As Byte) 'check if the socket is connected,if it is then send the bytes If _Condition = Status.Connected Then NetStream.Write(Data, 0, Data.Length) Else Throw New Net.Sockets.SocketException(10057) End Sub ''' Sends a buffer of data to the remote host ''' String to send Public Sub SendData(ByVal Data As String) If _Condition = Status.Connected Then 'checks if the socket is connected Dim ByteData() As Byte = System.Text.UTF8Encoding.UTF8.GetBytes(Data) 'get bytes of the string NetStream.Write(ByteData, 0, ByteData.Length) 'send the bytes Else : Throw New Net.Sockets.SocketException(10057) End If End Sub ''' Closes the current connection Public Sub Close() If TData IsNot Nothing AndAlso TData.IsAlive Then TData.Abort() 'stop checking for new data 'destroy all If tcpListener IsNot Nothing Then tcpListener.Server.Dispose() : tcpListener = Nothing If tcpClient IsNot Nothing Then tcpClient.Close() : tcpClient = Nothing If NetStream IsNot Nothing Then NetStream.Dispose() : NetStream = Nothing _Condition = Status.Disconnected 'set the status End Sub #End Region End Class ''' Builds a loader for Habbo Hotel Class LoaderBuilder #Region "Declarations and properties" Private ReadOnly _Mail, _Password, _HotelDomain, _NewHost As String Private TMake As Threading.Thread, _HabboHost, _SWF, _SSO As String, _HabboPort, _ID As Int32 'events Public Event LoginCompleted As EventHandler Public Event DataCompleted As EventHandler Public Event LoaderBuilt As EventHandler Public Event ErrorOccurred(ByVal ex As Exception) ''' Returns the e-mail used to login Public ReadOnly Property Mail As String Get Return _Mail End Get End Property ''' Returns the password of the e-mail Public ReadOnly Property Password As String Get Return _Password End Get End Property ''' Returns the domain of the Hotel Public ReadOnly Property HotelDomain As String Get Return _HotelDomain End Get End Property ''' Returns the spoofed host Public ReadOnly Property NewHost As String Get Return _NewHost End Get End Property ''' Returns the host of the Hotel (requires BeginMakeFile completed) Public ReadOnly Property HabboHost As String Get Return _HabboHost End Get End Property ''' Returns the SWF information of the Hotel (requires BeginMakeFile completed) Public ReadOnly Property SWF As String Get Return _SWF End Get End Property ''' Returns the port of the Hotel (requires BeginMakeFile completed) Public ReadOnly Property HabboPort As Int32 Get Return _HabboPort End Get End Property ''' Returns the Habbo's ID (requires BeginMakeFile completed) Public ReadOnly Property ID As Int32 Get Return _ID End Get End Property ''' Returns the SSO Ticket (requires BeginMakeFile completed) Public ReadOnly Property SSO As String Get Return _SSO End Get End Property #End Region #Region "New and Methods" ''' Initializes a new loader builder ''' The e-mail used to login ''' The password used to login ''' The spoofed host ''' The domain of the Hotel Public Sub New(ByVal Mail As String, ByVal Password As String, ByVal NewHost As String, ByVal Domain As String) If System.Text.RegularExpressions.Regex.IsMatch(Mail, "^\S+@\S+\.\S+$") Then _Mail = Mail Else : Throw New ArgumentException("This address is invalid") End If If String.IsNullOrWhiteSpace(Password) Then Throw New ArgumentException("The inserted password is invalid") Else _Password = Password If String.IsNullOrWhiteSpace(NewHost) Then Throw New ArgumentException("The inserted host is invalid") Else _NewHost = NewHost If String.IsNullOrWhiteSpace(Domain) Then Throw New ArgumentException("The inserted domain is invalid") Else _HotelDomain = Domain End Sub ''' Starts creating a new loader ''' The path where the new loader will be placed ''' Optional nickname of the Habbo to use, if ommitted the default Habbo of the e-mail will be used Public Sub BeginMakeFile(ByVal Path As String, Optional ByVal Username As String = Nothing) If TMake Is Nothing Then TMake = New Threading.Thread(Sub() MakingFile(Path, Username)) 'asynchronous operation With TMake .IsBackground = True .Priority = Threading.ThreadPriority.AboveNormal .Start() End With Else : Throw New InvalidOperationException("The object is already creating a new loader") End If End Sub Private Sub MakingFile(ByVal Path As String, Optional ByVal Username As String = Nothing) Try Dim Request As Net.HttpWebRequest, Response As Net.HttpWebResponse, Buffer() As Byte, Source, HostsPath As String Dim WebWriter As IO.Stream = Nothing, WebReader As IO.StreamReader = Nothing, PreserveCookies As New Net.CookieCollection Dim LoginURI As New Uri("https://www.habbo" & _HotelDomain & "/account/submit") 'first request (logging in via POST and getting cookies) Buffer = System.Text.Encoding.UTF8.GetBytes("credentials.username=" & _Mail & "&credentials.password=" & _Password) Request = CType(Net.WebRequest.Create(LoginURI), Net.HttpWebRequest) With Request .Method = "POST" .ContentType = "application/x-www-form-urlencoded" .ContentLength = Buffer.Length .CookieContainer = New Net.CookieContainer End With Try WebWriter = Request.GetRequestStream WebWriter.Write(Buffer, 0, Buffer.Length) Finally 'this streamer needs to be closed If WebWriter IsNot Nothing Then WebWriter.Close() End Try Try Response = CType(Request.GetResponse, Net.HttpWebResponse) WebReader = New IO.StreamReader(Response.GetResponseStream) Source = WebReader.ReadToEnd For Each Cookie As Net.Cookie In Response.Cookies PreserveCookies.Add(Cookie) Next Finally 'this streamer needs to be closed If WebReader IsNot Nothing Then WebReader.Close() End Try 'second request (selecting habbo) If Username IsNot Nothing Then 'check if the account has that Habbo Source = GetURISource(New Uri("http://www.habbo" & _HotelDomain & "/identity/avatars"), PreserveCookies).ToString If Source.ToUpper.Contains(Username.ToUpper) Then 'the check must be case insensitive 'get Habbo's ID Source = GetURISource(New Uri("http://www.habbo" & _HotelDomain & "/habblet/ajax/new_habboid?habboIdName=" & Username)).ToString _ID = CInt(DoSplit(Source, "", 1, "").Replace(Convert.ToChar(32), String.Empty)) 'set the login uri LoginURI = New Uri("http://www.habbo" & _HotelDomain & "/identity/useOrCreateAvatar/" & _ID.ToString & "?next=") Else 'Source do not contains the username Throw New Exception("The inserted e-mail address doesn't have that user.") End If Else 'the username is nothing, so login using the default habbo LoginURI = New Uri(DoSplit(Source, ";URL=", 1, """>")) End If If Source.Contains("&focus=login-password") Then 'check if the login is actually done Throw New Exception("Your e-mail or your password are incorrect.") Else GetURISource(LoginURI, PreserveCookies) SafeEvent(LoginCompletedEvent, {Me, New EventArgs}) 'rasing a thread safe event 'third request (getting /client source) Source = GetURISource(New Uri("http://www.habbo" & _HotelDomain & "/client"), PreserveCookies).ToString _HabboHost = DoSplit(Source, """connection.info.host"" : """, 1, """,") 'getting Habbo Host and Port 'some Habbo ports are written like this "30000,993" Dim CheckPort As String = DoSplit(Source, """connection.info.port"" : """, 1, """,") _HabboPort = CInt(IIf(CheckPort.Contains(","c), DoSplit(CheckPort, ",", 0), CheckPort)) 'replacing Habbo Loading string If Source.Contains("""client.starting"" : """) Then Source = Source.Replace(DoSplit(Source, """client.starting"" : """, 1, ""","), "Thanks For Using Ihabbox!") End If 'get SSO Ticket If Source.Contains("""sso.ticket"" : """) Then _SSO = DoSplit(Source, """sso.ticket"" : """, 1, """") 'get swf version info If Source.Contains("name=""build"" content=""") Then _SWF = DoSplit(Source, "name=""build"" content=""", 1, Convert.ToChar(32)) 'remove the News page If Source.Contains("
") Then Source = Source.Replace("
", String.Empty) End If SafeEvent(DataCompletedEvent, {Me, New EventArgs}) 'rasing a thread safe event 'write loader file replacing the old host with the new one My.Computer.FileSystem.WriteAllText(Path, Source.Replace(_HabboHost, _NewHost), False) 'Editing Hosts file if needed HostsPath = Environment.SystemDirectory & "/drivers/etc/hosts" 'check if the hosts file contains "[LocalIP] [NewHost]" If Not My.Computer.FileSystem.ReadAllText(HostsPath).Contains("127.0.0.1 " & _NewHost) Then My.Computer.FileSystem.WriteAllText(HostsPath, Environment.NewLine & "127.0.0.1 " & _NewHost _ & " # Added by Ihabbox", True) 'spoof the host End If SafeEvent(LoaderBuiltEvent, {Me, New EventArgs}) 'rasing a thread safe event End If Catch ex As Exception SafeEvent(ErrorOccurredEvent, {ex}) End Try End Sub ''' Stops the creation of the loader Public Sub EndMakeFile() If TMake IsNot Nothing AndAlso TMake.IsAlive Then TMake.Abort() End Sub #End Region End Class End Namespace Namespace Habbos ''' Represents a Habbo Class Habbo Private Packet, _Username, _Motto, _Figure, _RoomID, _ReturnString As String, _RoomIDDecoded, _ID As Int32, _Sex As New Gender ''' The Habbo's gender Public Enum Gender ''' The Habbo is a male Male ''' The Habbo is a female Female End Enum ''' Returns the current Habbo's sex Public Property Sex As Gender Get Return _Sex End Get Set(ByVal Sex As Gender) _Sex = Sex End Set End Property ''' Returns the Habbo's nickname Public ReadOnly Property Username As String Get Return _Username End Get End Property ''' Returns the Habbo's motto Public Property Motto As String Get Return _Motto End Get Set(ByVal Motto As String) _Motto = Motto End Set End Property ''' Returns the Habbo's figure code Public Property Figure As String Get Return _Figure End Get Set(ByVal Code As String) _Figure = Code End Set End Property ''' Returns the Habbo's VL64 Room ID Public ReadOnly Property RoomID As String Get Return _RoomID End Get End Property ''' Returns the Habbo's integer Room ID Public ReadOnly Property RoomIDDecoded As Int32 Get Return _RoomIDDecoded End Get End Property ''' Returns the Habbo's ID Public ReadOnly Property ID As Int32 Get Return _ID End Get End Property ''' Initializes a new Habbo instance ''' The Habbo's nickname ''' The Habbo's ID ''' The Habbo's motto ''' The Habbo's figure code ''' The Habbo's integer Room ID ''' The Habbo's VL64 Room ID ''' The Habbo's sex Public Sub New(ByVal Username As String, ByVal ID As Int32, ByVal Motto As String, ByVal Figure As String, ByVal RoomIDDecoded As Int32, _ ByVal RoomID As String, ByVal Sex As Gender) _Username = Username _ID = ID _Motto = Motto _Figure = Figure _RoomIDDecoded = RoomIDDecoded _RoomID = RoomID _Sex = Sex End Sub End Class ''' Represents a collection of Habbos Class HabboCollection #Region "Declarations and New()" Private HabboList As New List(Of Habbo), TQueue As New ThreadsQueue(Threading.ThreadPriority.Lowest) Private ReadOnly Chr2 As Char = Convert.ToChar(2) 'events Public Event ItemAdded(ByVal Habbo As Habbo) Public Event ItemRemoved(ByVal Habbo As Habbo) #End Region #Region "Get Habbo" Public Shared Function GetHabboFromPacket(ByVal PacketNoHeader As String) As HabboData Dim Result As HabboData = Nothing, Chr2Split() As String = PacketNoHeader.Split({Convert.ToChar(2)}, 7) If Chr2Split(2).Contains(Convert.ToChar(32)) Then 'if the 3rd array contains space char then it must be a pet Dim VL64Builder As New System.Text.StringBuilder, Index As Int32, ReturnString As String 'the first and the second VL64 value have to be removed ReturnString = PacketNoHeader.Substring(PacketNoHeader.IndexOf(Chr2Split(4))) For i As Byte = CByte(1) To 2 Do VL64Builder.Append(ReturnString.Chars(Index)) Index += 1 Loop Until IsVL64(VL64Builder.ToString) ReturnString = ReturnString.Remove(0, VL64Builder.ToString.Length) VL64Builder.Clear() 'reset Index = 0 Next Result = New HabboData(Nothing, ReturnString) Else 'this is an Habbo Dim VL64Builder As New System.Text.StringBuilder, Index As Int32 For i As Byte = 0 To CByte(1) 'the operation must be executed two times Do VL64Builder.Append(Chr2Split(0).Chars(Index)) 'add one char per time Index += 1 Loop Until IsVL64(VL64Builder.ToString) If i = 0 Then 'the first VL64 value is useless,we have to skip it VL64Builder.Clear() Else 'it must be the Habbo's ID Dim ID As Int32 = Decode(VL64Builder.ToString, EncodingScheme.VL64) If ID = -1 Then 'check if this is a bot If Chr2Split(4).Last = Convert.ToChar(1) Then 'check if this the last Habbo (bot) of the entire packet Result = New HabboData(Nothing, String.Empty) Else VL64Builder.Clear() Index = 0 Do 'the first VL64 value has to be removed VL64Builder.Append(Chr2Split(4).Chars(Index)) Index += 1 Loop Until IsVL64(VL64Builder.ToString) Result = New HabboData(Nothing, PacketNoHeader.Substring(PacketNoHeader.IndexOf(Chr2Split(4))).Remove(0, VL64Builder.ToString.Length)) End If Else 'this is a normal Habbo Try Dim RoomIDDecoded As Int32 = Decode(RemoveNumbers(Chr2Split(3)).Trim({"."c}), EncodingScheme.VL64) 'remove numbers and get the value 'start of the instance creation Result = New HabboData( _ New Habbo(Chr2Split(0).Substring(Index), ID, Chr2Split(1), Chr2Split(2), RoomIDDecoded, Encode(RoomIDDecoded, EncodingScheme.VL64), _ CType(IIf(Chr2Split(4).Last = "m"c, Habbo.Gender.Male, Habbo.Gender.Female), Habbo.Gender)), _ PacketNoHeader.Substring(PacketNoHeader.IndexOf(Chr2Split(5)) + Chr2Split(5).Length + 1)) 'end of the instance creation Catch ex As Exception MessageBoxEx.Show(ex.Message, "Error", MessageBoxButtons.OK, MessageBoxIcon.Error) End Try End If End If Next End If Return Result End Function #End Region #Region "Add\Remove Habbos" ''' Creates a list of Habbo objects asynchronously by their @\ packet without the header ''' The @\ packet without the header Public Sub BeginAdd(ByVal PacketNoHeader As String) Dim T As New Threading.Thread(Sub() ThreadAdd(PacketNoHeader)) T.Priority = Threading.ThreadPriority.Lowest T.IsBackground = True TQueue.Enqueue(T) End Sub Private Sub ThreadAdd(ByVal Packet As String) Try Dim H As Habbo, Data As HabboData While Packet.Contains(Chr2) 'loop until there are no more Habbos Data = GetHabboFromPacket(Packet) Packet = Data.PacketRest 'get the rest of the elaboration H = Data.Habbo If H IsNot Nothing Then 'if H is nothing it must be a pet or a bot,so we have to skip it HabboList.Add(H) SafeEvent(ItemAddedEvent, {H}) 'thread safe raiseevent End If End While Catch ex As Exception End Try End Sub ''' Removes an Habbo asynchronously from the list by its decoded Room ID ''' Habbo's decoded Room ID> Public Sub BeginRemove(ByVal RoomID As Int32) Dim T As New Threading.Thread(Sub() ThreadRemove(RoomID)) T.Priority = Threading.ThreadPriority.Lowest T.IsBackground = True TQueue.Enqueue(T) End Sub Private Sub ThreadRemove(ByVal RoomID As Int32) For Each H As Habbo In HabboList If H.RoomIDDecoded = RoomID Then HabboList.Remove(H) SafeEvent(ItemRemovedEvent, {H}) 'thread safe raiseevent Exit For End If Next End Sub #End Region #Region "Clear and Find" ''' Removes every Habbo Public Sub Clear() HabboList.Clear() End Sub ''' Returns the Habbo with the specified username ''' Username used to search the Habbo Public Function Find(ByVal Username As String) As Habbo Find = Nothing For Each Find In HabboList If Find.Username = Username Then Exit For Next End Function ''' Returns the Habbo with the specified room id ''' Decoded Room ID value used to search the Habbo Public Function Find(ByVal RoomID As Int32) As Habbo Find = Nothing For Each Find In HabboList If Find.RoomIDDecoded = RoomID Then Exit For Next End Function #End Region End Class ''' Represents the data got with the GetHabboFromPacket method of the HabboCollection class Class HabboData Private _Habbo As Habbo, _PacketRest As String ''' Returns the Habbo object Public ReadOnly Property Habbo As Habbo Get Return _Habbo End Get End Property ''' Returns the rest of the packet Public ReadOnly Property PacketRest As String Get Return _PacketRest End Get End Property ''' Initializes a new instance ''' The Habbo object ''' The rest of the packet elaboration Public Sub New(ByVal Habbo As Habbo, ByVal PacketRest As String) _Habbo = Habbo _PacketRest = PacketRest End Sub End Class End Namespace End Namespace