ExcelでSocket通信

Excel(Windows版)でSocket通信をする方法として、 winsockを用いる方法がある。 以下のような標準モジュールWinSockを用意し、

Option Explicit

' winsock minimum version (Miner,Major)
Public Const WS_VERSION_REQD As Long = &H101

' winsock error return
Public Const SOCKET_ERROR As Long = -1

' Address Family
Public Const AF_UNSPEC      As Long = 0
Public Const AF_INET        As Long = 2
Public Const AF_IPX         As Long = 6
Public Const AF_APPLETALK   As Long = 16
Public Const AF_NETBIOS     As Long = 17
Public Const AF_INET6       As Long = 23
Public Const AF_IRDA        As Long = 26
Public Const AF_BTH         As Long = 32

' socket type
Public Const SOCK_STREAM    As Long = 1
Public Const SOCK_DGRAM     As Long = 2
Public Const SOCK_RAW       As Long = 3
Public Const SOCK_RDM       As Long = 4
Public Const SOCK_SEQPACKET As Long = 5

' Protocol
Public Const IPPROTO_IP         As Long = 0
Public Const IPPROTO_ICMP       As Long = 1
Public Const IPPROTO_IGMP       As Long = 2
Public Const BTHPROTO_RFCOMM    As Long = 3
Public Const IPPROTO_TCP        As Long = 6
Public Const IPPROTO_UDP        As Long = 17
Public Const IPPROTO_ICMPV6     As Long = 58
Public Const IPPROTO_RM         As Long = 113

' shutdown type
Public Const SD_RECEIVE         As Integer = 0
Public Const SD_SEND            As Integer = 1
Public Const SD_BOTH            As Integer = 2

Public Const WSADESCRIPTION_LEN     As Integer = 256
Public Const WSASYS_STATUS_LEN      As Integer = 128

Public Type WSAData
    wVersion As Integer
    wHighVersion As Integer
    szDescription(WSADESCRIPTION_LEN + 1) As Byte
    szSystemStatus(WSASYS_STATUS_LEN + 1) As Byte
    iMaxSockets As Integer
    iMaxUdpDg As Integer
    lpVendorInfo As Long
End Type
 
Public Type hostent
     h_name As LongPtr          'pointer to hostname string
     h_aliases As LongPtr       '
     h_addrtype As Integer      'address type
     h_length As Integer        'length of each address
     h_addr_list As LongPtr     'list of addresses (null end)
End Type

' address storage
Public Type sockaddr
    sa_family As Integer
    sa_data(14) As Byte
End Type

' IPv4 address
Public Type sockaddr_in
    sin_family As Integer
    sin_port As Integer
    sin_addr As Long
    sin_zero1 As Long
    sin_zero2 As Long
End Type

'---ioctl Constants
Public Const FIONREAD As Long = &H8004667F
Public Const FIONBIO  As Long = &H8004667E
Public Const FIOASYNC As Long = &H8004667D

'-------------------------------------------
' for Server:
'
Public Const FD_SETSIZE = 64
' Public Const FIONBIO = 2147772030#
'Public Const SOCKADDR_SIZE                      = 16
'Public Const SOCKADDR_IN_SIZE                   = 16
Public Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000

Public Const IP_SUCCESS             As Long = 0
Public Const IP_ADD_MEMBERSHIP  As Long = 12
Public Const IP_DROP_MEMBERSHIP As Long = 13
'---network events
Public Const FD_READ                     As Long = &H1&
Public Const FD_WRITE                    As Long = &H2&
Public Const FD_OOB                      As Long = &H4&
Public Const FD_ACCEPT                   As Long = &H8&
Public Const FD_CONNECT                  As Long = &H10&
Public Const FD_CLOSE                    As Long = &H20&
Public Const FD_QOS                      As Long = &H40&
Public Const FD_GROUP_QOS                As Long = &H80&
Public Const FD_ROUTING_INTERFACE_CHANGE As Long = &H100&
Public Const FD_ADDRESS_LIST_CHANGE      As Long = &H200&

Public Const FD_MAX_EVENTS As Integer = 10

Public Type LPWSANETWORKEVENTS
    lNetworkEvents As Long
    iErrorCode(FD_MAX_EVENTS) As Long
End Type

Public Type fd_set
    fd_count As LongPtr
    fd_array(FD_SETSIZE) As Long
