ExcelVBAで簡易Webサーバー実装

StartWebServer()でスタートして
StopWebServer()で止めます。

アドレスは
http://127.0.0.1:123456/hogehoge
です。

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function WSAStartup Lib "ws2_32.dll" (ByVal wVersionRequired As Long, lpWSAData As Any) As Long
    Private Declare PtrSafe Function socket Lib "ws2_32.dll" (ByVal af As Long, ByVal s_type As Long, ByVal protocol As Long) As LongPtr
    Private Declare PtrSafe Function bind Lib "ws2_32.dll" (ByVal s As LongPtr, ByRef name As SOCKADDR_IN, ByVal namelen As Long) As Long
    Private Declare PtrSafe Function listen Lib "ws2_32.dll" (ByVal s As LongPtr, ByVal backlog As Long) As Long
    Private Declare PtrSafe Function accept Lib "ws2_32.dll" (ByVal s As LongPtr, ByRef addr As SOCKADDR_IN, ByRef addrLen As Long) As LongPtr
    Private Declare PtrSafe Function recv Lib "ws2_32.dll" (ByVal s As LongPtr, ByVal buf As String, ByVal llen As Long, ByVal flags As Long) As Long
    Private Declare PtrSafe Function send Lib "ws2_32.dll" (ByVal s As LongPtr, ByVal buf As String, ByVal llen As Long, ByVal flags As Long) As Long
    Private Declare PtrSafe Function closesocket Lib "ws2_32.dll" (ByVal s As LongPtr) As Long
    Private Declare PtrSafe Function WSACleanup Lib "ws2_32.dll" () As Long
    Private Declare PtrSafe Function ioctlsocket Lib "ws2_32.dll" (ByVal s As LongPtr, ByVal cmd As Long, ByRef argp As Long) As Long
    Private Declare PtrSafe Function WSAGetLastError Lib "ws2_32.dll" () As Long
#Else
    Private Declare Function WSAStartup Lib "ws2_32.dll" (ByVal wVersionRequired As Long, lpWSAData As Any) As Long
    Private Declare Function socket Lib "ws2_32.dll" (ByVal af As Long, ByVal s_type As Long, ByVal protocol As Long) As Long
    Private Declare Function bind Lib "ws2_32.dll" (ByVal s As Long, ByRef name As SOCKADDR_IN, ByVal namelen As Long) As Long
    Private Declare Function listen Lib "ws2_32.dll" (ByVal s As Long, ByVal backlog As Long) As Long
    Private Declare Function accept Lib "ws2_32.dll" (ByVal s As Long, ByRef addr As SOCKADDR_IN, ByRef addrLen As Long) As Long
    Private Declare Function recv Lib "ws2_32.dll" (ByVal s As Long, ByVal buf As String, ByVal llen As Long, ByVal flags As Long) As Long
    Private Declare Function send Lib "ws2_32.dll" (ByVal s As Long, ByVal buf As String, ByVal llen As Long, ByVal flags As Long) As Long
    Private Declare Function closesocket Lib "ws2_32.dll" (ByVal s As Long) As Long
    Private Declare Function WSACleanup Lib "ws2_32.dll" () As Long
    Private Declare Function ioctlsocket Lib "ws2_32.dll" (ByVal s As Long, ByVal cmd As Long, ByRef argp As Long) As Long
    Private Declare Function WSAGetLastError Lib "ws2_32.dll" () As Long
#End If

Private Type SOCKADDR_IN
    sin_family As Integer
    sin_port As Integer
    sin_addr As Long
    sin_zero(0 To 7) As Byte
End Type

Private Type wsaData
    wVersion As Integer
    wHighVersion As Integer
    szDescription(0 To 256) As Byte
    szSystemStatus(0 To 128) As Byte
    iMaxSockets As Integer
    iMaxUdpDg As Integer
    lpVendorInfo As Long
End Type

Const AF_INET = 2
Const SOCK_STREAM = 1
Const INADDR_ANY = 0
Const SOCKET_ERROR = -1
Const FIONBIO = &H8004667E
Const WSAEWOULDBLOCK = 10035

#If VBA7 Then
    Private serverRunning As Boolean
    Private serverSocket As LongPtr
#Else
    Private serverRunning As Boolean
    Private serverSocket As Long
#End If

' デバッグ用の変数
Private acceptCallCount As Long
Private lastAcceptError As Long

