Excel VBAでTCP/IP通信しよう（wsock32.dllを使用）

Option Explicit

Public Const INADDR_NONE = &HFFFF
Public Const INADDR_ANY = &H0

Public Const WSA_DESCRIPTIONLEN = 256
Public Const WSA_DescriptionSize = WSA_DESCRIPTIONLEN + 1
Public Const WSA_SYS_STATUS_LEN = 128
Public Const WSA_SysStatusSize = WSA_SYS_STATUS_LEN + 1

Public Const INVALID_SOCKET = -1
Public Const SOCKET_ERROR = -1
Public Const SOCK_STREAM = 1
Public Const SOCK_DGRAM = 2
Public Const MAXGETHOSTSTRUCT = 1024
Public Const AF_INET = 2
Public Const PF_INET = 2

Public Const FIONREAD = &H8004667F
Public Const FIONBIO = &H8004667E
Public Const FIOASYNC = &H8004667D

Public Const WORK_TRUE = 0
Public Const WORK_FALSE = -1

Public Declare PtrSafe Function closesocket Lib "wsock32.dll" _
                                (ByVal s As Long) As Long
Public Declare PtrSafe Function connect Lib "wsock32.dll" _
                                (ByVal s As Long, _
                                sName As sockaddr, _
                                ByVal namelen As Long) As Long
Public Declare PtrSafe Function ioctlsocket Lib "wsock32.dll" _
                                (ByVal s As Long, _
                                ByVal cmd As Long, _
                                argp As Long) As Long
Public Declare PtrSafe Function recv Lib "wsock32.dll" _
                                (ByVal s As Long, _
                                ByVal buf As Any, _
                                ByVal lngLen As Long, _
                                ByVal flags As Long) As Long
Public Declare PtrSafe Function send Lib "wsock32.dll" _
                                (ByVal s As Long, _
                                buf As Any, _
                                ByVal lngLenlen As Long, _
                                ByVal flags As Long) As Long
Public Declare PtrSafe Function Socket Lib "wsock32.dll" Alias "socket" _
                                (ByVal af As Long, _
                                ByVal lngType As Long, _
                                ByVal protocol As Long) As Long

Public Declare PtrSafe Function htons Lib "wsock32.dll" _
                                (ByVal hostshort As Long) As Integer
Public Declare PtrSafe Function inet_addr Lib "wsock32.dll" _
                                (ByVal cp As String) As Long
Public Declare PtrSafe Function gethostbyname Lib "wsock32.dll" _
                                (ByVal strName As String) As Long
Public Declare PtrSafe Function WSAStartup Lib "wsock32.dll" _
                                (ByVal wVersionRequested As Long, _
                                lpWSAData As WSADataType) As Long
Public Declare PtrSafe Function WSACleanup Lib "wsock32.dll" () As Long
Public Declare PtrSafe Function WSAGetLastError Lib "wsock32.dll" () As Long

Public Declare PtrSafe Sub MemCopy Lib "kernel32" Alias "RtlMoveMemory" _
                               (hpvDest As Any, _
                               hpvSource As Any, _
                               ByVal cbCopy As Long)

Type HostEnt
    h_name As Long
    h_aliases As Long
    h_addrtype As Integer
    h_length As Integer
    h_addr_list As Long
End Type

Type sockaddr
    sin_family As Integer
    sin_port As Integer
    sin_addr As Long
    sin_zero As String * 8
End Type

Type WSADataType
    wVersion As Integer
    wHighVersion As Integer
    szDescription As String * WSA_DescriptionSize
    szSystemStatus As String * WSA_SysStatusSize
    iMaxSockets As Integer
    iMaxUdpDg As Integer
    lpVendorInfo As Long
End Type

Type SocketCtrlData
    mlngSock As Long
    musrSockBuf As sockaddr
    musrStartup As WSADataType
End Type

'IPアドレス取得
Private Function wrkHostNameAlias(ByVal hstName As String) As Long
    Dim ret As Long
    Dim adr As Long
    Dim ip As Long
    Dim heHost As HostEnt
    
    ip = inet_addr(hstName)
    
    If ip = INADDR_NONE Then
        If gethostbyname(hstName) <> WORK_TRUE Then
            MemCopy heHost, ByVal ret, Len(heHost)
            MemCopy adr, ByVal heHost.h_addr_list, 4
            MemCopy ip, ByVal adr, heHost.h_length
        Else
            ip = INADDR_NONE
        End If
    End If
    
    wrkHostNameAlias = ip
    