End Type

Public Type timeval
    tv_sec As Long
    tv_usec As Long
End Type

Public Type ip_mreq
     imr_multiaddr As Long
     imr_interface As Long
End Type

'--------------------------------------------------------------------
'- 関数宣言
'- char     :Byte
'- Int      :Long
'- short    :Integer
'- long     :Long
'- pointer  :LongPtr
'- WORD     :Integer
'- DWORD    :Long
' WSA関連
Private Declare PtrSafe Function WSAStartup Lib "ws2_32.dll" (ByVal wVersionRequested As Integer, ByRef lpWSAData As WSAData) As Long
Private Declare PtrSafe Function WSACleanup Lib "ws2_32.dll" () As Long
Private Declare PtrSafe Function WSAGetLastError Lib "ws2_32.dll" () As Long
'Private Declare PtrSafe Function WSAEventSelect Lib "ws2_32.dll" (ByVal s As Long, ByVal hEventObject As Long, ByVal lNetworkEvents As Long) As Long
'Private Declare PtrSafe Function WSAAsyncSelect Lib "ws2_32.dll" (ByVal s As Long, ByVal hWnd As Long, ByVal wMsg As Long, ByVal lngEvent As Long) As Long
'Private Declare PtrSafe Function WSACreateEvent Lib "ws2_32.dll" () As Long
'Private Declare PtrSafe Function WSACloseEvent Lib "ws2_32.dll" (ByVal hEvent As Long) As Boolean
'Private Declare PtrSafe Function WSAWaitForMultipleEvents Lib "ws2_32.dll" (ByVal cEvents As Long, ByVal lphEvents As Long, ByVal bWaitAll As Boolean, ByVal nTimeout As Long, ByVal bAlertable As Boolean) As Long
'Private Declare PtrSafe Function WSAWaitForMultipleEvents Lib "ws2_32.dll" (ByVal cEvents As Long, ByVal lphEvents As LongPtr, ByVal fWaitAll As Boolean, ByVal dwTimeout As Long, ByVal fAlertable As Boolean) As Long
'Private Declare PtrSafe Function WSAEnumNetworkEvents Lib "ws2_32.dll" (ByVal s As Long, ByVal hEventObject As Long, ByRef lpNetworkEvents As LPWSANETWORKEVENTS) As Long

' 接続
Private Declare PtrSafe Function w_socket Lib "ws2_32.dll" Alias "socket" (ByVal af As Long, ByVal socketType As Long, ByVal protocol As Long) As Long
Private Declare PtrSafe Function w_connect Lib "ws2_32.dll" Alias "connect" (ByVal s As Long, ByRef name As sockaddr_in, ByVal namelen As Long) As Long
Private Declare PtrSafe Function w_shutdown Lib "ws2_32.dll" Alias "shutdown" (ByVal s As Long, ByVal how As Long) As Long
Private Declare PtrSafe Function w_closesocket Lib "ws2_32.dll" Alias "closesocket" (ByVal s As Long) As Long
Private Declare PtrSafe Function w_select Lib "ws2_32.dll" Alias "select" (ByVal nfds As Long, readFds As fd_set, writeFds As fd_set, exceptFds As fd_set, TIMEOUT As timeval) As Long
Private Declare PtrSafe Function w_setsockopt Lib "ws2_32.dll" Alias "setsockopt" (ByVal s As Long, ByVal level As Long, ByVal optname As Long, optval As Any, ByVal optlen As Long) As Long
Private Declare PtrSafe Function w_ioctlsocket Lib "ws2_32.dll" Alias "ioctlsocket" (ByVal s As Long, ByVal cmd As Long, argp As LongPtr) As Long

' 送受信
Private Declare PtrSafe Function w_send Lib "ws2_32.dll" Alias "send" (ByVal s As Long, ByRef buf As Any, ByVal length As Long, ByVal flags As Long) As Long
Private Declare PtrSafe Function w_sendTo Lib "ws2_32.dll" Alias "sendto" (ByVal s As Long, ByRef buf As Any, ByVal length As Long, ByVal flags As Long, ByRef remoteAddr As sockaddr_in, ByVal remoteAddrSize As Long) As Long
Private Declare PtrSafe Function w_recv Lib "ws2_32.dll" Alias "recv" (ByVal s As Long, ByVal buf As LongPtr, ByVal length As Long, ByVal flags As Long) As Long
Private Declare PtrSafe Function w_recvFrom Lib "ws2_32.dll" Alias "recvfrom" (ByVal s As Long, ByVal buf As LongPtr, ByVal length As Long, ByVal flags As Long, fromAddr As sockaddr_in, ByVal fromAddrSize As Long) As Long

