'
' VBSocket - новое имя контролов под старым названием "Тяга"
' VBSocket - максимально облегченный контрол, исправлены все глюки
' "Тяга 1.5" и "Тяга 2В" (последний официально не вышел).
' Наконец-то додана асинхронность в коннекте. Надеюсь, это последний
' мой контрол для работы с сокетами
'
' По всем вопросам обращатся к разработчику, т. е. ко мне:
'                                                            aSharm
'                                                            dasharm@mail.ru
'                                                            www.localhost.co.nr
'                                                            ICQ 2068093
' Ukraine, Ternopol (100% Український продукт!)
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
Public Enum AlertVars
 Yes = 0
 No = 1
End Enum
Public Enum StateVars
 Connecting = 0
 Connected = 1
 Sending = 2
 Sended = 3
 Recving = 4
 Listening = 5
 Accepted = 6
End Enum
Event DataArrival(Data As String)
Event Accepted(IP As String)
Event Connected(IP As String, port As Long)
Event ConnectError()
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 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 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 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 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 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 Function Lis Lib "ws2_32.dll" Alias "listen" (ByVal S As Long, ByVal backlog 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 Const MAXCONN = &H7FFFFFFF
Private Const FD_READ = &H1
Private Const FD_ACCEPT = &H8
Private Const FD_CONNECT = &H10
Private Const FD_CLOSE = &H20
Public AlertMode As AlertVars
Public LocalIP As String
Public LocalName As String
Public State As StateVars
Public 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
Public 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
Public Function SendData(Data As String) As Boolean
If Data = "" Then Exit Function
 Dim sB() As Byte
 Dim sBytes As Long
 Dim LensB As Long
  LensB = Len(Data)
  sB() = StrConv(Data, vbFromUnicode)
  sBytes = send(aSocket, sB(0), LensB, 0&
   If sBytes = -1 Then
    If AlertMode = Yes Then MsgBox "Невозможно передать данные хосту", vbCritical, "Ошибка"
    SendData = False
   Else
    SendData = True
    State = Sended
   End If
End Function
Public 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
   If AlertMode = Yes Then MsgBox "Невозможно слушать порт, наверное он занят", vbCritical, "Ошибка"
   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
 If AlertMode = Yes Then MsgBox "Невозможно установить коннект к хосту " & Host, vbCritical, "Ошибка"
 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
   RaiseEvent 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
   ata = Left$(RB, bytes)
   GetData = Data
  Else
   GetData = ""
  End If
End Function

Private Sub Label1_Click()

End Sub

Private Sub UserControl_Initialize()
 Dim ws As WSAData
  WSAStartup &H202, ws
 Dim MyName As String * 255
  gethostname MyName, 255
  LocalName = MyName
  LocalIP = GetIPFromHostName(MyName)
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 = 465
 Height = 390
End Sub

Private Sub UserControl_Terminate()
 closesocket NewSocket
 closesocket IncSocket
 closesocket aSocket
End Sub

-----------
UserClosed
Выглядит так:
Private Sub S1_UserClosed(id As Long)

End Sub
Событие происходит всегда, когда один из пользователей розрывает соединение.
В параметрах передается уникальный номер розорваного соединения, этот номер
можно теперь считать свободным, и, когда подключится новый пользователь, то
наверняка он "возьмет" этот номер себе.
Пример:
Private Sub S1_UserClosed(id As Long)
MsgBox "Пользователь с номером: " & id & " отключился"
End Sub
-----------

 

Методы

 

-----------
CloseThis
Синтаксис: CloseThis [номер соединения]
Вот так можно закрыть соединение с любым из пользователей.
Пример:
MsgBox "Пользователь номер 5 плохо вел себя в чате, мы его закроем"
S1.CloseThis 5
-----------

Private Sub Command2_Click()
Form2.Show
Unload Form1
End Sub