求接受/发送组播（Multicast）的源程序

frmUDPSock:(接受event用)
Option ExplicitPrivate Sub Form_Load()
    Set gForm = Me
    ' デフォルトウィンドウハンドルを保存
    glngOriginalhWnd = Me.hWnd
    ' サブクラス化を設定
    glnglpOriginalWndProc = _
        SetWindowLong(glngOriginalhWnd, _
                      GWL_WNDPROC, _
                      AddressOf WmWSAAsyncSelect)
End SubPrivate Sub Form_Unload(Cancel As Integer)
    Dim lngWin32apiResultCode As Long    ' サブクラス化を解除
    lngWin32apiResultCode = _
        SetWindowLong(glngOriginalhWnd, _
                      GWL_WNDPROC, _
                      glnglpOriginalWndProc)
    glngOriginalhWnd = 0
    Set gForm = Nothing
End Sub
basWindowProc（定义了一堆全局的变量以及处理消息的callback函数）
问题就出来这里，我在一个程序里要调用几个socket，这样的话，只有最后一个socket能接收到消息。Option Explicit' 指定されたウィンドウに関する情報を変更する関数の宣言
Declare Function SetWindowLong Lib "user32.dll" _
    Alias "SetWindowLongA" _
   (ByVal hWnd As Long, _
    ByVal nIndex As Long, _
    ByVal dwNewLong As Long) As Long
' ウィンドウプロシージャの新しいアドレスを設定
Public Const GWL_WNDPROC = (-4)' 指定されたウィンドウプロシージャにメッセージ情報を渡す
' 関数の宣言
Declare Function CallWindowProc Lib "user32.dll" _
    Alias "CallWindowProcA" _
   (ByVal lpPrevWndFunc As Long, _
    ByVal hWnd As Long, _
    ByVal Msg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As Long) As Long' 指定された文字列をバッファにコピーする関数の宣言
Declare Function lstrcpy Lib "kernel32.dll" _
    Alias "lstrcpyA" _
   (ByVal lpString1 As String, _
    lpString2 As Any) As StringDeclare Function lstrcpyn Lib "kernel32.dll" _
    Alias "lstrcpynA" _
   (ByVal lpString1 As String, _
    lpString2 As Any, _
    ByVal iMaxLength As Integer) As String' 処理の終了を通知するメッセージ
Public Const WM_USER = &H400
Public Const WM_WSAAsyncSelect = WM_USER + 1000' インターフェースクラス
Public gUDPClass As clsUDPSock
' フォーム（Timerコントロールを実装）
Public gForm As frmUDPSock
' ソケットハンドル
Public glngSocketDescriptor As Long' ウィンドウプロシージャのアドレスを保存する変数
Public glnglpOriginalWndProc As Long
' ウィンドウハンドルを保存する変数
Public glngOriginalhWnd      As Long
'
' サブクラス関数 - 処理の終了を監視
'
Function WmWSAAsyncSelect _
       (ByVal hWnd As Long, _
        ByVal uMsg As Long, _
        ByVal wParam As Long, _
        ByVal lParam As Long) As Long    Dim lngErrorCode          As Long
    Dim lngEvent              As Long
    Dim bytReceiveData(1024)  As Byte
    Dim strReceiveData        As String
    Dim strWork               As String
    Dim lngSocketAddressLen   As Long
    Dim udtSocketAddress      As sockaddr_in
    Dim lngWin32apiResultCode As Long
    Dim lngDottedAddress      As Long
    Dim strDottedAddress      As String * 16

    Dim RecvData As String
    Dim IPAddr As String
    Dim Port As Integer    ' 処理の終了を通知するメッセージのときは
    If uMsg = WM_WSAAsyncSelect Then
        ' エラーコードを取り出す
        lngErrorCode = WSAGETSELECTERROR(lParam)
        ' イベントを取り出す
        lngEvent = WSAGETSELECTEVENT(lParam)
        ' データを受信できたときは
        If lngErrorCode = 0 Then
            Select Case lngEvent
            Case FD_READ
                'ソケットが生成されているか？
                If glngSocketDescriptor <> INVALID_SOCKET Then
                    lngSocketAddressLen = Len(udtSocketAddress)
                    ' ソケットからデータを受信
                    lngWin32apiResultCode = _
                        recvfrom(glngSocketDescriptor, _
                             bytReceiveData(0), _
                             UBound(bytReceiveData), - _
                             0, _
                             udtSocketAddress, _
                             lngSocketAddressLen)
                    If lngWin32apiResultCode = SOCKET_ERROR Then
                        gUDPClass.UDPErrorArrival lngEvent, CLng(WSAGetLastError())
                    Else
                        'ポート番号を取得
                        Port = ntohs(udtSocketAddress.sin_port)
                        'ＩＰアドレスを文字列に変換
                        lngDottedAddress = inet_ntoa(udtSocketAddress.sin_addr.S_addr)
                        strDottedAddress = lstrcpy(strDottedAddress, ByVal lngDottedAddress)
                        strWork = strDottedAddress
                        IPAddr = _
                            Left(strWork, _
                                 InStr(strWork, _
                                       vbNullChar) - 1)
                        '受信したデータを設定
                        '文字コードを変換
                        strWork = _
                            StrConv(bytReceiveData, _
                                    vbUnicode)
                        strReceiveData = _
                            Left(strWork, _
                                 InStr(strWork, _
                                       vbNullChar) - 1)

                        '受信したデータを渡す modified by rong 03/07/14
                        gUDPClass.UDPDataArrival bytReceiveData, IPAddr, Port, lngSocketAddressLen
                    End If
                End If
            Case FD_CONNECT
                'マルチキャストの接続が完了しました。
                gUDPClass.UDPConnected lngErrorCode
            End Select
        Else
            ' 受信したエラーを渡す
            gUDPClass.UDPErrorArrival lngEvent, lngErrorCode
        End If
    Else
        ' オリジナルウィンドウプロシージャへメッセージを渡す
        WmWSAAsyncSelect = _
            CallWindowProc(glnglpOriginalWndProc, _
                           hWnd, _
                           uMsg, _
                           wParam, _
                           lParam)
    End If
