Excel VBAでメッセージ受信を行うWinsockサーバ「clsWinsockServer」

概要

Excel VBAでメッセージ受信を行うWinsockサーバー「clsWinsockServer」を作成しました。
clsWinsockServerを利用すると、別途作成したWinsockクライアント「clsWinsockClient」が送信したメッセージを受信できます。

事前準備

Microsoft Winsock Control 6.0への参照設定

本クライアントを使用するには、以下の手順で「Microsoft Winsock Control 6.0」への参照設定を追加する必要があります。

Visual Basic Editorの「ツール」メニューから「参照設定」ダイアログを開きます。
参照設定ダイアログ上の「参照」ボタンを押し、「ファイルの参照」ダイアログを開きます。
ファイルの参照ダイアログで「c:\Windows\system32\MSWINSCK.OCX」を選択し、「開く」ボタンを押します。
参照可能なライブラリファイルに「Microsoft Winsock Control 6.0」が追加されたことを確認し、「OK」ボタンを押します。

Microsoft Scripting Runtimeへの参照設定。

本クライアントを使用するには、以下の手順で「Microsoft Scripting Runtime」への参照設定を追加する必要があります。

Visual Basic Editorの「ツール」メニューから「参照設定」ダイアログを開きます。
参照設定ダイアログ上のリストボックスで「Microsoft Scripting Runtime」を探し、チェックをつけます。
「OK」ボタンを押します。

使い方

clsWinsockServerをクラスモジュールとしてプロジェクトに追加し、標準モジュール等から以下のように利用します。

    '// 1. Winsockサーバーを生成する。
    Set server = New clsWinsockServer
    
    '// 2. 接続の待受を開始する。
    If server.StartListen(1500) = 9 Then
        '// 待受の開始に失敗:
        Call MsgBox("待受を開始に失敗しました。 ")
        Exit Sub
    End If
    
    '// 3. 接続のタイムアウトを確認する。
    Call server.CheckTimeout

    '// 4. Winsockサーバーが受信したメッセージを取得する。
    If server.GetMessage(wkDatetime, wkRemoteHostIp, wkMessage) = 0 Then
    	'// 受信したメッセージを表示する。
        Call MsgBox(wkDatetime & " " & wkRemoteHostIp & " " & wkMessage)
    End If

    '// 5.接続の待受を停止する。
    If server.StopListen = 9 Then
        '// 待受の停止に失敗:
        Call MsgBox("待受の停止に失敗しました｡ ")
        Exit Sub
    End If

1. Winsockサーバーを生成する。

まず最初に、Newを使ってclsWinsockServerのインスタンスを生成します。

2. 接続の待受を開始する。

クライアントからの接続の待受を開始するには、clsWinsockServerインスタンスのStartListenメソッドを呼び出します。
StartListenメソッドの引数は待受ポート番号です。上記の例の場合、ポート番号「1500」で待受を開始します。
StartListenメソッドの戻り値は待受開始の成功・失敗を表します。成功した場合には「0」が、失敗した場合には「9」が返却されます。

3. 接続のタイムアウトを確認する。

接続のタイムアウトを確認するため、定期的にclsWinsockServerインスタンスのCheckTimeoutメソッドを呼び出す必要があります。
CheckTimeoutメソッドの呼び出し時、タイムアウト時間を過ぎた接続をクローズします。

4. Winsockサーバーが受信したメッセージを取得する。

Winsockサーバが受信したメッセージを標準モジュール等が取得するには、clsWinsockServerインスタンスのGetMessageメソッドを呼び出します。
GetMessageメソッドの引数はすべて出力値です。１番目の引数はメッセージの受信時刻を、２番目の引数は接続元のIPアドレスを、３番目の引数は受信メッセージを返します。

5. 接続の待受を停止する。

接続の待受を停止するには、clsWinsockServerインスタンスのStopListenメソッドを呼び出します。
StopListenメソッドの戻り値は待受開始の成功・失敗を表します。成功した場合には「0」が、失敗した場合には「9」が返却されます。

ソースコード

以下、clsWinsockServerのソースコードです。

clsWinsockServerクラスモジュール

Option Explicit

