что это значит?
тёма, я не силён в ВБ и не смогу все жучки твои выковырить самостоятельно, вот вот этот forever loop он так и должен быть или там есть твой жук?
'Forever
Do
Dim Result As Long
Result = WSAWaitForMultipleEvents(Count + 1, Events(0), 0, 1000, 0)
If Result <= Count Then
- Код: Выделить всё
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Src As Any, ByVal Length As Long)
Private Declare Function WSACreateEvent Lib "ws2_32" () As Long
Private Declare Function WSACloseEvent Lib "ws2_32" (ByVal hEvent As Long) As Long
Private Declare Function WSAResetEvent Lib "ws2_32" (ByVal hEvent As Long) As Long
Private Enum FD_BIT
FD_BIT_READ = 0
FD_BIT_WRITE = 1
FD_BIT_OOB = 2
FD_BIT_ACCEPT = 3
FD_BIT_CONNECT = 4
FD_BIT_CLOSE = 5
FD_BIT_QOS = 6
FD_BIT_GROUP_QOS = 7
FD_BIT_ROUTING_INTERFACE_CHANGE = 8
FD_BIT_ADDRESS_LIST_CHANGE = 9
End Enum
Private Const FD_MAX_EVENTS = 10
Private Enum FD
FD_READ = 2 ^ FD_BIT_READ
FD_WRITE = 2 ^ FD_BIT_WRITE
FD_OOB = 2 ^ FD_BIT_OOB
FD_ACCEPT = 2 ^ FD_BIT_ACCEPT
FD_CONNECT = 2 ^ FD_BIT_CONNECT
FD_CLOSE = 2 ^ FD_BIT_CLOSE
FD_QOS = 2 ^ FD_BIT_QOS
FD_GROUP_QOS = 2 ^ FD_BIT_GROUP_QOS
FD_ROUTING_INTERFACE_CHANGE = 2 ^ FD_BIT_ROUTING_INTERFACE_CHANGE
FD_ADDRESS_LIST_CHANGE = 2 ^ FD_BIT_ADDRESS_LIST_CHANGE
FD_ALL_EVENTS = 2 ^ FD_MAX_EVENTS - 1
End Enum
Private Declare Function WSAEventSelect Lib "ws2_32" (ByVal socket As Long, ByVal hEvent As Long, ByVal lNetworkEvents As FD) As Long
Private Declare Function WSAWaitForMultipleEvents Lib "ws2_32" (ByVal cEvents As Long, lphEvents As Long, ByVal fWaitAll As Long, ByVal dwTimeout As Long, ByVal fAlertable As Long) As Long
Private Type WSANETWORKEVENTS
lNetworkEvents As FD
iErrorCodes(FD_MAX_EVENTS) As Long
End Type
Private Declare Function WSAEnumNetworkEvents Lib "ws2_32" (ByVal socket As Long, ByVal hEvent As Long, lpNetworkEvents As WSANETWORKEVENTS) As Long
Private Const SOMAXCONN = &H7FFFFFFF
Private Declare Function listen Lib "ws2_32" (ByVal socket As Long, ByVal backlog As Long) As Long
Private Type sockaddr
sin_family As Integer
sin_port As Integer
sin_addr As Long
sin_zero(1 To
As Byte
End Type
Private Declare Function bind Lib "ws2_32" (ByVal socket As Long, name As sockaddr, namelen As Long) As Long
Private Declare Function connect Lib "ws2_32" (ByVal socket As Long, name As sockaddr, namelen As Long) As Long
Private Declare Function accept Lib "ws2_32" (ByVal socket As Long, addr As sockaddr, addrlen As Long) As Long
Private Const SOCK_STREAM = 1
Private Const AF_INET = 2
Private Declare Function socket Lib "ws2_32" (ByVal af As Long, ByVal stype As Long, ByVal protocol As Long) As Long
Private Declare Function closesocket Lib "ws2_32" (ByVal socket As Long) As Long
Private Declare Function send Lib "ws2_32" (ByVal socket As Long, buf As Any, ByVal Length As Long, ByVal flags As Long) As Long
Private Declare Function recv Lib "ws2_32" (ByVal socket As Long, buf As Any, ByVal Length As Long, ByVal flags As Long) As Long
Private Const WSADESCRIPTION_LEN_1 = 256 + 1
Private Const WSASYS_STATUS_LEN_1 = 128 + 1
Private Type WSADATA
wVersion As Integer
wHighVersion As Integer
szDescription As String * WSADESCRIPTION_LEN_1
szSystemStatus As String * WSASYS_STATUS_LEN_1
iMaxSockets As Integer
iMaxUdpDg As Integer
lpVendorInfo As String
End Type
Private Declare Function WSAStartup Lib "ws2_32" (ByVal wVersionRequested As Integer, lpWSAData As WSADATA) As Long
Private Declare Function WSACleanup Lib "ws2_32" () As Long
Private Sockets() As Long, Events() As Long, Count As Long, Tags() As Variant
Private Const Increment = 256
Private Sub Main()
App.TaskVisible = True
Dim wd As WSADATA
WSAStartup 2, wd
ReDim Sockets(0 To Increment)
ReDim Events(0 To Increment)
ReDim Tags(0 To Increment)
Count = 0
Dim MyName As sockaddr
MyName.sin_family = AF_INET
MyName.sin_port = -27647 '404
Sockets(0) = socket(AF_INET, SOCK_STREAM, 0)
bind Sockets(0), MyName, Len(MyName)
listen Sockets(0), SOMAXCONN
Events(0) = WSACreateEvent
WSAEventSelect Sockets(0), Events(0), FD_ACCEPT
'Forever
Do
Dim Result As Long
Result = WSAWaitForMultipleEvents(Count + 1, Events(0), 0, 1000, 0)
If Result <= Count Then
Dim What As WSANETWORKEVENTS: What.lNetworkEvents = FD_ALL_EVENTS
WSAEnumNetworkEvents Sockets(Result), Events(Result), What
If (What.lNetworkEvents And FD_ACCEPT) Then
Debug.Print ">> FD_ACCEPT"
Winsock_ConnectionRequest Result
Debug.Print "FD_ACCEPT >>"
End If
If (What.lNetworkEvents And FD_CLOSE) Then
Debug.Print ">> FD_CLOSE"
Winsock_Close Result
Debug.Print "FD_CLOSE >>"
End If
If (What.lNetworkEvents And FD_CONNECT) Then
Debug.Print ">> FD_CONNECT"
Winsock_Connect Result
Debug.Print "FD_CONNECT >>"
End If
If (What.lNetworkEvents And FD_READ) Then
Debug.Print ">> FD_READ"
Winsock_DataArrival Result
Debug.Print "FD_READ >>"
End If
'Nothing else processed ATM
End If
Loop
End Sub
Private Sub RecycleSocket(ByVal Index As Integer)
closesocket Sockets(Index)
Sockets(Index) = 0
WSACloseEvent Events(Index)
Events(Index) = Events(0)
Tags(0) = Empty
End Sub
Private Sub SendSocket(ByVal Index As Integer, data() As Byte)
send Sockets(Index), data(LBound(data)), UBound(data) - LBound(data) + 1, 0
End Sub
Private Function AllocSocket() As Long
Dim i As Long
For i = 0 To Count
If Sockets(i) = 0 Then Exit For
Next
If i <= Count Then
AllocSocket = i
Else
If Count = UBound(Sockets) Then
ReDim Preserve Sockets(0 To Count + Increment)
ReDim Preserve Events(0 To Count + Increment)
ReDim Preserve Tags(0 To Count + Increment)
End If
Count = Count + 1: AllocSocket = Count
End If
End Function
Private Sub Winsock_Close(ByVal Index As Integer)
RecycleSocket Index
If Tags(Index) Then 'Data
RecycleSocket Tags(Index)
Else 'Req
End If
End Sub
Private Sub Winsock_Connect(ByVal Index As Integer)
If Tags(Index) Then 'Data
Dim resp(0 To 7) As Byte
resp(1) = 90
' If .State = sckConnected Then
SendSocket Tags(Index), resp
' End If
Else 'Req
Err.Raise 5, "Winsock_Connect", "Unexpected connection!"
End If
Exit Sub
End Sub
Private Sub Winsock_ConnectionRequest(ByVal Index As Integer)
If Index Then 'Data
''not supported
Err.Raise 5, "Winsock_ConnectionRequest", "Unexpected connection!"
Else 'Control
Dim Remote As sockaddr, Length As Long: Length = Len(Remote)
Dim NewSocket As Long: NewSocket = AllocSocket
MsgBox " adr " & Remote.sin_addr
Sockets(NewSocket) = accept(Sockets(Index), Remote, Length)
If Remote.sin_addr = &HD2B418D9 Then '217.24.180.210
Events(NewSocket) = WSACreateEvent
WSAEventSelect Sockets(NewSocket), Events(NewSocket), FD_READ Or FD_CLOSE
Tags(NewSocket) = 0
Else
MsgBox "recycle socket"
RecycleSocket NewSocket
End If
End If
Exit Sub
End Sub
Private Sub Winsock_DataArrival(ByVal Index As Integer)
If Tags(Index) Then 'Data
Dim buffer(0 To 65535) As Byte 'the number is random
Do
Dim Length As Long: Length = recv(Sockets(Index), buffer(0), 65536, 0)
send Sockets(Tags(Index)), buffer(0), Length, 0
Loop Until Length < 65536
Else 'Req
Dim req(0 To 255) As Byte, NewSocket As Long, Remote As sockaddr
recv Sockets(Index), req(0), 256, 0
If req(0) <> 4 Then Err.Raise 5, "Winsock_DataArrival", "Bad SOCKS version!"
If req(1) <> 1 Then Err.Raise 5, "Winsock_DataArrival", "Unsupported command!"
NewSocket = AllocSocket
Remote.sin_family = AF_INET
CopyMemory Remote.sin_port, req(2), 2
CopyMemory Remote.sin_addr, req(4), 4
Sockets(NewSocket) = socket(AF_INET, SOCK_STREAM, 0)
connect Sockets(NewSocket), Remote, Len(Remote)
Events(NewSocket) = WSACreateEvent
WSAEventSelect Sockets(NewSocket), Events(NewSocket), FD_CONNECT Or FD_READ Or FD_CLOSE
Tags(NewSocket) = Index
Tags(Index) = NewSocket
End If
Exit Sub
End Sub
'Private Sub Winsock_Error(Index As Integer, ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
'With Winsock(Index)
' .Close
' If .Tag Then
' With Winsock(.Tag)
' If .State = sckConnected Then
' Dim resp() As Byte: ReDim resp(7)
' resp(1) = 91
' .SendData resp
' .Close
' End If
' End With
' End If
'End With
'End Sub
Private Sub Terminate(Cancel As Integer) 'never called, but wtf
Dim i As Long
For i = 0 To Count
If Sockets(i) Then RecycleSocket i
Next
WSACleanup
End Sub