End Function

'接続
Public Function wrkConnectTCP(Sockdat As SocketCtrlData, address As String, 
                                port As String) As long
    Dim adr As Long
    
    wrkConnectTCP = WORK_FALSE
    
    '初期化
    If WSAStartup(&H101, Sockdat.musrStartup) <> WORK_TRUE Then Exit Function
    
    'Socket
    Sockdat.mlngSock = Socket(AF_INET, SOCK_STREAM, 0)
    If Sockdat.mlngSock = WORK_FALSE Then Exit Function
    
    'Connect
    With Sockdat.musrSockBuf
        adr = wrkHostNameAlias(address)
        .sin_family = AF_INET
        .sin_port = htons(CLng(port))
        .sin_addr = adr
        .sin_zero = String$(8, 0)
    End With
        
    If connect(Sockdat.mlngSock, Sockdat.musrSockBuf, _
                                Len(Sockdat.musrSockBuf)) <> WORK_TRUE Then
        Exit Function
    End If
    DoEvents

    'ioctlsocket
    If ioctlsocket(Sockdat.mlngSock, FIONBIO, True) <> WORK_TRUE Then 
        Exit Function
    End If
    
    wrkConnectTCP = WORK_TRUE

End Function

Public Sub wrkDisconnectTCP()
    closesocket mySockdat.mlngSock
    Call WSACleanup
End Sub

'送受信
Public Function wrkCommTCP(sckn As Long, bSnddat() As Byte, _
                                strRet As String) As Long
    Dim lngRet As Long
    Dim lngAll As Long
    Dim strRev As String * 1000
    
    wrkCommTCP = 0
    strRet = ""
    
    '送信
    Call send(sckn, bSnddat(0), UBound(bSnddat) + 1, 0)
    
    'ｳｪｲﾄ
    Call timewait(0.1)
    
    '受信
    Do
        DoEvents
        lngRet = recv(sckn, ByVal strRev, 1000, 0)
        
        If lngRet > 0 Then
            strRet = strRet & Left$(strRev, lngRet)
            wrkCommTCP = wrkCommTCP + lngRet
            If InStr(strRet, vbCrLf) > 0 Then Exit Do
        ElseIf lngRet = SOCKET_ERROR Then
            wrkCommTCP = SOCKET_ERROR
            Exit Do
        End If
          
    Loop
    
End Function

'ウェイト
Private Sub timewait(sec As Single)
    Dim sttmr As Single
    Dim ctmr As Single
    
    If sec < 0 Then Exit Sub
    sttmr = Timer
    
    Do
        ctmr = Timer
        If ctmr < sttmr Then ctmr = ctmr + 24# * 60 * 60
        If ctmr > sttmr + sec Then Exit Sub
        DoEvents
    Loop

End Sub

Option Explicit

'ソケットデータ
Private mySockdat As SocketCtrlData

'接続
Private Sub CommandButton1_Click()
    Dim ip As String
    Dim port As String
    
    ip = "192.168.0.102"
    port = "56789"
        
    'TCP接続
    If wrkConnectTCP(mySockdat, ip, port) = SOCKET_ERROR Then
        Range("C4") = "NG"
    else
        Range("C4") = "OK"
    End If
End Sub

'切断
Private Sub CommandButton2_Click()
    closesocket mySockdat.mlngSock
    Call WSACleanup
    Range("C4") = ""
End Sub

'送受信
Private Sub CommandButton3_Click()
    Dim strSnd As String
    Dim binSnd() As Byte
    Dim strRev As String
    Dim lenStr As Long
    Dim cnt As Long
    
    'C6セルの内容を送信する
    strSnd = Range("C6") & vbCrLf
    lenStr = Len(strSnd) - 1
    
    ReDim binSnd(lenStr)
    
    For cnt = 0 To lenStr
        binSnd(cnt) = Asc(Mid(strSnd, cnt + 1, 1))
    Next
    
    '送受信
    If wrkCommTCP(mySockdat.mlngSock, binSnd, strRev) = SOCKET_ERROR Then
        If WSAGetLastError() > 0 Then
            closesocket mySockdat.mlngSock
            Call WSACleanup
        End If
    End If
    
    '返送データをC7のセルに表示する
    Range("C7") = strRev
    
End Sub