' サーバー
Private Declare PtrSafe Function w_bind Lib "ws2_32.dll" Alias "bind" (ByVal s As Long, ByRef name As sockaddr, ByVal namelen As Long) As Long
Private Declare PtrSafe Function w_listen Lib "ws2_32.dll" Alias "listen" (ByVal s As Long, ByVal backlog As Long) As Long
Private Declare PtrSafe Function w_accept Lib "ws2_32.dll" Alias "accept" (ByVal s As Long, ByRef addr As sockaddr, ByRef addrlen As Long) As Long

' Utility
Private Declare PtrSafe Function getsockname Lib "ws2_32.dll" (ByVal s As Long, ByRef name As sockaddr, ByRef namelen As Long) As Long
' ローカルホスト名取得
Private Declare PtrSafe Function gethostname Lib "ws2_32.dll" (ByVal host_name As String, ByVal namelen As Integer) As Integer
' アドレスからホスト名を取得
Private Declare PtrSafe Function gethostbyaddr Lib "ws2_32.dll" (ByRef addr As Long, ByVal length As Long, ByVal af As Long) As LongPtr
' ホスト名からIPアドレスを取得
Private Declare PtrSafe Function gethostbyname Lib "ws2_32.dll" (ByVal host_name As String) As LongPtr
' IPをドット形式(x.x.x.x)から内部形式に変更 ※8進と16進に注意
Private Declare PtrSafe Function inet_addr Lib "ws2_32.dll" (ByVal cp As String) As Long
' ホストバイトオーダからネットワークバイトオーダに変更
Private Declare PtrSafe Function htons Lib "ws2_32.dll" (ByVal hostshort As Long) As Integer
Private Declare PtrSafe Function htonl Lib "ws2_32.dll" (ByVal hostlong As Long) As Long
' ネットワークバイトオーダからホストバイトオーダに変更
Private Declare PtrSafe Function ntohl Lib "ws2_32.dll" (ByVal netlong As Long) As Long

Private Declare PtrSafe Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal hpvDest As LongPtr, ByVal hpvSource As LongPtr, ByVal cbCopy As Long)
Private Declare PtrSafe Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal Buffer As String, ByRef Size As Long) As Long
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