Private WithEvents mdl_winsock_listen As Winsock    '// 待受用ｿｹｯﾄ
Private WithEvents mdl_winsock_data As Winsock      '// ﾃﾞｰﾀ送受信用ｿｹｯﾄ

Private mdl_timeout_data As Date                    '// ﾃﾞｰﾀ送受信用ｿｹｯﾄのﾀｲﾑｱｳﾄ時刻

Private mdl_message_queue As Collection             '// ﾒｯｾｰｼﾞｷｭｰ

'//////////////////////////////////////////////////////
' ｸﾗｽ初期化時の処理
'//////////////////////////////////////////////////////
Private Sub Class_Initialize()

On Error GoTo ERR_PROC

    '// 待受用ｿｹｯﾄを生成する。
    Set mdl_winsock_listen = New Winsock
    '// ﾃﾞｰﾀ送受信用ｿｹｯﾄを生成する。
    Set mdl_winsock_data = New Winsock
    '// ﾒｯｾｰｼﾞｷｭｰを生成する。
    Set mdl_message_queue = New Collection
    
    Exit Sub
ERR_PROC:
    Call MsgBox(Err.Description)
End Sub

'//////////////////////////////////////////////////////
' StartListen
' 概要  : 接続の待受を開始する。
' 引数  : IN :(Intger)    i_local_port  待受ﾎﾟｰﾄ番号
' 戻り値: 正常時: 0、ｴﾗｰ時: 9
'//////////////////////////////////////////////////////
Public Function StartListen(i_local_port As Integer) As Integer

On Error GoTo ERR_PROC

    StartListen = 9

    '// 待受ﾎﾟｰﾄ番号を設定する。
    mdl_winsock_listen.LocalPort = i_local_port
    
    '// 接続の待受を開始する。
    Call mdl_winsock_listen.Listen
    
    StartListen = 0
        
    Exit Function
    
ERR_PROC:

    Call MsgBox(Err.Description)
    
    '// 待受用ｿｹｯﾄをｸﾛｰｽﾞする。
    Call mdl_winsock_listen.Close
    
    '// OSに制御を移し、ｸﾛｰｽﾞ処理を実行させる。
    DoEvents

End Function

'//////////////////////////////////////////////////////
' StopListen
' 概要  : 接続の待受を停止する。
' 引数  : なし
' 戻り値: 正常時: 0、ｴﾗｰ時: 9
'//////////////////////////////////////////////////////
Public Function StopListen() As Integer

On Error GoTo ERR_PROC

    StopListen = 9

    '// 待受用ｿｹｯﾄをｸﾛｰｽﾞする。
    Call mdl_winsock_listen.Close
    
    '// OSに制御を移し、ｸﾛｰｽﾞ処理を実行させる。
    DoEvents
    
    StopListen = 0
        
    Exit Function
    
ERR_PROC:

    Call MsgBox(Err.Description)
    
End Function


'//////////////////////////////////////////////////////
' CheckTimeout
' 概要  : ﾃﾞｰﾀ送受信ｿｹｯﾄのﾀｲﾑｱｳﾄを確認します。
' 引数  : なし
' 戻り値: 正常時: 0、ｴﾗｰ時: 9
'//////////////////////////////////////////////////////
Public Function CheckTimeout() As Integer

    Dim i As Integer

On Error GoTo ERR_PROC

    CheckTimeout = 9
    
    '// ﾃﾞｰﾀ送受信ｿｹｯﾄが接続中で、かつ、ｿｹｯﾄ接続ﾀｲﾑｱｳﾄ時刻を過ぎたことを確認する。
    If mdl_winsock_data.State <> sckClosed And mdl_timeout_data <= Now() Then
        '// ﾃﾞｰﾀ送受信ｿｹｯﾄをｸﾛｰｽﾞする。
        Debug.Print "一定時間が経過したため、ﾃﾞｰﾀ通信ｿｹｯﾄをｸﾛｰｽﾞします。"
        mdl_winsock_data.Close
        
        '// OSに制御を移し、ｸﾛｰｽﾞ処理を実行させる。
        DoEvents

    End If
        
    CheckTimeout = 0
        
    Exit Function
    