End FunctionPrivate Function WSAGETSELECTEVENT(lParam As Long) As Long
    WSAGETSELECTEVENT = lParam And &HFFFF&
End FunctionPrivate Function WSAGETSELECTERROR(lParam As Long) As Long
    WSAGETSELECTERROR = (lParam \ 2 ^ 16) And &HFFFF&
End Function
clsSocket（part1）:
里面一堆垃圾，原先看来想用timer来控制，后来改用form来处理了。
Option ExplicitPublic Enum MCastFlag
    mcfSend = JL_SENDER_ONLY
    mcfRecv = JL_RECEIVER_ONLY
    mcfBoth = JL_BOTH
End EnumPublic Enum CastMode
    cmUnicast = 1
    cmMulticast = 2
End EnumPrivate mMulticastHandle As Long
Private mHandle As Long
Private mCastMode As CastMode
Private mErrorCode As Long
Private mudtWSAData As WSAData
Private mProtocolInfo As WSAPROTOCOL_INFOProperty Get Handle() As Long
    Handle = mHandle
End PropertyProperty Get ErrorCode() As Integer
    ErrorCode = mErrorCode
End PropertyPrivate Sub Class_Initialize()
    StartUp
End SubPrivate Sub Class_Terminate()
    FreeSocket
End SubPrivate Function StartUp() As Boolean
    Dim lngWin32apiResultCode As Long
    StartUp = False

    ' Winsockの使用を開始
    lngWin32apiResultCode = _
        WSAStartup(MAKEWORD(2, 2), _
                   mudtWSAData)
    If lngWin32apiResultCode <> 0 Then
        'WSAGetLastErrorをCallしてはいけません。
        mErrorCode = lngWin32apiResultCode
        Exit Function
    End If    StartUp = True
End FunctionPrivate Function UnicastOpenSocket() As Boolean
    Dim lngWin32apiResultCode As Long
    Dim lngOptionValue As Long

    UnicastOpenSocket = False

    ' ソケットを作成
    mHandle = _
        socket(AF_INET, _
               SOCK_DGRAM, _
               0)
    If mHandle = INVALID_SOCKET Then
        mErrorCode = WSAGetLastError()
        Exit Function
    End If

    ' ソケットオプションを指定
    lngOptionValue = CLng(1)
    ' ソケットオプションを設定
    lngWin32apiResultCode = _
       setsockopt(mHandle, _
                  SOL_SOCKET, _
                  SO_REUSEADDR, _
                  lngOptionValue, _
                  Len(lngOptionValue))
    If lngWin32apiResultCode = SOCKET_ERROR Then
        mErrorCode = WSAGetLastError()
        Exit Function
    End If    UnicastOpenSocket = True