' error code
Private Const WSABASEERR             As Long = 10000 'No Error
Private Const WSAEINTR               As Long = 10004 'Interrupted by system call
Private Const WSAEBADF               As Long = 10009 '無効なファイルハンドルがソケット関数に渡された
Private Const WSAEACCES              As Long = 10013 'access denied
Private Const WSAEFAULT              As Long = 10014 '無効なバッファアドレス
Private Const WSAEINVAL              As Long = 10022 '無効な引数
Private Const WSAEMFILE              As Long = 10024 'Too many open files
Private Const WSAEWOULDBLOCK         As Long = 10035 'Operation would block
Private Const WSAEINPROGRESS         As Long = 10036 'Operation now in progress
Private Const WSAEALREADY            As Long = 10037 'Operation already in progress
Private Const WSAENOTSOCK            As Long = 10038 'Socket operation on non-socket
Private Const WSAEDESTADDRREQ        As Long = 10039 '
Private Const WSAEMSGSIZE            As Long = 10040
Private Const WSAEPROTOTYPE          As Long = 10041
Private Const WSAENOPROTOOPT         As Long = 10042
Private Const WSAEPROTONOSUPPORT     As Long = 10043
Private Const WSAESOCKTNOSUPPORT     As Long = 10044
Private Const WSAEOPNOTSUPP          As Long = 10045
Private Const WSAEPFNOSUPPORT        As Long = 10046
Private Const WSAEAFNOSUPPORT        As Long = 10047
Private Const WSAEADDRINUSE          As Long = 10048
Private Const WSAEADDRNOTAVAIL       As Long = 10049
Private Const WSAENETDOWN            As Long = 10050
Private Const WSAENETUNREACH         As Long = 10051
Private Const WSAENETRESET           As Long = 10052
Private Const WSAECONNABORTED        As Long = 10053
Private Const WSAECONNRESET          As Long = 10054
Private Const WSAENOBUFS             As Long = 10055
Private Const WSAEISCONN             As Long = 10056
Private Const WSAENOTCONN            As Long = 10057
Private Const WSAESHUTDOWN           As Long = 10058
Private Const WSAETOOMANYREFS        As Long = 10059
Private Const WSAETIMEDOUT           As Long = 10060
Private Const WSAECONNREFUSED        As Long = 10061
Private Const WSAELOOP               As Long = 10062
Private Const WSAENAMETOOLONG        As Long = 10063
Private Const WSAEHOSTDOWN           As Long = 10064
Private Const WSAEHOSTUNREACH        As Long = 10065
Private Const WSAENOTEMPTY           As Long = 10066
Private Const WSAEPROCLIM            As Long = 10067
Private Const WSAEUSERS              As Long = 10068
Private Const WSAEDQUOT              As Long = 10069
Private Const WSAESTALE              As Long = 10070
Private Const WSAEREMOTE             As Long = 10071
Private Const WSASYSNOTREADY         As Long = 10091
Private Const WSAVERNOTSUPPORTED     As Long = 10092
Private Const WSANOTINITIALISED      As Long = 10093
Private Const WSAEDISCON             As Long = 10101
Private Const WSAENOMORE             As Long = 10102
Private Const WSAECANCELLED          As Long = 10103
Private Const WSAEINVALIDPROCTABLE   As Long = 10104
Private Const WSAEINVALIDPROVIDER    As Long = 10105
Private Const WSAEPROVIDERFAILEDINIT As Long = 10106
Private Const WSASYSCALLFAILURE      As Long = 10107
Private Const WSASERVICE_NOT_FOUND   As Long = 10108
Private Const WSATYPE_NOT_FOUND      As Long = 10109
Private Const WSA_E_NO_MORE          As Long = 10110
Private Const WSA_E_CANCELLED        As Long = 10111
Private Const WSAEREFUSED            As Long = 10112
Private Const WSAHOST_NOT_FOUND      As Long = 11001
Private Const WSATRY_AGAIN           As Long = 11002
Private Const WSANO_RECOVERY         As Long = 11003
Private Const WSANO_DATA             As Long = 11004
Private Const WSANO_ADDRESS          As Long = 11004
Private Const sckInvalidOp           As Long = 40020

'--------------------------------------------------
' Utilities
'

Private Function IPToText(ByVal IPAddress As Long) As String
    Dim bytes(3) As Byte
    MoveMemory VarPtr(bytes(0)), VarPtr(IPAddress), 4
    IPToText = _
        CStr(bytes(0)) & "." & _
        CStr(bytes(1)) & "." & _
        CStr(bytes(2)) & "." & _
        CStr(bytes(3))
End Function

Private Function UnsignedLongToInteger(uLong As Long) As Integer
     If uLong > 32767 Then
         UnsignedLongToInteger = uLong - 65536
     Else
         UnsignedLongToInteger = uLong
     End If
End Function

'1次元バイト配列に要素を追加
Private Function Array_Push(ByRef Src() As Byte, ByRef Data() As Byte, Optional ByVal dlen As Long) As Variant
    Dim vBuf() As Byte
    Dim nDataCnt As Long
    Dim v As Variant
    Dim i As Long
    Dim j As Long

    vBuf = Src
    If IsArray(Data) Then
        If IsMissing(dlen) Then
            nDataCnt = UBound(Data, 1) - LBound(Data, 1) + 1
        Else
            nDataCnt = dlen
        End If
    Else
        nDataCnt = 1
    End If
    If Not Not vBuf Then
        'ReDim済
        i = UBound(vBuf)
    Else
        '未初期化
        i = -1
    End If
    ReDim Preserve vBuf(i + nDataCnt)
    i = i + 1
    j = 0
    For Each v In Data
        vBuf(i) = v
        i = i + 1
        j = j + 1
        If j >= nDataCnt Then
            Exit For
        End If
    Next
    Array_Push = vBuf
End Function