ERR_PROC:

    Call MsgBox(Err.Description)
    
    '// 待受用ｿｹｯﾄをｸﾛｰｽﾞする。
    Call mdl_winsock_listen.Close
    
    '// OSに制御を移し、ｸﾛｰｽﾞ処理を実行させる。
    DoEvents

End Function

'//////////////////////////////////////////////////////
' GetMessage
' 概要  : 受信ﾒｯｾｰｼﾞを取得する。
' 引数  : OUT:(Date)    o_datetime          受信時刻
'         OUT:(String)  o_remote_host_ip    接続元ﾎｽﾄのIPｱﾄﾞﾚｽ
'         OUT:(String)  o_message           ﾒｯｾｰｼﾞ
' 戻り値: ﾒｯｾｰｼﾞあり: 0、ﾒｯｾｰｼﾞなし: 1、ｴﾗｰ時: 9
'//////////////////////////////////////////////////////
Public Function GetMessage(o_datetime As Date, o_remote_host_ip As String, o_message As String) As Integer

    Dim wkMessageMap As Dictionary              '// ﾒｯｾｰｼﾞを格納するﾏｯﾌﾟ
    
On Error GoTo ERR_PROC

    GetMessage = 9
    
    '// ｷｭｰにﾒｯｾｰｼﾞが格納されていることを確認する。
    If mdl_message_queue.Count = 0 Then
        '// ﾒｯｾｰｼﾞが格納されていない:
        GetMessage = 1
        Exit Function
    End If
    
    '// ｷｭｰから先頭のﾒｯｾｰｼﾞを格納したﾏｯﾌﾟを取得する。
    Set wkMessageMap = mdl_message_queue(1)
    
    '// ﾏｯﾌﾟから受信時刻を取得する。
    o_datetime = wkMessageMap("Datetime")
    '// ﾏｯﾌﾟから接続元ﾎｽﾄのIPｱﾄﾞﾚｽを取得する。
    o_remote_host_ip = wkMessageMap("RemoteHostIP")
    '// ﾏｯﾌﾟからﾒｯｾｰｼﾞを取得する。
    o_message = wkMessageMap("Message")
    
    '// ｷｭｰから先頭のﾒｯｾｰｼﾞを削除する。
    Call mdl_message_queue.Remove(1)
    
    GetMessage = 0
    
    Exit Function
    
ERR_PROC:
    Call MsgBox(Err.Description)

End Function

'//////////////////////////////////////////////////////
' 待受ｿｹｯﾄへの接続要求時の処理
'//////////////////////////////////////////////////////
Private Sub mdl_winsock_listen_ConnectionRequest(ByVal requestID As Long)

On Error GoTo ERR_PROC

    '// ﾃﾞｰﾀ受信用ｿｹｯﾄがｸﾛｰｽﾞされていることを確認する。
    If mdl_winsock_data.State = sckClosed Then
    
        '// ﾃﾞｰﾀ送受信用ｿｹｯﾄで接続を受け入れる。
        Call mdl_winsock_data.Accept(requestID)
        '// ﾀｲﾑｱｳﾄ時刻を設定する。
        mdl_timeout_data = DateAdd("s", 10, Now())
    End If

    Exit Sub
    
ERR_PROC:
    Call MsgBox(Err.Description)
End Sub

'//////////////////////////////////////////////////////
' 接続元からﾃﾞｰﾀを受信した時の処理
'//////////////////////////////////////////////////////
Private Sub mdl_winsock_data_DataArrival(ByVal bytesTotal As Long)
    
    Dim wkDatetime As Date                      '// 受信時刻
    Dim wkRemoteHostIp As String                '// 接続先ﾎｽﾄのIPｱﾄﾞﾚｽ
    Dim wkMessage As String                     '// ﾒｯｾｰｼﾞ
    
    Dim wkMessageMap As Dictionary              '// ﾒｯｾｰｼﾞを格納するﾏｯﾌﾟ
    
