API Winsock реализация через Wsock32.dll и ws2_32.dll

[extHack]

Как реализовать API Winsock приложение. Читал доки, ничего не получается. Где сорцы слить? А то сидеть на ActiveX Winsock уже надоело, библиотеки надо таскать

[Demonx]

http://www.vbip.com/winsock-api/csocket ... ass-01.asp

[tyomitch]

http://killervb.com/WinsockLib.aspx


Ещё у меня есть SOCKS4-прокси через апи, надо кому?

[extHack]

Спасиб, отличные документации

[Sasha_karasov]

http://killervb.com/WinsockLib.aspx


Ещё у меня есть SOCKS4-прокси через апи, надо кому?

Да нужно!

[tyomitch]

Ещё у меня есть SOCKS4-прокси через апи, надо кому?

Да нужно!

Хочется верить...

Код: Выделить всё

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 8) 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 = False
   
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
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
        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
            RecycleSocket NewSocket
        End If
    End If
End Sub

Private Sub Winsock_DataArrival(ByVal Index As Integer)
On Error GoTo Handler
    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
Handler:
    Winsock_Close Index
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


Писано не по спецификации SOCKS, а "шоб работало". У меня работает, но никаких гарантий не даю

[eugene2005]

code не работает

run time error 9
subscript out of range