SuBrute

[DJ.KilleR]

http://i034.radikal.ru/0804/4a/3bbe4672ea41.jpg

Super Brute V 1.0 by .snif & JONE
Новый брутфорс для icq который работает без прокси серверов (что предпологает его невысокую скорость). Брут брутит
диапазоны юинов на один пароль. Почему диапазоНЫ спросити вы? Всё просто это первый брутфорс который брутит одновременно
4 диапазона! Тоесть вы одновременно можете брутить сразу 6,7,8,9 знаки!
Так-же эта програмка сварачивается в трей (место возле часов) что позволяет облегчить вам работу за компьютером и сократить количество
открытых вкладок.
В папке с брутом лежит файл JoSkiNe.dll (48kb), его нужно хранить в директории с брутом.
Приятный интерфейс, удобное расположение кнопок и приятный чёрно-сереневый цвет радует глаз при бруте.
Кстати функция "прокси сервер" в этой верси программы недоступна.
Настройки таймаута зависят от скорости интернета, чем выше скорость, тем меньше таймаут (минимум 1800). Рекомендованно юзать его от 2700мс
и выше.
Всё это вы найдёте в Super Brut`e V 1.1.
Авторами брута являются: .snif & JONE.

Скачать (http://forum.asechka.ru/attachment.php?attachmentid=8130&d=1207313893)

[Ergoproxy]

Нужная прога

[ZVEN]

перезалей пожалуйсто на какой нибуть файлообменник

[CaNNabi$]

перезалей пожалуйсто на какой нибуть файлообменник
Вот Рапида (http://rapidshare.com/files/104828050/SuBrute_V1.0.rar.html)
Slil (http://slil.ru/25654132)
ifolder (http://ifolder.ru/6018870)
Deposit (http://depositfiles.com/files/4531723)

Не работает че то он)
Номер и пароль правильный поставил нажал Начать и говорит пароль не правильный пароль)
Еще орфографические ошибки)) как будто 1 класс))
Вот скрин даже) выделил где ошибки)
http://www.valar.ru/tm2/0408/12123124124.jpg
(http://www.valar.ru/upload/jpg/0408/12123124124.htm)
И какой то он глюченный)
Короч по моему туфта)
Но самое ржачное Неправельный пороль http://forum.oszone.net/images/smilies/new/laugh.gif

[Stif]

+1 поржал)

[puyol]

У меня тоже не работает CaNNabi$ +1

[Black dead]

не знаю у кого как у меня на тестовом нуме подобрал правельный пасс и показал его
коректно как я понял работает только при бруте в один поток а не в 4 :mad:

[Dimo4ka14]

жаль у меня тоже неработает((( идея хорошая но надо доработать

[Xcontrol212]

Сорцы прилагаються?

[CaNNabi$]

Неа и сказали что не будет сорцов)
Нах тебе такие сорцы)
Такого бажного брутфорса я впервые вижу чсно слово)

[m9chik]

Прога полный сакс,ищем по месту жительства авторов берём лопаты и едим к ним...

[Imobile]

Аналогично, фигня редкая не сбрутила ни одного из 5-ти подставных номеров.

[Mav]

брут рабочий..

[CaNNabi$]

брут рабочий..
Покажи скрин, а лучше видео где он нормально сбрутил номер ;)

[CyberTm]

Нормально брутит только в 1 поток)))

[Imobile]

Без 4х серверов он не актуален, если IPR идет с ним на уровне, то Sbrute гораздо выше изза удобства.

[Rogun]

1.Какой брут лучше SuBrute или Sbrute?
2.Ещё если брутить Sbrute'ом в две проги(1брутом один диапазон а 2-ым другой) то скорость уменьшается или остаётся прежней?

[Genom2Geri]

1.Какой брут лучше SuBrute или Sbrute?
2.Ещё если брутить Sbrute'ом в две проги(1брутом один диапазон а 2-ым другой) то скорость уменьшается или остаётся прежней?

Я в этом деле нуб...но как мне видеться ответ на этот вопрос щас напишу. А потом кто поопытней скажите мне правильно ли это.

1. Оба брута непользуються проксями по этому они одинаковые, тоесть теже яйца только в профиль. Только SuBrute брутить только по заданному диапозону на одно слово, а SBrute брутить из файла. Тоесть в файле может быть то что ты захочешь, тоесть диапозон на одно слово. Или один уин на кучу слов.
2. Как мне кажеться(ненадо забывать что я нуб)! Ты брутишь с одного IPшника и по этому сервер авторизации ICQ не даст тебе проверить пас к уину чаще чем 1 один раз в 3 секунды, там вроде такой время стоит между запросами на авторизацию. Тоесть ты можешь врубить хоть 100 программ, но брут всё равно будет идти не чаще одного уина в три секунды. Тоесть в начале одна прога подключиться к серверу авторизации и проверит пасс на правильность не правильность потом другая... и так по очереди. Вот моё мнения...

[Jailer]

Ты брутишь с одного IPшника и по этому сервер авторизации ICQ не даст тебе проверить пас к уину чаще чем 1 один раз в 3 секунды, там вроде такой время стоит между запросами на авторизацию.
Для этого сущесвуют другие серверы icq

[Genom2Geri]

Для этого сущесвуют другие серверы icq
А блин точно... ты прав. Говорю же нуб!

[777vip]

Нужная прога
но нерабочая

[*DeViL*]

Те кто говорит что брут не рабочий, я с вами полностью не согласен, ( свой я номер не пробовал брутить, но на 8* тестил ) если надо могу скрин сделать в доказательство )) пока сбрутил 2 момера) рабит вроде нормально...

[*DeViL*]

http://img100.imageshack.us/img100/6576/31340549ck3.th.jpg (http://img100.imageshack.us/my.php?image=31340549ck3.jpg)
Вот скрин доказывающий работоспособность данного брута...

[GAVVVR]

Нифига не брутит. Мой собственный пароль говорит - неверный

[FIND_ERROR]

у меня есть подобный... также сам писал... скорость выходит 200 uin ов в 15 минут...
если нужно могу скинуть...

[xxChaoSxx]

если нужно могу скинуть...
брут в студию

[AllenZ]

Да фигня этот брут... У меня на деде с каналом в 7 метров за 3 суток прошёл токо 140к номеров....

[Rogun]

да ну что то брут дейсствительно какашенция, мой юин:пасс он несмог из небольшого диапазона сбрутить....:/
Sbrute хоть и медленно но верно брутит:/

[FIND_ERROR]

брут в студию
воть... http://www.mediafire.com/?dg33cxn3jdy

[Rogun]

воть... http://www.mediafire.com/?dg33cxn3jdy
И чем же этот брут отличается от других? и где показывает ППС?

[FIND_ERROR]

И чем же этот брут отличается от других?
а я и неговорил что он чем то особенным отличаеться, я сказал что есть что то подобное... попросили скинул...
и где показывает ППС?
непоказывает...

[Rogun]

Да ну этот брут жёстко пропускает пароли! я ввёл небольшой диапазон + и - 10 и там специально был валидные uin пасс и он ненашол нефига!!

[Genom2Geri]

Да ну этот брут жёстко пропускает пароли! я ввёл небольшой диапазон + и - 10 и там специально был валидные uin пасс и он ненашол нефига!!
Ненравиться не пользуйся

[m9chik]

Да ну этот брут жёстко пропускает пароли! я ввёл небольшой диапазон + и - 10 и там специально был валидные uin пасс и он ненашол нефига!!
просто у тебя руки не из того места ростут,повторюсь прога найс сбрутила уже не одну семёрку :) про девятки ваще молу... за ночь ловит более 500 штук...автору повторный респект ;)

[Ol1garch]

люди, юзайте xAIM! на канале ~5mbit держит >15 pps(до 20 доходит, стабильно!)

[Lucky_Student]

Олигарх, этот брут требует проксики или нед?
И дай на него ссылочку, желательно на тему с его описанием

[Genom2Geri]

Lucky_Student...блин...
он без проксей. юзай гугл и найдёшь брут. какое нафиг описание? бруты вообще не требуют описания они и так все просты до безобразия.

[Ol1garch]

прокси не нужны...
http://files.mail.ru/LP6Q5N
парль на архив inattack.ru_xaim
с вас + ;)
тока лучше не юзать опцию его бота... глючит...

[Sn1ckers]

Спасибо за прогу. Очень хорошо когда нет необходимости в проксях

[Lucky_Student]

Геном, спасибо - что такое бруты разбираюсь, можешь поверить... Описание его возможностей, ога ;)

За прогу спс, чуть позже гляну что такое.. :)

[Genom2Geri]

Геном, спасибо - что такое бруты разбираюсь, можешь поверить... Описание его возможностей, ога ;)

За прогу спс, чуть позже гляну что такое.. :)
мону, но не буду. вопросы странные задоёшь.

[Lucky_Student]

Вопросы вполне нормальные, просто видимо до кого-то не доходят =/

[Aleks]

Перезалей

не качает

[sparrow3000]

Перезалей
не качает


он не актуален

[Aleks]

он не актуален


Всё понятно ок

[TrambleR]

он 90% гудов пропускает

[Ugol]

он 90% гудов пропускает


так а ты пробовал брутить- и пропускает

[sparrow3000]

так а ты пробовал брутить- и пропускает


Последний раз редактировалось CaNNabi$, 04.04.2008

и так понятно что ему приёл конец

[lsd55]

Я бручу (SuBrute -1.2) и всё нормально

попробуй этот

[Ugol]

Так а что актуально -взамен( SuBrute )

[alkos]

Так а что актуально -взамен( SuBrute )


из однопоточных брутов самый актуальный AlfaBrute от Луки.

[Ugol]

Ну (AlfaBrute) почему то медлено работает

и пропускает good-не всегда но ...

[TrambleR]

из однопоточных брутов самый актуальный AlfaBrute от Луки.


лол ) альфабрут на старом протоколе работает что дает ему брутить тока девятки(на остальных ступор) я все это декомпилятором искатал. он работает по старому VBicq контролу от карася


Option Explicit
' Socket
Public Enum StateVars
Connecting = 0
Connected = 1
Sending = 2
Sended = 3
Recving = 4
Listening = 5
Accepted = 6
End Enum
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function gethostname Lib "ws2_32.dll" (ByVal host_name As String, ByVal namelen As Long) As Long
Private Declare Function getpeername Lib "ws2_32.dll" (ByVal so As Long, ByRef stru As sockaddr_in, ByRef strulen As Long) As Long
Private Declare Function send Lib "ws2_32.dll" (ByVal s As Long, ByRef buf As Any, ByVal BufLen As Long, ByVal Flags As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (xDest As Any, xSource As Any, ByVal nbytes As Long)
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Any) As Long
Private Declare Function Lis Lib "ws2_32.dll" Alias "listen" (ByVal s As Long, ByVal backlog As Long) As Long
Private Declare Function gethostbyname Lib "wsock32" (ByVal hostname As String) As Long
Private Declare Function inet_ntoa Lib "ws2_32.dll" (ByVal inn As Long) As Long
Private Declare Function htons Lib "ws2_32.dll" (ByVal hostshort As Integer) As Integer
Private Declare Function htonl Lib "ws2_32.dll" (ByVal hostlong As Long) As Long
Private Declare Function Socket Lib "ws2_32.dll" Alias "socket" (ByVal afi As Long, ByVal s_type As Long, ByVal protocol As Long) As Long
Private Declare Function Con Lib "ws2_32.dll" Alias "connect" (ByVal s As Long, ByRef name As sockaddr_in, ByVal namelen As Long) As Long
Private Declare Function VBind Lib "ws2_32.dll" Alias "bind" (ByVal s As Long, ByRef name As sockaddr_in, ByRef namelen As Long) As Long
Private Declare Function WSAAsyncSelect Lib "ws2_32.dll" (ByVal s As Long, ByVal hwnd As Long, ByVal wMsg As Long, ByVal lEvent As Long) As Long
Private Declare Function accept Lib "ws2_32.dll" (ByVal s As Long, addr As sockaddr_in, addrlen As Long) As Long
Private Declare Function recv Lib "ws2_32.dll" (ByVal s As Long, ByVal buf As Any, ByVal BufLen As Long, ByVal Flags As Long) As Long
Private Declare Function closesocket Lib "ws2_32.dll" (ByVal s As Long) As Long
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As Long) As Long
Private Declare Function lstrlenA Lib "kernel32" (lpString As Any) As Long
Private Declare Function inet_addr Lib "ws2_32.dll" (ByVal cp As String) As Long
Private Declare Function WSAStartup Lib "ws2_32.dll" (ByVal wVR As Long, lpWSAD As WSAData) As Long
Private Declare Function WSACleanup Lib "ws2_32.dll" () As Long

Private Type WSAData
wVersion As Integer
wHighVersion As Integer
szDescription As String * 257
szSystemStatus As String * 129
iMaxSockets As Integer
iMaxUdpDg As Integer
lpVendorInfo As Long
End Type
Private Type sockaddr_in
sin_family As Integer
sin_port As Integer
sin_addr As Long
sin_zero(1 To 8) As Byte
End Type

Private Const MAXCONN = &H7FFFFFFF
Private Const FD_READ = &H1
Private Const FD_ACCEPT = &H8
Private Const FD_CONNECT = &H10
Private Const FD_CLOSE = &H20
Private LocalIP As String
Private LocalName As String
Public State As StateVars
Public Server As String
Public Port As Long
Private ConnectedRemoteIP As String
Dim NewSocket As Long
Dim IncSocket As Long
Dim aSocket As Long
Dim imClient As Boolean
Dim tmppIP As String
Dim tmppPort As Long

'VBicq
Dim CLI As Boolean
Dim CliReady As String
Dim MainBuff As String
Dim Flen, mlen As Integer
Dim cook As String
Dim SEQ As Long
Dim Serv2 As String
Dim Port2 As Long
Public uin As String
Public Pass As String
Public Enum IcqStatus
online = "0000"
invisible = "0100"
away = "0001"
NA = "0005"
Occupied = "0011"
DND = "0013"
FFC = "0020"
End Enum
Event GetIcqData(data As String)
Event Connected()
Event IcqError(msg As String)
Event MsgRecv(uin As String, msg As String)
Event SendOK(uin As String)
'///////////////////////////////////////////////////////////////////
' ///////////////////////////// VBsocket блок /////////////////////
'/////////////////////////////////////////////////////////////////
Private Function Connect(host As String, Port As Long)
Dim IP As String
tmppIP = host
tmppPort = Port
Dim cStruct As sockaddr_in
Dim retV As Long
If Left(host, 1) <> 1 Or Left(host, 1) <> 2 Then IP = GetIPFromHostName(host)
cStruct.sin_addr = inet_addr(IP)
cStruct.sin_family = 2
cStruct.sin_port = htons(Port)
State = Connecting
closesocket NewSocket
closesocket aSocket
NewSocket = Socket(2, 1, 6)
WSAAsyncSelect NewSocket, inCON.hwnd, &H202, FD_CONNECT
retV = Con(NewSocket, cStruct, Len(cStruct))
aSocket = NewSocket
End Function
Private Function SendData(data As String) As Boolean
Dim sB() As Byte
Dim sBytes As Long
Dim LensB As Long
InkSEQ
LensB = Len(data)
sB = data
sB() = StrConv(data, vbFromUnicode)
sBytes = send(aSocket, sB(0), LensB, 0&)
If sBytes = -1 Then
SendData = False
Else
SendData = True
State = Sended
End If
End Function
Private Function Listen(Port As Long) As Boolean
closesocket aSocket
Dim sST As sockaddr_in
Dim tRe
sST.sin_addr = &H0
sST.sin_family = 2
sST.sin_port = htons(Port)
IncSocket = Socket(2, 1, 6)
tRe = VBind(IncSocket, sST, LenB(sST))
If tRe = -1 Then
Listen = False
Else
Listen = True
State = Listening
End If
tRe = Lis(IncSocket, MAXCONN)
tRe = WSAAsyncSelect(IncSocket, inC.hwnd, &H202, FD_CONNECT Or FD_ACCEPT)
End Function
Public Sub CloseConnection()
closesocket NewSocket
closesocket IncSocket
closesocket aSocket
End Sub
Private Sub inC_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim ns As sockaddr_in
Dim vRE As Long
aSocket = accept(IncSocket, ns, Len(ns))
ConnectedRemoteIP = Convert(inet_ntoa(ns.sin_addr))
'RaiseEvent Accepted(ConnectedRemoteIP)
WSAAsyncSelect aSocket, inD.hwnd, &H202, FD_READ Or FD_CLOSE
End Sub
Private Sub inCON_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim nst As sockaddr_in
Dim rVal As Long
rVal = getpeername(aSocket, nst, Len(nst))
If rVal = -1 Then
closesocket NewSocket
closesocket aSocket
'RaiseEvent ConnectError
Exit Sub
End If
State = Connected
imClient = True
'RaiseEvent Connected(tmppIP, tmppPort)
WSAAsyncSelect aSocket, inD.hwnd, &H202, FD_READ Or FD_CLOSE
End Sub
Private Sub inD_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error Resume Next
Dim incData As String
incData = GetData
If incData = "" Then
If imClient = True Then Exit Sub
WSAAsyncSelect IncSocket, inC.hwnd, &H202, FD_CONNECT Or FD_ACCEPT
Else
DataArrival incData
End If
End Sub
Private Function GetData() As String
Dim bytes As Long
Dim RB As String * 16384
Dim data As String
bytes = recv(aSocket, RB, 16384, 0)
If bytes > 0 Then
data = Left$(RB, bytes)
GetData = data
Else
GetData = ""
End If
End Function
Private Sub UserControl_Initialize()
Dim ws As WSAData
WSAStartup &H202, ws
Dim MyName As String * 255
gethostname MyName, 255
LocalName = MyName
LocalIP = GetIPFromHostName(MyName)
Server = "login.icq.com"
Port = 5190
End Sub
Private Function GetIPFromHostName(ByVal sHostName As String) As String
Dim nbytes As Long
Dim ptrHosent As Long
Dim ptrName As Long
Dim ptrAddress As Long
Dim ptrIPAddress As Long
Dim sAddress As String
sAddress = Space$(4)
ptrHosent = gethostbyname(sHostName & vbNullChar)
If ptrHosent <> 0 Then
ptrAddress = ptrHosent + 12
CopyMemory ptrAddress, ByVal ptrAddress, 4
CopyMemory ptrIPAddress, ByVal ptrAddress, 4
CopyMemory ByVal sAddress, ByVal ptrIPAddress, 4
GetIPFromHostName = IPToText(sAddress)
End If
End Function
Private Function IPToText(ByVal IPAddress As String) As String
IPToText = CStr(Asc(IPAddress)) & "." & _
CStr(Asc(Mid$(IPAddress, 2, 1))) & "." & _
CStr(Asc(Mid$(IPAddress, 3, 1))) & "." & _
CStr(Asc(Mid$(IPAddress, 4, 1)))
End Function
Private Function Convert(ByVal Inp As Long) As String
Dim pr As String
Dim re As Long
pr = String$(lstrlen(ByVal Inp), 0)
re = lstrcpy(ByVal pr, ByVal Inp)
If re Then Convert = pr
End Function
Private Sub UserControl_Resize()
Width = 450
Height = 405
End Sub
Private Sub UserControl_Terminate()
closesocket NewSocket
closesocket IncSocket
closesocket aSocket
End Sub

'------------------------------------------------------------------------

'///////////////////////////////////////////////////////////////////
' ///////////////////////////// VBicq блок ////////////////////////
'/////////////////////////////////////////////////////////////////

'// вспомогательный функции
' вытаскивает из блока байт
Private Function GetByte(Txt As String, num As Integer) As Byte
GetByte = Asc(Mid$(Txt, num, 1))
End Function

'работа с флэпами
Private Function GetFlapLen(flapdata As String) As Long
Dim HexBuff As String
Dim byte1 As String * 2
Dim byte2 As String * 2
If GetByte(flapdata, 5) <> 0 Then byte1 = Hex(GetByte(flapdata, 5)) Else byte1 = "00"
If GetByte(flapdata, 6) <> 0 Then byte2 = Hex(GetByte(flapdata, 6)) Else byte2 = "00"
HexBuff = "&H" & byte1 & byte2
GetFlapLen = Val(HexBuff)
End Function
Private Function GetFlapSEQ(flapdata As String) As Long
Dim HexBuff As String
HexBuff = "&H" & Hex(GetByte(flapdata, 3)) & Hex(GetByte(flapdata, 4))
GetFlapSEQ = Val(HexBuff)
End Function

Private Function GetFlapData(flapdata As String) As String
GetFlapData = Mid$(flapdata, 7, Len(flapdata) - 6)
End Function

'--------------- работа со снэками ------------
Private Function GetSnacFid(data As String) As Long
Dim HexBuff As String
HexBuff = "&H" & Hex(GetByte(data, 1)) & Hex(GetByte(data, 2))
GetSnacFid = Val(HexBuff)
End Function
Private Function GetSnacSID(data As String) As Long
Dim HexBuff As String
HexBuff = "&H" & Hex(GetByte(data, 3)) & Hex(GetByte(data, 4))
GetSnacSID = Val(HexBuff)
End Function
Private Function GetSnacF1(data As String) As Byte
GetSnacF1 = GetByte(data, 5)
End Function
Private Function GetSnacF2(data As String) As Byte
GetSnacF2 = GetByte(data, 6)
End Function
Private Function GetSnacRID(data As String) As Long
Dim HexBuff As String
HexBuff = "&H" & Hex(GetByte(data, 7)) & Hex(GetByte(data, 8)) & Hex(GetByte(data, 9)) & Hex(GetByte(data, 10))
GetSnacRID = Val(HexBuff)
End Function
Private Function GetSnacData(data As String) As String
GetSnacData = Mid$(data, 11, Len(data) - 10)
End Function

'------------- работа с TLV ----------------
Private Function GetTlvID(data As String) As Long
GetTlvID = Val("&H" & str2hex(Mid$(data, 1, 2)))
End Function
Private Function GetTlvLEN(data As String) As Long
GetTlvLEN = Val("&H" & str2hex(Mid$(data, 3, 2)))
End Function
Private Function GetTlvData(data As String, leng As Long) As String
GetTlvData = Mid$(data, 5, leng)
End Function

'/ппреобразование hex-строк
Private Function GetHEX(ByVal Txt As String) As String
Dim i As Integer
Dim buff As String
For i = 1 To Len(Txt)
buff = Hex(GetByte(Txt, i))
If Len(buff) = 1 Then buff = "0" & buff
GetHEX = GetHEX & buff & " "
Next i
End Function
Private Function hex2str(ByVal data As String) As String
Dim i As Integer
For i = 1 To Len(data) Step 2
hex2str = hex2str & Chr(Val("&H" + Mid$(data, i, 2)))
Next i
End Function
Private Function str2hex(ByVal Txt As String) As String
Dim i As Integer
Dim buff As String
For i = 1 To Len(Txt)
buff = Hex(GetByte(Txt, i))
If Len(buff) = 1 Then buff = "0" & buff
str2hex = str2hex & buff
Next i
End Function
Private Function Word2Str(data As Long) As String
Dim i As Integer
Dim buff As String
buff = Hex(data)
If Len(buff) = 1 Then buff = "000" + buff
If Len(buff) = 2 Then buff = "00" + buff
If Len(buff) = 3 Then buff = "0" + buff
Word2Str = Chr(Val("&H" & Mid$(buff, 1, 2))) + Chr(Val("&H" & Mid$(buff, 3, 2)))
End Function

' счётчик пакетов(нумерация пакетов)
Private Sub InkSEQ()
SEQ = SEQ + 1
If SEQ = 65535 Then SEQ = 0
End Sub

'делает XOR пароль
Private Function CalcPass(ByVal Pass As String) As String
Dim passarr(1 To 16) As Byte
Dim i As Byte
passarr(1) = &HF3
passarr(2) = &H26
passarr(3) = &H81
passarr(4) = &HC4
passarr(5) = &H39
passarr(6) = &H86
passarr(7) = &HDB
passarr(8) = &H92
passarr(9) = &H71
passarr(10) = &HA3
passarr(11) = &HB9
passarr(12) = &HE6
passarr(13) = &H53
passarr(14) = &H7A
passarr(15) = &H95
passarr(16) = &H7C
CalcPass = ""
For i = 1 To Len(Pass)
CalcPass = CalcPass & Chr(Asc(Mid$(Pass, i, 1)) Xor passarr(i))
Next i
End Function

' // главные функции
' сборщег пакетов
Private Sub DataArrival(ByVal data As String)
Dim flen2 As Long
' если свободно
If CLI = False Then
'определим длину флэпа
Flen = GetFlapLen(data)
mlen = Flen + 6
CLI = True
MainBuff = ""
MainBuff = data
Else
MainBuff = MainBuff + data
mlen = mlen + Len(data)
End If
'проверим, не пора ли прекратить сбор пакетов
If mlen = Flen + 6 Then
CLI = False
Flen = 0
Do
Flen = GetFlapLen(MainBuff) + 6
Flapper (Mid$(MainBuff, 1, Flen))
MainBuff = Mid$(MainBuff, Flen + 1, Len(MainBuff) - Flen)
Loop Until Len(MainBuff) = 0
MainBuff = ""
End If
End Sub

' самая главная процелура - распределитель
Private Sub Flapper(data As String)
Dim i, j As Long
Dim n As Integer
Dim fData As String
Dim sData As String
Dim pack, snac, Packl2 As String
Dim r_uin As String
Dim r_msg As String
Dim t_type, t_len As Long
Dim t_len2 As Long
Dim t_data As String

fData = GetFlapData(data)
RaiseEvent GetIcqData("Chanel [" & GetByte(data, 2) & "] " & GetHEX(fData))
'-------- первый канал (установка соединения)
If GetByte(data, 2) = 1 Then
'первый коннект (к autorization server)
If str2hex(fData) = "00000001" And Serv2 <> "" Then
snac = hex2str("00000001")
snac = snac + hex2str("00060100") & cook
pack = hex2str("2A01") + Word2Str(SEQ) + Word2Str(Len(snac)) + snac
SendData (pack)
End If
If str2hex(fData) = "00000001" And Serv2 = "" Then
' если добро на соединение то
SEQ = Rnd * 32767
'идентификация
'/делаем снэк логина
snac = hex2str("00000001")
snac = snac + hex2str("000100") + Chr(Len(uin)) + uin 'TLV01
snac = snac + hex2str("000200") + Chr(Len(CalcPass(Pass))) + CalcPass(Pass) 'TLV02
snac = snac + hex2str("0003008") & "ICQbasic" '
snac = snac + hex2str("00160002010A") '16й TLV
snac = snac + hex2str("001700020018") 'нижняя граница версии протокола(5)
snac = snac + hex2str("001800020025") 'верхняя граница версии протокола
snac = snac + hex2str("001900020001")
snac = snac + hex2str("001A00020E90")
snac = snac + hex2str("0014000400000055")
snac = snac + hex2str("000F0002656E") 'язык (EN)
snac = snac + hex2str("000E00027573") 'местонахождение
pack = hex2str("2A01") + Word2Str(SEQ) + Word2Str(Len(snac)) + snac
SendData (pack)
End If
End If
'-------- второй канал (основной)
If GetByte(data, 2) = 2 Then
' первые Families
If GetSnacFid(fData) = 1 And GetSnacSID(fData) = 3 Then
snac = hex2str("00010017000000000000000100030013000200020001000300 0100150001000400010006000100090001000A0001000B0001")
pack = hex2str("2A02") + Word2Str(SEQ) + Word2Str(Len(snac)) + snac
SendData (pack)
End If
' вторые Families
If GetSnacFid(fData) = 1 And GetSnacSID(fData) = &H18 Then
snac = hex2str("00010006000000000000")
pack = hex2str("2A02") + Word2Str(SEQ) + Word2Str(Len(snac)) + snac
SendData (pack)
End If
'SRV_RATES
If GetSnacFid(fData) = 1 And GetSnacSID(fData) = 7 Then
snac = hex2str("0001000800000000000000010002000300040005")
pack = hex2str("2A02") + Word2Str(SEQ) + Word2Str(Len(snac)) + snac
SendData (pack)

Packl2 = ""
For i = 1 To 6
If i = 1 Then snac = hex2str("000400020000000000000000000000031F4003E703E7000000 00")
If i = 2 Then snac = hex2str("0001000E000000000000")
If i = 3 Then snac = hex2str("00020002000000000000")
If i = 4 Then snac = hex2str("00030002000000000000")
If i = 5 Then snac = hex2str("00040004000000000000")
If i = 6 Then snac = hex2str("00090002000000000000")
pack = hex2str("2A02") + Word2Str(SEQ) + Word2Str(Len(snac)) + snac
InkSEQ
Packl2 = Packl2 & pack
Next i
SendData (Packl2)
SEQ = SEQ - 1
End If
'SRV_REPLYBOS
If GetSnacFid(fData) = 9 And GetSnacSID(fData) = 3 Then
snac = hex2str("00020004000000000004000500055642696371")
pack = hex2str("2A02") + Word2Str(SEQ) + Word2Str(Len(snac)) + snac
SendData (pack)
Packl2 = ""
For i = 1 To 4
If i = 1 Then snac = hex2str("00090007000000000000")
If i = 2 Then snac = hex2str("0001001100000000000000000000")
If i = 3 Then snac = hex2str("0001001E000000000000000600040000000000080002000000 0C002559BD9BDD00000BB80400082DA84E5600000050000000 030000000000000000000000000000")
If i = 4 Then snac = hex2str("00010002000000000000000100030110047B00130002011004 7B000200010101047B000300010110047B001500010110047B 000400010110047B000600010110047B000900010110047B00 0A00010110047B000B00010110047B")
pack = hex2str("2A02") + Word2Str(SEQ) + Word2Str(Len(snac)) + snac
InkSEQ
Packl2 = Packl2 & pack
Next i
SendData (Packl2)
SEQ = SEQ - 1
End If

If GetSnacFid(fData) = &HB And GetSnacSID(fData) = 2 Then RaiseEvent Connected
If GetSnacFid(fData) = 4 And GetSnacSID(fData) = 7 Then
fData = Mid$(fData, 21, Len(fData) - 20)
t_len = GetByte(fData, 1)
r_uin = Mid$(fData, 2, t_len)
For i = 1 To Len(fData)
If str2hex(Mid$(fData, i, 4)) = "00030004" Then
For j = i + 8 To Len(fData)
If str2hex(Mid$(fData, j, 4)) = "00000000" Then
t_len = Val("&H" & Hex(GetByte(fData, j - 2) & Hex(GetByte(fData, j - 1))))
r_msg = Mid$(fData, j, t_len)
r_msg = Strings.Replace(r_msg, Chr(0), "")
r_msg = Strings.Replace(r_msg, Chr(2), "")
RaiseEvent MsgRecv(r_uin, r_msg)
Exit Sub
End If
Next j
End If
Next i
End If
If GetSnacFid(fData) = 4 And GetSnacSID(fData) = &HC Then
fData = Mid$(fData, 21, Len(fData) - 20)
t_len = GetByte(fData, 1)
r_uin = Mid$(fData, 2, t_len)
RaiseEvent SendOK(r_uin)
r_uin = ""
End If
End If

'-------- третий канал (ошибки)
If GetByte(data, 2) = 3 Then
RaiseEvent IcqError(fData)
End If

'-------- четвёртый канал
If GetByte(data, 2) = 4 Then
If GetSnacFid(fData) = 1 And GetSnacSID(fData) = 9 Then RaiseEvent IcqError("Ошибка соединения...")
' если пришли куки
If Mid$(fData, 1, 5) = hex2str("008E000100") Then
fData = Mid$(fData, 6, Len(fData) - 5)
Do
t_type = GetTlvID(fData)
t_len = GetTlvLEN(fData)
t_data = GetTlvData(fData, t_len)
If t_type = 1 Then uin = t_data
If t_type = 5 Then
For i = 1 To Len(t_data)
If Mid$(t_data, i, 1) = ":" Then n = i
Next i
Serv2 = Mid$(t_data, 1, n - 1)
Port2 = Val(Mid$(t_data, n + 1, Len(t_data) - n))
End If
If t_type = 6 Then cook = t_data
fData = Mid$(fData, t_len + 1 + 4, Len(fData) - t_len - 4)
Loop Until Len(fData) = 0
CloseConnection
Connect Serv2, Port2
End If
End If
End Sub

Public Sub login()
Serv2 = ""
Port2 = 0
CloseConnection
Connect Server, Port
End Sub
Public Sub SetStatus(ByVal s_status As String)
Dim pack, snac As String
snac = hex2str("0001001E00000000000000060004") & hex2str("2003") & Word2Str(Val("&h" & s_status))
pack = hex2str("2A02") + Word2Str(SEQ) + Word2Str(Len(snac)) + snac
SendData (pack)
End Sub

Public Sub SendMessage(ByVal m_UIN As String, ByVal m_msg As String)
Dim pack, snac, TLVl2 As String
TLVl2 = hex2str("0501000201010101") & Word2Str(Len(m_msg) + 4) & hex2str("00000000") & m_msg
snac = hex2str("0004000600000001000600000000000000000001") & Chr(Len(m_UIN)) & m_UIN & hex2str("0002") & Word2Str(Len(TLVl2)) & TLVl2 & hex2str("00060000")
pack = hex2str("2A02") + Word2Str(SEQ) + Word2Str(Len(snac)) + snac
SendData (pack)
End Sub

Public Function KeepAlive() As Boolean
Dim snac, pack As String
KeepAlive = False
snac = hex2str("0000")
pack = hex2str("2A05") + Word2Str(SEQ) + Word2Str(Len(snac)) + snac
KeepAlive = SendData(pack)
End Function

отчетливо видно что старый протокол. мои изобретения на VBicq2 который работает по новому протоколу