'エラーメッセージを返します。
Private Function ErrorMsg(ByVal ErrorCode) As String
    ErrorMsg = ""
    Select Case ErrorCode
        Case WSAEINTR:           ErrorMsg = "関数呼び出しに割り込みがありました。"
        Case WSAEACCES:          ErrorMsg = "アクセスは拒否されました。"
        Case WSAEFAULT:          ErrorMsg = "アドレスが正しくありません。"
        Case WSAEINVAL:          ErrorMsg = "無効な引数です。"
        Case WSAEMFILE:          ErrorMsg = "開いているファイルが多すぎます。"
        Case WSAEWOULDBLOCK:     ErrorMsg = "ノンブロッキング状態であり、処理が直ちに完了しませんでした。。"
        Case WSAEINPROGRESS:     ErrorMsg = "ブロック操作を実行中です。"
        Case WSAEALREADY:        ErrorMsg = "操作はすでに実行中です。"
        Case WSAENOTSOCK:        ErrorMsg = "記述子がソケットではありません。"
        Case WSAEDESTADDRREQ:    ErrorMsg = "送信先のアドレスが必要です。"
        Case WSAEMSGSIZE:        ErrorMsg = "メッセージが長すぎます。"
        Case WSAEPROTOTYPE:      ErrorMsg = "プロトコルの種類がソケットに対して正しくありません。"
        Case WSAENOPROTOOPT:     ErrorMsg = "プロトコルのオプションが正しくありません。"
        Case WSAEPROTONOSUPPORT: ErrorMsg = "指定したプロトコルがサポートされていません。"
        Case WSAESOCKTNOSUPPORT: ErrorMsg = "サポートされていないプロトコルの種類です。"
        Case WSAEOPNOTSUPP:      ErrorMsg = "要求された操作がソケット上でサポートされていません。"
        Case WSAEPFNOSUPPORT:    ErrorMsg = "プロトコルファミリがサポートされていません。"
        Case WSAEAFNOSUPPORT:    ErrorMsg = "指定されたプロトコルファミリは指定されたアドレスファミリをサポートしていません。"
        Case WSAEADDRINUSE:      ErrorMsg = "アドレスが使用中です。"
        Case WSAEADDRNOTAVAIL:   ErrorMsg = "アドレスをローカルマシンから取得できません。"
        Case WSAENETDOWN:        ErrorMsg = "ネットワークがダウンしています。"
        Case WSAENETUNREACH:     ErrorMsg = "現時点ではこのホストからネットワークにアクセスできません。"
        Case WSAENETRESET:       ErrorMsg = "ネットワークがリセットされたため切断されました。"
        Case WSAECONNABORTED:    ErrorMsg = "タイムアウトその他の不具合で接続処理が中止されました。"
        Case WSAECONNRESET:      ErrorMsg = "ピアによって接続がリセットされました。"
        Case WSAENOBUFS:         ErrorMsg = "使用できるバッファ領域がありません。"
        Case WSAEISCONN:         ErrorMsg = "ソケットは既に接続されています。"
        Case WSAENOTCONN:        ErrorMsg = "ソケットは接続されていません。"
        Case WSAESHUTDOWN:       ErrorMsg = "ソケットは終了しています。"
        Case WSAETIMEDOUT:       ErrorMsg = "接続がタイムアウトになりました。"
        Case WSAECONNREFUSED:    ErrorMsg = "接続が強制的に拒絶されました。"
        Case WSAEHOSTDOWN:       ErrorMsg = "ホストがダウンしています。"
        Case WSAEHOSTUNREACH:    ErrorMsg = "ホストに到達するためのルートがありません。"
        Case WSAEPROCLIM:        ErrorMsg = "プロセスが多すぎます。"
        Case WSASYSNOTREADY:     ErrorMsg = "ネットワークサブシステムが利用できません。"
        Case WSAVERNOTSUPPORTED: ErrorMsg = "要求された Winsock のバージョンはサポートされていません。"
        Case WSANOTINITIALISED:  ErrorMsg = "まず WSAStartup を呼び出す必要があります。"
        Case WSAEDISCON:         ErrorMsg = "正常なシャットダウン処理が進行中です。"
        Case WSATYPE_NOT_FOUND:  ErrorMsg = "この種類のクラスが見つかりません。"
        Case WSAHOST_NOT_FOUND:  ErrorMsg = "ホストが見つかりません。そのようなホストはありません。"
        Case WSATRY_AGAIN:       ErrorMsg = "ホストが見つかりません。DNSサーバーからの応答がありません。"
        Case WSANO_RECOVERY:     ErrorMsg = "回復不能なエラーです。"
        Case WSANO_DATA:         ErrorMsg = "名前は有効ですが、要求された型のデータレコードがありません。"
        Case sckInvalidOp:       ErrorMsg = "現在の状態では不正な操作です。"
        Case Else:               ErrorMsg = "不明なエラー"
    End Select
    ErrorMsg = ErrorMsg & vbCrLf & "エラーコード : " & str$(ErrorCode)