On Error GoTo ERR_PROC

    '// 受信時刻を取得する。
    wkDatetime = Now
    '// 接続先ﾎｽﾄのIPアドレスを取得する。
    wkRemoteHostIp = mdl_winsock_data.RemoteHostIP
    
    '// 接続元からのﾒｯｾｰｼﾞを取得する。
    Debug.Print "接続元からﾒｯｾｰｼﾞを受信しました。"
    Call mdl_winsock_data.GetData(wkMessage)
    
    '// 接続元にOKﾒｯｾｰｼﾞを送信する。
    Debug.Print "接続元にOKﾒｯｾｰｼﾞを送信します。"
    Call mdl_winsock_data.SendData("OK")
    
    '// OSに制御を移し、送信処理を実行させる。
    DoEvents
    
    '// ﾏｯﾌﾟを作成する。
    Set wkMessageMap = New Dictionary
    
    '// ﾏｯﾌﾟに受信時刻を格納する。
    wkMessageMap("Datetime") = wkDatetime
    '// ﾏｯﾌﾟに接続先ﾎｽﾄのIPｱﾄﾞﾚｽを格納する。
    wkMessageMap("RemoteHostIP") = wkRemoteHostIp
    '// ﾏｯﾌﾟにﾒｯｾｰｼﾞを格納する。
    wkMessageMap("Message") = wkMessage
    
    '// ｷｭｰにﾒｯｾｰｼﾞを追加する。
    Call mdl_message_queue.Add(wkMessageMap)
    
    Exit Sub
    
ERR_PROC:
    Call MsgBox(Err.Description)
End Sub

'//////////////////////////////////////////////////////
' 接続先からｿｹｯﾄをｸﾛｰｽﾞされた時の処理
'//////////////////////////////////////////////////////
Private Sub mdl_winsock_data_Close()

On Error GoTo ERR_PROC
    
    '// ｿｹｯﾄをｸﾛｰｽﾞする。
    Debug.Print "接続元にｸﾛｰｽﾞされたため、ｿｹｯﾄをｸﾛｰｽﾞします。"
    mdl_winsock_data.Close
    
    '// OSに制御を移し、ｸﾛｰｽﾞ処理を実行させる。
    DoEvents

    Exit Sub
    
ERR_PROC:
    Call MsgBox(Err.Description)
End Sub

'//////////////////////////////////////////////////////
' ｿｹｯﾄ通信中にｴﾗｰが発生した時の処理
'//////////////////////////////////////////////////////
Private Sub mdl_winsock_data_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)

On Error GoTo ERR_PROC
    
    '// ｿｹｯﾄをｸﾛｰｽﾞする。
    Debug.Print "ｿｹｯﾄ通信中にｴﾗｰが発生したため、ｿｹｯﾄをｸﾛｰｽﾞします。"
    Call mdl_winsock_data.Close

    '// OSに制御を移し、ｸﾛｰｽﾞ処理を実行させる。
    DoEvents

    Exit Sub
    
ERR_PROC:
    Call MsgBox(Err.Description)
End Sub

サンプル

clsWinsockServerを使用するサンプルを作成しました。このサンプルはエクセルシートと標準モジュールで構成されています。

エクセルシート

待受ポート番号を入力して待受開始ボタンを押すと、接続の待受を開始します。クライアントからのメッセージが受信した場合、シート上に受信時刻、接続元IPアドレス、メッセージが出力されます。
また、待受停止ボタンを押すと、接続の待受が停止されます。
なお、接続開始ボタンには標準モジュールのStartListen関数を、接続停止ボタンにはStopListen関数を関連付けています。

標準モジュール

Private server As New clsWinsockServer

'//////////////////////////////////////////////////////
' 接続の待受を開始する。
'//////////////////////////////////////////////////////
Public Sub StartListen()

    Dim wkSheet As Worksheet                    '// ｼｰﾄ(Winsockｻｰﾊﾞｰﾌﾟﾛｸﾞﾗﾑ)
    
    Dim wkLocalPort As Integer                  '// 待受ﾎﾟｰﾄ番号
    
On Error GoTo ERR_PROC

    '// Winsockｻｰﾊﾞｰﾌﾟﾛｸﾞﾗﾑｼｰﾄを取得する。
    Set wkSheet = ThisWorkbook.Worksheets("Winsockｻｰﾊﾞｰﾌﾟﾛｸﾞﾗﾑ")
    
    '// 待受ﾎﾟｰﾄ番号を取得する。
    wkLocalPort = wkSheet.Cells(4, 4)
    
    '// Winsockｻｰﾊﾞｰを生成する。
    Set server = New clsWinsockServer
    
    '// 接続の待受を開始する。
    If server.StartListen(wkLocalPort) = 9 Then
        '// 待受の開始に失敗:
        Call MsgBox("待受を開始に失敗しました｡ ")
        Exit Sub
    End If
    
    '// Winsockｻｰﾊﾞーを定期的にﾁｪｯｸする。
    Call IntervalCheck
    
    Call MsgBox("待受を開始しました。")
    
    Exit Sub
    
