UDP-контрол

Здесь можно найти готовые «кирпичики» — части кода, пригодные для построения более крупных проектов, а также решения различных типовых и не очень задач на VB.

Модератор: Brickgroup

AWPStar
Начинающий
Начинающий
 
Сообщения: 16
Зарегистрирован: 29.07.2010 (Чт) 2:32

UDP-контрол

Сообщение AWPStar » 15.10.2015 (Чт) 19:16

Контрол для работы с UDP.

Функции:

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
Вложения
udpsock.zip
(2.43 Кб) Скачиваний: 70

Вернуться в Кирпичный завод

Кто сейчас на конференции

Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 1

    TopList