Функции:
Bind(Port As Long, Optional Host As String = "") As Long
Создает сокет, привязывает к порту и адресу
SetRemote(Host As String, Port As Long)
Задает адрес получателя. Как вариант, вызывать при получении первого пакета, когда IP клиента станет известен.
CloseSock() - Знаю, не очень удачное название
Закрывает сокет
SendString(data As String) As Long
Отправляет строку
SendData(data() As Byte, dataLength As Long) As Long
Отправляет массив данных
Ивенты
DataArrival(data() As Byte, dataLength As Long, IP As String)
Получает массив данных с IP отправителя
ConnectError(ErrorCode As Long, Description As String)
Возвращает ошибки
Переменные
LocalIP As String
RemoteIP As String
Код контрола udpsock.ctl:
- Код: Выделить всё
Option Explicit
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 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 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 WSAGetLastError Lib "wsock32.dll" () 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 wsBind Lib "ws2_32.dll" Alias "bind" (ByVal S As Long, ByRef name As sockaddr_in, ByRef namelen As Long) As Long
Private Declare Function sendto Lib "ws2_32.dll" (ByVal S As Long, buf As Any, ByVal Length As Long, ByVal Flags As Long, addrto As sockaddr_in, ByVal tolen As Long) As Long
Private Declare Function recvfrom Lib "ws2_32.dll" (ByVal S As Long, buf As Any, ByVal Length As Long, ByVal Flags As Long, addrfrom As sockaddr_in, ByRef fromlen As Long) As Long
Private Declare Function closesocket Lib "ws2_32.dll" (ByVal S As Long) As Long
Private Declare Function htons Lib "ws2_32.dll" (ByVal hostshort As Integer) As Integer
Private Declare Function inet_ntoa Lib "ws2_32.dll" (ByVal inn As Long) As Long
Private Declare Function inet_addr Lib "ws2_32.dll" (ByVal cp As String) As Long
Private Declare Function gethostname Lib "ws2_32.dll" (ByVal host_name As String, ByVal namelen As Long) As Long
Private Declare Function gethostbyname Lib "ws2_32.dll" (ByVal hostname As String) 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 Const FD_READ = &H1
Event DataArrival(data() As Byte, dataLength As Long, IP As String)
Event ConnectError(ErrorCode As Long, Description As String)
Dim IncSocket As Long
Dim BufferLen As Long
Dim Buff() As Byte
Dim WS As WSAData
Dim RemSts As sockaddr_in
Dim RcvADDS As sockaddr_in
Public LocalIP As String
Public RemoteIP As String
' INIT/TERMINATE
Private Sub UserControl_Initialize()
If WSAStartup(&H202, WS) <> 0 Then
RaiseEvent ConnectError(1, "WSAStartup Failed")
End If
Dim LName As String * 255
gethostname LName, 255
LocalIP = GetIPFromHostName(LName)
BufferLen = 4096
ReDim Buff(BufferLen - 1)
End Sub
Private Sub UserControl_Terminate()
On Error Resume Next
closesocket IncSocket
WSACleanup
End Sub
'' DATA ARRIVAL
Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim bytes As Long
bytes = recvfrom(IncSocket, Buff(0), BufferLen, 0, RcvADDS, LenB(RcvADDS)) 'VarPtr(LenB(RcvADDS)))
If bytes > 0 Then
Dim IP As String
Dim b() As Byte
ReDim b(bytes - 1)
CopyMemory b(0), Buff(0), bytes
IP = Convert(inet_ntoa(CLng(RcvADDS.sin_addr)))
RaiseEvent DataArrival(b, bytes, IP)
Else
RaiseEvent ConnectError(3, "Cannot receive data")
End If
End Sub
'' SENDING DATA
Public Function SendString(data As String) As Long
If Len(data) = 0 Then Exit Function
Dim sBytes As Long
Dim b() As Byte
' Converting to Byte Array
b = StrConv(data, vbFromUnicode)
' Sending
sBytes = sendto(IncSocket, b(0), Len(data), 0&, RemSts, LenB(RemSts))
If sBytes = -1 Then
RaiseEvent ConnectError(2, "Cannot send data")
SendString = -1
End If
End Function
Public Function SendData(data() As Byte, dataLength As Long) As Long
If dataLength = 0 Then Exit Function
Dim sBytes As Long
' Sending
sBytes = sendto(IncSocket, data(0), dataLength, 0&, RemSts, LenB(RemSts))
If sBytes = -1 Then
RaiseEvent ConnectError(2, "Cannot send data")
SendData = -1
End If
End Function
' SETS REMOTE HOST
Public Sub SetRemote(Host As String, Port As Long)
Dim IP As String
IP = Host
If Left$(Host, 1&) <> "1" And Left$(Host, 1&) <> "2" Then
IP = GetIPFromHostName(Host)
Else
IP = Host
End If
With RemSts
.sin_addr = inet_addr(IP)
.sin_family = 2
.sin_port = htons(Port)
End With
RemoteIP = IP
End Sub
' BINDING
Public Function Bind(Port As Long, Optional Host As String = "") As Long
closesocket IncSocket
Dim sST As sockaddr_in
Dim tRe As Long
Dim IP As String
If Host = "" Then
IP = LocalIP
Else
If Left$(Host, 1&) <> "1" And Left$(Host, 1&) <> "2" Then
IP = GetIPFromHostName(Host)
Else
IP = Host
End If
LocalIP = IP
End If
With sST
.sin_addr = inet_addr(IP) ' &H0
.sin_family = 2
.sin_port = htons(Port)
End With
IncSocket = Socket(2, 2, 17) ' 17)
If IncSocket <= 0 Then Bind = -1: RaiseEvent ConnectError(4, "Socket creation error")
tRe = wsBind(IncSocket, sST, LenB(sST))
If tRe <> 0 Then Bind = -1: RaiseEvent ConnectError(5, "Socket binding error")
tRe = WSAAsyncSelect(IncSocket, UserControl.HWND, &H202, FD_READ Or &H20)
If tRe <> 0 Then Bind = -1: RaiseEvent ConnectError(6, "WSAAsyncSelect error")
End Function
' CLOSING SOCKET
Public Sub CloseSock()
closesocket IncSocket
End Sub
'
' ----------------------------------------------------------------------------
'
Private Function GetIPFromHostName(ByVal sHostName As String) As String
Dim ptrHosent 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
'
' ----------------------------------------------------------------------------
'
Public Property Get BufferLength() As Long
BufferLength = BufferLen
End Property
Public Property Let BufferLength(ByVal New_Val As Long)
BufferLen = New_Val
ReDim Buff(BufferLen - 1)
PropertyChanged "BufferLength"
End Property
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
BufferLen = PropBag.ReadProperty("BufferLength", 4096)
If BufferLen = 0 Then Exit Sub
ReDim Buff(BufferLen - 1)
Debug.Print BufferLen
End Sub
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Call PropBag.WriteProperty("BufferLength", BufferLen, 4096)
End Sub
Private Sub UserControl_Resize()
Width = 480
Height = 480
End Sub