End Function

'--------------------------------------------------------------------------
'--------------------------------------------------------------------------
' プロシージャ
'--------------------------------------------------------------------------
'--------------------------------------------------------------------------
Public Sub wsTCPSend(remoteAddress As String, remotePort As Long, Message As String)
    Dim WSAD As WSAData
    Dim s As Long 'socket
    Dim pHostEnt As LongPtr  'pointer of hostent structure
    Dim typHostEnt As hostent
    Dim pAddr As LongPtr
    Dim remoteIP As Long
    Dim remoteAddr As sockaddr_in
    Dim sendedLength As Long
    Dim ip As Long

    ' winsock初期化
    If (WSAStartup(WS_VERSION_REQD, WSAD)) Then
        MsgBox ErrorMsg(WSAGetLastError)
        WSACleanup
        Exit Sub
    End If

    ' ソケット取得
    s = w_socket(AF_INET, SOCK_STREAM, IPPROTO_IP)
    If s < 0 Then
        MsgBox ErrorMsg(WSAGetLastError)
        WSACleanup
        Exit Sub
    End If

    ' ホストアドレス取得
    pHostEnt = gethostbyname(remoteAddress & vbNullChar)
    If (pHostEnt = 0) Then
        Debug.Print "IP形式"
        remoteIP = inet_addr(remoteAddress & vbNullChar)
        pHostEnt = gethostbyaddr(remoteIP, 4, AF_INET)
    End If
    If (pHostEnt = 0) Then
        MsgBox ErrorMsg(WSAGetLastError)
        w_closesocket s
        WSACleanup
        Exit Sub
    End If
    MoveMemory VarPtr(typHostEnt), ByVal pHostEnt, Len(typHostEnt)
    MoveMemory VarPtr(pAddr), ByVal typHostEnt.h_addr_list, 4
    MoveMemory VarPtr(remoteIP), ByVal pAddr, 4

    Debug.Print "remoteIP = " & IPToText(remoteIP)

    remoteAddr.sin_family = AF_INET
    remoteAddr.sin_port = htons(remotePort)
    remoteAddr.sin_addr = remoteIP

    If (w_connect(s, remoteAddr, Len(remoteAddr)) = SOCKET_ERROR) Then
        MsgBox ErrorMsg(WSAGetLastError)
        w_closesocket s
        WSACleanup
        Exit Sub
    End If

    sendedLength = 0
    If Message <> "" Then
        sendedLength = w_send(s, ByVal Message, Len(Message), 0)
    End If
    Debug.Print "sendedLength = " & str$(sendedLength)

    If (w_shutdown(s, SD_BOTH) = SOCKET_ERROR) Then
        MsgBox ErrorMsg(WSAGetLastError)
        w_closesocket s
        WSACleanup
        Exit Sub
    End If

    If (w_closesocket(s) = SOCKET_ERROR) Then
        MsgBox ErrorMsg(WSAGetLastError)
        WSACleanup
        Exit Sub
    End If

    If WSACleanup() = SOCKET_ERROR Then
        MsgBox ErrorMsg(WSAGetLastError)
    End If
    Debug.Print "completed"
End Sub