End FunctionPrivate Function MulticastOpenSocket() As Boolean
    Dim lngWin32apiResultCode As Long
    Dim lngOptionValue As Long    MulticastOpenSocket = False

    ' ソケットを作成
    mHandle = _
        WSASocket(AF_INET, _
                  SOCK_DGRAM, _
                  IPPROTO_UDP, _
                  mProtocolInfo, _
                  0, _
                  (WSA_FLAG_MULTIPOINT_C_LEAF Or _
                  WSA_FLAG_MULTIPOINT_D_LEAF Or _
                  WSA_FLAG_OVERLAPPED))
    If mHandle = INVALID_SOCKET Then
        mErrorCode = CLng(WSAGetLastError())
        Exit Function
    End If

    ' ソケットオプションを指定
    lngOptionValue = CLng(1)
    ' ソケットオプションを設定
    lngWin32apiResultCode = _
       setsockopt(mHandle, _
                  SOL_SOCKET, _
                  SO_REUSEADDR, _
                  lngOptionValue, _
                  Len(lngOptionValue))
    If lngWin32apiResultCode = SOCKET_ERROR Then
        mErrorCode = CLng(WSAGetLastError())
        Exit Function
    End If    MulticastOpenSocket = TrueEnd FunctionPrivate Function FreeSocket() As Boolean
    Dim lngWin32apiResultCode As Long

    FreeSocket = False
    ' ソケットをクローズ
    lngWin32apiResultCode = _
        closesocket(mHandle)
    If lngWin32apiResultCode = SOCKET_ERROR Then
        mErrorCode = WSAGetLastError()
        Exit Function
    End If    ' Winsockの使用を終了
    lngWin32apiResultCode = _
        WSACleanup()
    If lngWin32apiResultCode = SOCKET_ERROR Then
        mErrorCode = WSAGetLastError()
        Exit Function
    End If    FreeSocket = True
End FunctionPublic Function OpenSocket(Optional Mode As CastMode = cmUnicast) As Boolean
    mCastMode = Mode 'メンバ変数へ設定

    If mCastMode = cmUnicast Then
        OpenSocket = UnicastOpenSocket()
    Else
        OpenSocket = MulticastOpenSocket()
    End If
End FunctionPublic Function BindSocket _
            ( _
             IPAddr As String, _
             Port As Integer _
            ) As Boolean

    Dim udtSocketAddress      As sockaddr_in
    Dim lngWin32apiResultCode As Long    BindSocket = False

    ' ソケットの情報を指定
    With udtSocketAddress
        .sin_family = _
            AF_INET
        .sin_port = _
            htons(Port)
        .sin_addr.S_addr = _
            inet_addr(IPAddr)
'        .sin_addr.S_addr = INADDR_ANY

    End With
    ' ローカルアドレスをソケットに関連付け
    lngWin32apiResultCode = _
        bind(mHandle, _
             udtSocketAddress, _
             Len(udtSocketAddress))
    If lngWin32apiResultCode = SOCKET_ERROR Then
        mErrorCode = WSAGetLastError()
        Exit Function
    End If

    BindSocket = True
End FunctionPublic Function JoinReaf _
            ( _
             IPAddr As String, _
             Port As Integer, _
             Flag As MCastFlag _
            ) As Boolean

    Dim udtSocketAddress        As sockaddr_in
    Dim lngSocketAddressLen     As Long
    Dim lngWin32apiResultCode   As Long
    Dim lngOptionValue          As Long
    Dim cbRet                   As Long
    Dim dwFlag                  As Long
'    Dim nIP_TTL                 As integer
    Dim nIP_TTL                 As Long

    JoinReaf = False
    'マルチキャストスコープを設定
    nIP_TTL = 2
    lngWin32apiResultCode = _
        WSAIoctl(mHandle, _
                 SIO_MULTICAST_SCOPE, _
                 nIP_TTL, _
                 Len(nIP_TTL), _
                 ByVal CLng(0), _
                 0, _
                 cbRet, _
                 ByVal 0, _
                 ByVal 0)
    If lngWin32apiResultCode = SOCKET_ERROR Then
        mErrorCode = WSAGetLastError()
        Exit Function
    End If

    'ループバックをしない
    lngOptionValue = CLng(1)
    lngWin32apiResultCode = _
        WSAIoctl(mHandle, _
                 SIO_MULTIPOINT_LOOPBACK, _
                 lngOptionValue, _
                 Len(lngOptionValue), _
                 ByVal CLng(0), _
                 0, _
                 cbRet, _
                 ByVal 0, _
                 ByVal 0)
    If lngWin32apiResultCode = SOCKET_ERROR Then
        mErrorCode = WSAGetLastError()
        Exit Function
    End If

    ' ソケットの情報を指定
    With udtSocketAddress
        .sin_family = _
            AF_INET
        .sin_port = _
            htons(Port)
        .sin_addr.S_addr = _
            inet_addr(IPAddr)

    End With

    'マルチキャストに参加
    mMulticastHandle = _
        WSAJoinLeaf(mHandle, _
                    udtSocketAddress, _
                    Len(udtSocketAddress), _
                    ByVal CLng(0), _
                    ByVal CLng(0), _
                    ByVal CLng(0), _
                    ByVal CLng(0), _
                    Flag)
    If mMulticastHandle = INVALID_SOCKET Then
        mErrorCode = WSAGetLastError()
        Exit Function
    End If    JoinReaf = True
End Function

调试易

求接受/发送组播（Multicast）的源程序

解决方案 »