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サーバーに比べると機能や性能、セキュリティ面で制限があります。