Public Sub wsTCPSendRecv(ByVal remoteAddress As String, ByVal remotePort As Long, SendMessage As String, ByRef RecvData() As Byte)
    Const RecvBuffSize As Long = 1024
    Dim RecvBuff(RecvBuffSize) As Byte
    Dim tmpData() As Byte
    Dim WSAD As WSAData
    Dim s As Long 'socket
    Dim pHostEnt As LongPtr
    Dim typHostEnt As hostent
    Dim pAddr As LongPtr
    Dim remoteIP As Long
    Dim remoteAddr As sockaddr_in
    Dim sendedLength As Long
    Dim ret As Long
    Const TIMEOUT As Long = 3000 '*1ms
    Dim cnt As Long

    If (WSAStartup(WS_VERSION_REQD, WSAD)) Then
        MsgBox ErrorMsg(WSAGetLastError)
        WSACleanup
        Exit Sub
    End If

    s = w_socket(AF_INET, SOCK_STREAM, IPPROTO_IP)
    If s < 0 Then
        MsgBox ErrorMsg(WSAGetLastError)
        WSACleanup
        Exit Sub
    End If

    'If (w_ioctlsocket(s,FIONBIO,1)=SOCKET_ERROR) Then
    '    MsgBox ErrorMsg(WSAGetLastError)
    '    WSACleanup
    '    Exit Sub
    'End If

    pHostEnt = gethostbyname(remoteAddress & vbNullChar)
    If (pHostEnt = 0) Then
        remoteIP = inet_addr(remoteAddress & vbNullChar)
        pHostEnt = gethostbyaddr(remoteIP, 4, AF_INET)
    End If
    If (pHostEnt = 0) Then
        MsgBox ErrorMsg(WSAGetLastError)
        w_closesocket s
        WSACleanup
        Exit Sub
    End If

    '----------------------------------------------------
    MoveMemory VarPtr(typHostEnt), ByVal pHostEnt, Len(typHostEnt)
    MoveMemory VarPtr(pAddr), ByVal typHostEnt.h_addr_list, 4
    MoveMemory VarPtr(remoteIP), ByVal pAddr, 4

    Debug.Print "remoteIP = " & IPToText(remoteIP)

    remoteAddr.sin_family = AF_INET
    remoteAddr.sin_port = htons(remotePort)
    remoteAddr.sin_addr = remoteIP

    If (w_connect(s, remoteAddr, Len(remoteAddr)) = SOCKET_ERROR) Then
        MsgBox ErrorMsg(WSAGetLastError)
        w_closesocket s
        WSACleanup
        Exit Sub
    End If

    sendedLength = 0
    If SendMessage <> "" Then
        sendedLength = w_send(s, ByVal SendMessage, Len(SendMessage), 0)
    End If
    Debug.Print "sendedLength = " & str$(sendedLength)

    cnt = 0
    Do
        ret = w_recv(s, VarPtr(RecvBuff(0)), RecvBuffSize, 0)
        If (ret > 0) Then
            Debug.Print "Bytes received: " & CStr(ret)
            tmpData = Array_Push(tmpData, RecvBuff, ret)
        ElseIf (ret = 0) Then
            Debug.Print "Connection closed"
        Else
            If (WSAGetLastError = WSAEWOULDBLOCK) Then
                Debug.Print "wait"
            Else
                Debug.Print ErrorMsg(WSAGetLastError)
            End If
        End If
        cnt = cnt + 1
        If (cnt > TIMEOUT) Then
            Debug.Print "受信タイムアウト"
            Exit Do
        End If
        Sleep 1
    Loop While (ret > 0)
    RecvData = tmpData

    If (w_shutdown(s, SD_BOTH) = SOCKET_ERROR) Then
        MsgBox ErrorMsg(WSAGetLastError)
        w_closesocket s
        WSACleanup
        Exit Sub
    End If
    
    If (w_closesocket(s) = SOCKET_ERROR) Then
        MsgBox ErrorMsg(WSAGetLastError)
        WSACleanup
        Exit Sub
    End If
    
    If WSACleanup() = SOCKET_ERROR Then
        MsgBox ErrorMsg(WSAGetLastError)
    End If
    Debug.Print "completed"
End Sub

次のようにすれば通信可能

Public Sub RecvTest()
    Dim recv() As Byte
    Dim host As String
    Dim cmd As String
    Dim reqPath As String
    Dim v As Variant
    Dim b As Byte
    Dim fileName As String
    Dim fileNum As Long
    host = "www.google.co.jp"
    reqPath = "/index.html"
    cmd = _
        "GET " & reqPath & " HTTP/1.1" & vbCrLf & _
        "Host: " & host & vbCrLf & vbCrLf
    Debug.Print cmd
    Call wsTCPSendRecv(host, 80, cmd, recv)
    Debug.Print StrConv(recv, vbUnicode)
    
    fileName = "C:\work\new1.txt"
    Kill fileName
    fileNum = FreeFile()
    Open fileName For Binary Access Write As #fileNum
    For Each v In recv
        b = v
        Put #fileNum, , b
    Next
    Close #fileNum
End Sub