ERR_PROC:
    Call MsgBox(Err.Description)
End Sub

'//////////////////////////////////////////////////////
' 接続の待受を開始する。
'//////////////////////////////////////////////////////
Public Sub StopListen()

On Error GoTo ERR_PROC

    '// 接続の待受を停止する。
    If server.StopListen = 9 Then
        '// 待受の停止に失敗:
        Call MsgBox("待受を停止に失敗しました｡ ")
        Exit Sub
    End If
    
    Call MsgBox("待受を停止しました。")
    
    Exit Sub
    
ERR_PROC:
    Call MsgBox(Err.Description)
End Sub

'//////////////////////////////////////////////////////
' Winsockｻｰﾊﾞーを定期的(5秒毎)にﾁｪｯｸする。
' ・ﾃﾞｰﾀ送受信ｿｹｯﾄのﾀｲﾑｱｳﾄを確認
' ・受信ﾒｯｾｰｼﾞをｼｰﾄに出力
'//////////////////////////////////////////////////////
Public Sub IntervalCheck()
    
    Dim wkSheet As Worksheet                    '// ｼｰﾄ(Winsockｻｰﾊﾞｰﾌﾟﾛｸﾞﾗﾑ)
    
    Dim wkDatetime As Date                      '// 受信時刻
    Dim wkRemoteHostIp As String                '// 接続先ﾎｽﾄのIPｱﾄﾞﾚｽ
    Dim wkMessage As String                     '// ﾒｯｾｰｼﾞ
    
On Error GoTo ERR_PROC

    '//////////////////////////////////////////////////////
    '// ﾃﾞｰﾀ送受信ｿｹｯﾄのﾀｲﾑｱｳﾄを確認
    '//////////////////////////////////////////////////////
    
    '// ﾃﾞｰﾀ送受信ｿｹｯﾄのﾀｲﾑｱｳﾄを確認
    Call server.CheckTimeout
    
    '//////////////////////////////////////////////////////
    '// Winsockｻｰﾊﾞｰが受信したﾒｯｾｰｼﾞをｼｰﾄに出力する。
    '//////////////////////////////////////////////////////
    
    '// Winsockｻｰﾊﾞｰﾌﾟﾛｸﾞﾗﾑｼｰﾄを取得する。
    Set wkSheet = ThisWorkbook.Worksheets("Winsockｻｰﾊﾞｰﾌﾟﾛｸﾞﾗﾑ")
    
    '// 出力先の行番号を決定する。
    wkRow = 9
    Do While wkSheet.Cells(wkRow, 3) <> ""
        wkRow = wkRow + 1
    Loop

    '// Winsockｻｰﾊﾞｰが受信したﾒｯｾｰｼﾞをｼｰﾄに出力する。
    Do While server.GetMessage(wkDatetime, wkRemoteHostIp, wkMessage) = 0
        wkSheet.Cells(wkRow, 3) = wkDatetime
        wkSheet.Cells(wkRow, 4) = wkRemoteHostIp
        wkSheet.Cells(wkRow, 5) = wkMessage
        
        wkRow = wkRow + 1
    Loop

    '//////////////////////////////////////////////////////
    '// 定期ﾁｪｯｸ用のﾀｲﾏｰをｾｯﾄする。
    '//////////////////////////////////////////////////////
    
    '// 5秒後にWinsockｻｰﾊﾞｰをﾁｪｯｸする。
    Call Application.OnTime(earliesttime:=Now + TimeValue("00:00:05"), procedure:="IntervalCheck")

    Exit Sub
    
ERR_PROC:
    Call MsgBox(Err.Description)
End Sub

参考

Excel VBAでメッセージ送信を行うWinsockクライアント「clsWinsockClient」

いろいろ解析日記