Sub StartWebServer()
    Dim wsaData As wsaData
    Dim serverAddr As SOCKADDR_IN
    Dim nonBlocking As Long
    
    ' Initialize Winsock
    If WSAStartup(&H202, wsaData) <> 0 Then
        MsgBox "Failed to initialize Winsock"
        Exit Sub
    End If
    
    ' Create socket
    serverSocket = socket(AF_INET, SOCK_STREAM, 0)
    If serverSocket = SOCKET_ERROR Then
        MsgBox "Failed to create socket"
        WSACleanup
        Exit Sub
    End If
    
    ' Set socket to non-blocking mode
    nonBlocking = 1
    If ioctlsocket(serverSocket, FIONBIO, nonBlocking) = SOCKET_ERROR Then
        MsgBox "Failed to set non-blocking mode"
        closesocket serverSocket
        WSACleanup
        Exit Sub
    End If
    
    ' Bind socket
    With serverAddr
        .sin_family = AF_INET
        .sin_port = htons(123456)
        .sin_addr = INADDR_ANY
    End With
    
    If bind(serverSocket, serverAddr, LenB(serverAddr)) = SOCKET_ERROR Then
        Dim bindError As Long
        bindError = WSAGetLastError()
        MsgBox "Failed to bind socket. Error code: " & bindError
        closesocket serverSocket
        WSACleanup
        Exit Sub
    End If
    
    ' Listen for connections
    If listen(serverSocket, 1) = SOCKET_ERROR Then
        MsgBox "Failed to listen on socket"
        closesocket serverSocket
        WSACleanup
        Exit Sub
    End If
    
    ' デバッグ用の変数を初期化
    acceptCallCount = 0
    lastAcceptError = 0
    
    MsgBox "Server started. Access http://127.0.0.1:123456/hogehoge in your browser."
    
    serverRunning = True
    
    ' Schedule the first server check
    Application.OnTime Now + TimeValue("00:00:01"), "CheckServerStatus"
End Sub

Sub CheckServerStatus()
    If Not serverRunning Then
        closesocket serverSocket
        WSACleanup
        MsgBox "Server stopped."
        Exit Sub
    End If
    
    #If VBA7 Then
        Dim clientSocket As LongPtr
    #Else
        Dim clientSocket As Long
    #End If
    Dim clientAddr As SOCKADDR_IN
    Dim addrLen As Long
    Dim recvBuf As String * 1024
    Dim response As String
    Dim bytesReceived As Long
    Dim lastError As Long
    
    addrLen = LenB(clientAddr)
    clientSocket = accept(serverSocket, clientAddr, addrLen)
    
    ' accept呼び出し回数をインクリメント
    acceptCallCount = acceptCallCount + 1
    
    If clientSocket <> SOCKET_ERROR Then
        bytesReceived = recv(clientSocket, recvBuf, 1024, 0)
        If bytesReceived > 0 Then
            If InStr(1, recvBuf, "GET /kabucom") > 0 Then
                response = "HTTP/1.1 200 OK" & vbCrLf & _
                           "Content-Type: text/html" & vbCrLf & _
                           "Connection: close" & vbCrLf & vbCrLf & _
                           "<html><body><h1>Hello World</h1></body></html>"
                send clientSocket, response, Len(response), 0
            End If
        End If
        closesocket clientSocket
    Else
        lastError = WSAGetLastError()
        If lastError <> WSAEWOULDBLOCK Then
            ' エラー情報を更新
            lastAcceptError = lastError
            ' より詳細なエラー情報を表示
            MsgBox "Error accepting connection: " & lastError & vbCrLf & _
                   "Accept calls: " & acceptCallCount & vbCrLf & _
                   "Last error: " & lastAcceptError
        End If
    End If
    
    ' Schedule the next check
    Application.OnTime Now + TimeValue("00:00:01"), "CheckServerStatus"
End Sub

Private Function htons(ByVal hostshort As Integer) As Integer
    htons = ((hostshort And &HFF) * 256) + ((hostshort And &HFF00) \ 256)
End Function

Sub StopWebServer()
    serverRunning = False
End Sub

解説

簡易的なHTTPサーバーの構築の仕組みを、主要なステップに分けて説明します：

・ソケットの初期化と設定:

WSAStartup関数でWinsock APIを初期化します。
socket関数で新しいソケットを作成します。
ioctlsocket関数でソケットを非ブロッキングモードに設定します。

・ポートのバインドとリスニング:

bind関数で、作成したソケットを特定のIPアドレスとポート番号（ここでは12321）にバインドします。
listen関数で、ソケットを接続待ち状態にします。

・クライアント接続の受け付け:

CheckServerStatus サブルーチン内で、accept関数を使用してクライアントからの接続を受け付けます。
非ブロッキングモードのため、接続がない場合はすぐに制御を返します。

・リクエストの処理:

接続が確立したら、recv関数でクライアントからのHTTPリクエストを受信します。
リクエスト内容を解析し、"/hogehoge"へのGETリクエストかどうかを確認します。

・レスポンスの送信:

適切なHTTPレスポンスヘッダーとHTMLコンテンツを構築します。
send関数を使用して、構築したレスポンスをクライアントに送信します。

・接続のクローズ:

レスポンス送信後、closesocket関数でクライアントとの接続を閉じます。

繰り返し処理:

Application.OnTimeを使用して、次のCheckServerStatusの呼び出しをスケジュールし、
新しい接続を継続的にチェックします。

この仕組みにより、ExcelのVBA環境内で基本的なHTTPサーバー機能を実現しています。ただし、この実装は単純化されており、本格的なWebサーバーに比べると機能や性能、セキュリティ面で制限があります。