Application.OnTime を使ったマルチプロセスの記事をみて、ぜひWinsockに適用し一番やってみたかったチャレンジ
とりあえず成功したので、コードのメモ
何が驚くかというと、
・現在作業中のシートから、受信事象待ち専用のプロセス（別のExcelブック）として起動させると、Recvfromをnon-brokingにする必要がなくなる
・現在作業中のシートからサンプル電文 testHELLO()、 testElse()、testQUIT() を送信すると、受信事象待ち専用のプロセス（別のExcelブック）で受信できること。
そして、なにより現在作業中シートが固まらないこと ＜＝ ここが重要！！
Application.OnTimeを使った1ブックマルチプロセス対応
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 |
Option Explicit '* --- FormatMessage --- */ 'FormatMessage.dwFlags Private Const FORMAT_MESSAGE_ALLOCATE_BUFFER As Long = &H100 Private Const FORMAT_MESSAGE_ARGUMENT_ARRAY As Long = &H2000 Private Const FORMAT_MESSAGE_FROM_HMODULE As Long = &H800 Private Const FORMAT_MESSAGE_FROM_STRING As Long = &H400 Private Const FORMAT_MESSAGE_FROM_SYSTEM As Long = &H1000 Private Const FORMAT_MESSAGE_IGNORE_INSERTS As Long = &H200 Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK As Long = &HFF 'FormatMessage(API) Private Declare PtrSafe Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Long, _ ByVal dwMessageId As Long, ByVal dwLanguageId As Long, _ ByVal lpBuffer As String, ByVal nSize As Long, Arguments As LongPtr) _ As Long '* --- WSAStartup / WSACleanup --- */ 'WSAStartup / WSACleanup size Private Const WSASYS_STATUS_LEN As Long = 128 Private Const WSASYS_STATUS_SIZE As Long = WSASYS_STATUS_LEN + 1 Private Const WSADESCRIPTION_LEN As Long = 256 Private Const WSADESCRIPTION_SIZE As Long = WSADESCRIPTION_LEN + 1 Public Type WSAData wVersion As Integer wHighVersion As Integer szDescription As String * WSADESCRIPTION_SIZE szSystemStatus As String * WSASYS_STATUS_SIZE iMaxSockets As Integer iMaxUDPDG As Integer lpVendorInfo As Long End Type 'WSAStartup / WSACleanup(API) Public Declare PtrSafe Function WSAStartup Lib "Ws2_32.dll" (ByVal wVersionRequested As Integer, ByRef lpWSADATA As WSAData) As Long Public Declare PtrSafe Function WSACleanup Lib "wsock32.dll" () As Long '* --- Network --- */ Private Enum AF AF_UNSPEC = 0 AF_INET = 2 AF_IPX = 6 AF_APPLETALK = 16 AF_NETBIOS = 17 AF_INET6 = 23 AF_IRDA = 26 AF_BTH = 32 End Enum Private Enum SOCKTYPE SOCK_STREAM = 1 SOCK_DGRAM = 2 SOCK_RAW = 3 SOCK_RDM = 4 SOCK_SEQPACKET = 5 End Enum Private Enum PROTOCOL IPPROTO_ICMP = 1 IPPROTO_IGMP = 2 BTHPROTO_RFCOMM = 3 IPPROTO_TCP = 6 IPPROTO_UDP = 17 IPPROTO_ICMPV6 = 58 IPPROTO_RM = 113 End Enum ' 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 Private Const INVALID_SOCKET = -1 Private Const SOCKET_ERROR As Long = -1 'socket / closesocket(API) Public Declare PtrSafe Function SOCKET Lib "wsock32.dll" Alias "socket" (ByVal lngAf As LongPtr, ByVal lngType As LongPtr, ByVal lngProtocol As LongPtr) As Long Public Declare PtrSafe Function closesocket Lib "Ws2_32.dll" (ByVal socketHandle As Long) As Long 'sendto(API) Private Declare PtrSafe Function sendto Lib "Ws2_32.dll" (ByVal s As Long, ByVal buf As String, ByVal length As Long, ByVal Flags As Long, ByRef remoteAddr As SOCKADDR_IN, ByVal remoteAddrSize As Long) As Long 'recvfrom(API) Public Declare PtrSafe Function recvfrom Lib "wsock32.dll" (ByVal SOCKET As LongPtr, ByVal buf As String, ByVal length As LongPtr, ByVal Flags As Long, FromAddr As SOCKADDR_IN, fromAddrSize As Long) As Long 'bind(API) Private Declare PtrSafe Function bind Lib "Ws2_32.dll" (ByVal s As Long, ByRef Name As SOCKADDR_IN, ByVal namelen As Long) As Long 'htons(API) Private Declare PtrSafe Function htons Lib "Ws2_32.dll" (ByVal hostshort As Long) As Integer Private Declare PtrSafe Function ntohs Lib "Ws2_32.dll" (ByVal netshort As Long) As Integer ' inet_addr(API) IPをドット形式(x.x.x.x)から内部形式に変更 Private Declare PtrSafe Function inet_addr Lib "Ws2_32.dll" (ByVal cp As String) As Long 'IPv4またはIPv6インターネットネットワークアドレスからインターネット標準形式の文字列に変換 Private Declare PtrSafe Function InetNtopW Lib "Ws2_32.dll" (ByVal Family As Integer, ByRef pAddr As Long, ByVal pStringBuf As String, ByVal StringBufSize As Integer) As Long '* --- Sleep --- */ Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'エラーコードをFormatMessageで可読可能に変換 Public Function GetFormatMessageString(Optional ByVal dwMessageId As Long = 0) As String Dim dwFlags As Long 'オプションフラグ Dim lpBuffer As String 'メッセージを格納するたのバッファ Dim result As Long '戻り値(文字列のバイト数) '引数省略対応｡ If dwMessageId = 0 Then dwMessageId = VBA.Information.Err().LastDllError '未設定の場合はLastDllErrorをセット End If dwFlags = FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS Or FORMAT_MESSAGE_MAX_WIDTH_MASK lpBuffer = String(1024, vbNullChar) result = FormatMessage(dwFlags, 0&, dwMessageId, 0&, lpBuffer, Len(lpBuffer), 0&) If (result > 0) Then lpBuffer = Left(lpBuffer, InStr(lpBuffer, vbNullChar) - 1) 'Null終端まで取得 Else lpBuffer = "" End If GetFormatMessageString = lpBuffer & "(" & dwMessageId & ")" End Function 'C言語 MAKEWORD 相当 Public Function MAKEWORD(Lo As Byte, Hi As Byte) As Integer MAKEWORD = Lo + Hi * 256& Or 32768 * (Hi > 127) End Function Public Sub UDPRecvFrom() Dim ip As String: ip = "127.0.0.1" Dim remotePort As Long: remotePort = 60051 Dim RetCode As Long Dim remoteAddr As SOCKADDR_IN Dim ListenSocketHandle As Long Const RecvBuffSize As Long = 2048 Dim recvBuffer As String * RecvBuffSize Dim recvResult As Long Dim WSAD As WSAData RetCode = WSAStartup(MAKEWORD(2, 2), WSAD) If RetCode <> 0 Then MsgBox "WSAStartup failed with error：" & GetFormatMessageString(RetCode) Exit Sub End If ListenSocketHandle = SOCKET(AF.AF_INET, SOCKTYPE.SOCK_DGRAM, PROTOCOL.IPPROTO_UDP) If ListenSocketHandle = INVALID_SOCKET Then MsgBox "SOCKET failed with error：" & GetFormatMessageString(Err.LastDllError) GoTo EXIT_POINT End If remoteAddr.sin_family = AF_INET remoteAddr.sin_addr = inet_addr(ip) remoteAddr.sin_port = htons(remotePort) RetCode = bind(ListenSocketHandle, remoteAddr, LenB(remoteAddr)) If RetCode = SOCKET_ERROR Then MsgBox "Error binding listener socket: " & CStr(Err.LastDllError) GoTo EXIT_POINT End If Do While True DoEvents ' Sleep 200 recvBuffer = String(RecvBuffSize, vbNullChar) recvResult = recvfrom(ListenSocketHandle, recvBuffer, RecvBuffSize, 0, remoteAddr, LenB(remoteAddr)) If (recvResult > 0) Then Dim ipBuffer As String ipBuffer = Left(recvBuffer, InStr(recvBuffer, vbNullChar) - 1) 'Null終端まで取得 'ちょっと改造ここで電文制御 '仕様： 'HELLO -> HELLO VBA Winsock API と答える。 'QUIT -> 処理終了 'それ以外は通知された文字をそのまま表示する。 Select Case ipBuffer Case "HELLO" MsgBox "HELLO VBA Winsock API " & PrintIPAndPortNumber(remoteAddr) Case "QUIT" MsgBox "サーバー 処理終了電文受信成功 終了処理します。:" & ipBuffer Exit Do '受信成功したらループを抜ける Case Else MsgBox "サーバー 電文受信成功:" & ipBuffer End Select ElseIf recvResult = SOCKET_ERROR Then MsgBox "SOCKET_ERROR " & GetFormatMessageString(Err.LastDllError) GoTo EXIT_POINT: End If Loop EXIT_POINT: If closesocket(ListenSocketHandle) = SOCKET_ERROR Then MsgBox "closesocket failed with error：" & GetFormatMessageString(Err.LastDllError) End If If WSACleanup() <> 0 Then MsgBox "Windows Sockets error occurred in Cleanup.", vbExclamation End If 'ここで自分自身を閉じる。 ThisWorkbook.Close Application.Quit End Sub Public Sub UDPSendTo(ByRef Msg As String) ' WSAStartup -> socket → sendto → closesocket WSACleanup Dim RetCode As Long Dim WSAData As WSAData Dim SendSocketHandle As Long Dim DstAddr As SOCKADDR_IN 'パラメータ Dim ip As String: ip = "127.0.0.1" Dim TargetPort As Long: TargetPort = 60051 Dim strbuffer As String strbuffer = Msg 'スタートアップ RetCode = WSAStartup(MAKEWORD(2, 2), WSAData) If RetCode <> 0 Then MsgBox "WSAStartup failed with error：" & GetFormatMessageString(RetCode) Exit Sub End If 'UDP socket SendSocketHandle = SOCKET(AF.AF_INET, SOCKTYPE.SOCK_DGRAM, PROTOCOL.IPPROTO_UDP) If SendSocketHandle = INVALID_SOCKET Then MsgBox "SOCKET failed with error：" & GetFormatMessageString(Err.LastDllError) GoTo EXIT_POINT End If DstAddr.sin_family = AF.AF_INET DstAddr.sin_addr = inet_addr(ip) DstAddr.sin_port = htons(Convert_u_short_PortNumber(TargetPort)) 'sendto 送信 RetCode = sendto(SendSocketHandle, strbuffer, Len(strbuffer), 0, DstAddr, Len(DstAddr)) If RetCode = SOCKET_ERROR Then MsgBox "sendto failed with error：" & GetFormatMessageString(Err.LastDllError) GoTo EXIT_POINT Else Debug.Print "Sendto:" & PrintIPAndPortNumber(DstAddr) End If EXIT_POINT: If closesocket(SendSocketHandle) = SOCKET_ERROR Then MsgBox "closesocket failed with error：" & GetFormatMessageString(Err.LastDllError) End If If WSACleanup() <> 0 Then MsgBox "Windows Sockets error occurred in Cleanup.", vbExclamation End If End Sub Function PrintIPAndPortNumber(ByRef Addr As SOCKADDR_IN) As String Dim s As String Dim s2 As String s = String(100, vbNullChar) Call InetNtopW(AF.AF_INET, Addr.sin_addr, s, 128) s2 = Replace(s, vbNullChar, "") PrintIPAndPortNumber = "IPv4アドレス：" & s2 & "ポート番号" & u_short_PortNumberToLong(ntohs(Addr.sin_port)) End Function Sub MainForMultiProcess() Dim SVApp As Application Dim SVWb As Workbook '別プロセスをサーバとして起動 Set SVApp = New Application SVApp.Visible = True 'デバッグ用に表示、不要であればfalseにすればよい Set SVWb = SVApp.Workbooks.Open(ThisWorkbook.FullName, _ UpdateLinks:=False, _ ReadOnly:=True) 'サーバプロセス起動 '※この時呼ばれるプロシージャにはOnTimeのみを記述し直ちに応答を返す。 Call SVApp.Run("'" & SVWb.Name & "'!OnTimeUDPRecvFrom") End Sub 'UDPRecvFromの起動 Private Sub OnTimeUDPRecvFrom() Application.OnTime Now + TimeValue("00:00:1"), "UDPRecvFrom" ' MsgBox "SubProc UDPRecvFrom 実行" End Sub 'サンプル電文 Sub testHELLO() Call UDPSendTo("HELLO") End Sub Sub testElse() Call UDPSendTo("else message ") End Sub Sub testQUIT() Call UDPSendTo("QUIT") End Sub 'ポート番号をu_short（16bitの符号なし整数型）に変換したデータの可読用表示用変換 Function u_short_PortNumberToLong(ByVal u_short_PortNumber As Integer) As Long u_short_PortNumberToLong = 65535 And u_short_PortNumber End Function ' 'ポート番号をu_short（16bitの符号なし整数型）に変換する。 'VBでは、16bitの型はIntegerになるが、符号あり整数ため、32767以上の整数値を代入するとオーバーフローする。 'そのためBitレベルで,Integer型にはめ込む Function Convert_u_short_PortNumber(ByVal PortNumber As Long) As Integer Select Case PortNumber Case Is < 0&: Err.Raise "UnderFlow PortNumber is 0 - 65535" Case 0 To 32767: Convert_u_short_PortNumber = PortNumber Case 32768 To 65535: Convert_u_short_PortNumber = PortNumber - 65536 Case Is > 65535: Err.Raise Number:=513, Description:="OverFlow PortNumber is 0 - 65535" End Select End Function |
Application.OnTimeを使った1ブックマルチプロセス対応（non-brokingパターン）
一応、non-brokingのパターンも作成している。
non-brokingであれば、Recvfromは、処理の制御をすぐにExcelシートに返すので、あまり恩恵がないかも
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 |
Option Explicit '* --- FormatMessage --- */ 'FormatMessage.dwFlags Private Const FORMAT_MESSAGE_ALLOCATE_BUFFER As Long = &H100 Private Const FORMAT_MESSAGE_ARGUMENT_ARRAY As Long = &H2000 Private Const FORMAT_MESSAGE_FROM_HMODULE As Long = &H800 Private Const FORMAT_MESSAGE_FROM_STRING As Long = &H400 Private Const FORMAT_MESSAGE_FROM_SYSTEM As Long = &H1000 Private Const FORMAT_MESSAGE_IGNORE_INSERTS As Long = &H200 Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK As Long = &HFF 'FormatMessage(API) Private Declare PtrSafe Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Long, _ ByVal dwMessageId As Long, ByVal dwLanguageId As Long, _ ByVal lpBuffer As String, ByVal nSize As Long, Arguments As LongPtr) _ As Long '* --- WSAStartup / WSACleanup --- */ 'WSAStartup / WSACleanup size Private Const WSASYS_STATUS_LEN As Long = 128 Private Const WSASYS_STATUS_SIZE As Long = WSASYS_STATUS_LEN + 1 Private Const WSADESCRIPTION_LEN As Long = 256 Private Const WSADESCRIPTION_SIZE As Long = WSADESCRIPTION_LEN + 1 Public Type WSAData wVersion As Integer wHighVersion As Integer szDescription As String * WSADESCRIPTION_SIZE szSystemStatus As String * WSASYS_STATUS_SIZE iMaxSockets As Integer iMaxUDPDG As Integer lpVendorInfo As Long End Type 'WSAStartup / WSACleanup(API) Public Declare PtrSafe Function WSAStartup Lib "Ws2_32.dll" (ByVal wVersionRequested As Integer, ByRef lpWSADATA As WSAData) As Long Public Declare PtrSafe Function WSACleanup Lib "wsock32.dll" () As Long '* --- Network --- */ Private Enum AF AF_UNSPEC = 0 AF_INET = 2 AF_IPX = 6 AF_APPLETALK = 16 AF_NETBIOS = 17 AF_INET6 = 23 AF_IRDA = 26 AF_BTH = 32 End Enum Private Enum SOCKTYPE SOCK_STREAM = 1 SOCK_DGRAM = 2 SOCK_RAW = 3 SOCK_RDM = 4 SOCK_SEQPACKET = 5 End Enum Private Enum PROTOCOL IPPROTO_ICMP = 1 IPPROTO_IGMP = 2 BTHPROTO_RFCOMM = 3 IPPROTO_TCP = 6 IPPROTO_UDP = 17 IPPROTO_ICMPV6 = 58 IPPROTO_RM = 113 End Enum ' 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 Private Const INVALID_SOCKET = -1 Private Const SOCKET_ERROR As Long = -1 'socket / closesocket(API) Public Declare PtrSafe Function SOCKET Lib "wsock32.dll" Alias "socket" (ByVal lngAf As LongPtr, ByVal lngType As LongPtr, ByVal lngProtocol As LongPtr) As Long Public Declare PtrSafe Function closesocket Lib "Ws2_32.dll" (ByVal socketHandle As Long) As Long 'sendto(API) Private Declare PtrSafe Function sendto Lib "Ws2_32.dll" (ByVal s As Long, ByVal buf As String, ByVal length As Long, ByVal Flags As Long, ByRef remoteAddr As SOCKADDR_IN, ByVal remoteAddrSize As Long) As Long 'recvfrom(API) Public Declare PtrSafe Function recvfrom Lib "wsock32.dll" (ByVal SOCKET As LongPtr, ByVal buf As String, ByVal length As LongPtr, ByVal Flags As Long, FromAddr As SOCKADDR_IN, fromAddrSize As Long) As Long 'bind(API) Private Declare PtrSafe Function bind Lib "Ws2_32.dll" (ByVal s As Long, ByRef Name As SOCKADDR_IN, ByVal namelen As Long) As Long 'htons(API) Private Declare PtrSafe Function htons Lib "Ws2_32.dll" (ByVal hostshort As Long) As Integer Private Declare PtrSafe Function ntohs Lib "Ws2_32.dll" (ByVal netshort As Long) As Integer ' inet_addr(API) IPをドット形式(x.x.x.x)から内部形式に変更 Private Declare PtrSafe Function inet_addr Lib "Ws2_32.dll" (ByVal cp As String) As Long 'IPv4またはIPv6インターネットネットワークアドレスからインターネット標準形式の文字列に変換 Private Declare PtrSafe Function InetNtopW Lib "Ws2_32.dll" (ByVal Family As Integer, ByRef pAddr As Long, ByVal pStringBuf As String, ByVal StringBufSize As Integer) As Long '* --- ioctl --- */ '---ioctl Constants Private Const FIONREAD = &H8004667F Private Const FIONBIO = &H8004667E 'For nonblocking mode Private Const FIOASYNC = &H8004667D Private Const WSAEWOULDBLOCK = 10035 'ioctlsocket Private Declare PtrSafe Function ioctlsocket Lib "wsock32.dll" (ByVal s As Long, ByVal cmd As Long, argp As Long) As Long '* --- Sleep --- */ Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'エラーコードをFormatMessageで可読可能に変換 Public Function GetFormatMessageString(Optional ByVal dwMessageId As Long = 0) As String Dim dwFlags As Long 'オプションフラグ Dim lpBuffer As String 'メッセージを格納するたのバッファ Dim result As Long '戻り値(文字列のバイト数) '引数省略対応｡ If dwMessageId = 0 Then dwMessageId = VBA.Information.Err().LastDllError '未設定の場合はLastDllErrorをセット End If dwFlags = FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS Or FORMAT_MESSAGE_MAX_WIDTH_MASK lpBuffer = String(1024, vbNullChar) result = FormatMessage(dwFlags, 0&, dwMessageId, 0&, lpBuffer, Len(lpBuffer), 0&) If (result > 0) Then lpBuffer = Left(lpBuffer, InStr(lpBuffer, vbNullChar) - 1) 'Null終端まで取得 Else lpBuffer = "" End If GetFormatMessageString = lpBuffer & "(" & dwMessageId & ")" End Function 'C言語 MAKEWORD 相当 Public Function MAKEWORD(Lo As Byte, Hi As Byte) As Integer MAKEWORD = Lo + Hi * 256& Or 32768 * (Hi > 127) End Function Public Sub UDPRecvFrom() Dim ip As String: ip = "127.0.0.1" Dim remotePort As Long: remotePort = 60051 Dim RetCode As Long Dim remoteAddr As SOCKADDR_IN Dim ListenSocketHandle As Long Const RecvBuffSize As Long = 2048 Dim recvBuffer As String * RecvBuffSize Dim recvResult As Long Dim WSAD As WSAData RetCode = WSAStartup(MAKEWORD(2, 2), WSAD) If RetCode <> 0 Then MsgBox "WSAStartup failed with error：" & GetFormatMessageString(RetCode) Exit Sub End If ListenSocketHandle = SOCKET(AF.AF_INET, SOCKTYPE.SOCK_DGRAM, PROTOCOL.IPPROTO_UDP) If ListenSocketHandle = INVALID_SOCKET Then MsgBox "SOCKET failed with error：" & GetFormatMessageString(Err.LastDllError) GoTo EXIT_POINT End If remoteAddr.sin_family = AF_INET remoteAddr.sin_addr = inet_addr(ip) remoteAddr.sin_port = htons(remotePort) RetCode = bind(ListenSocketHandle, remoteAddr, LenB(remoteAddr)) If RetCode = SOCKET_ERROR Then MsgBox "Error binding listener socket: " & CStr(Err.LastDllError) GoTo EXIT_POINT End If RetCode = ioctlsocket(ListenSocketHandle, FIONBIO, -1) 'non-broking If RetCode = SOCKET_ERROR Then MsgBox "Error nonblocking mode Setting" GoTo EXIT_POINT End If Do While True DoEvents Sleep 200 recvBuffer = String(RecvBuffSize, vbNullChar) recvResult = recvfrom(ListenSocketHandle, recvBuffer, RecvBuffSize, 0, remoteAddr, LenB(remoteAddr)) If (recvResult > 0) Then Dim ipBuffer As String ipBuffer = Left(recvBuffer, InStr(recvBuffer, vbNullChar) - 1) 'Null終端まで取得 'ちょっと改造ここで電文制御 '仕様： 'HELLO -> HELLO VBA Winsock API と答える。 'QUIT -> 処理終了 'それ以外は通知された文字をそのまま表示する。 Select Case ipBuffer Case "HELLO" MsgBox "HELLO VBA Winsock API " & PrintIPAndPortNumber(remoteAddr) Case "QUIT" MsgBox "サーバー 処理終了電文受信成功 終了処理します。:" & ipBuffer Exit Do '受信成功したらループを抜ける Case Else MsgBox "サーバー 電文受信成功:" & ipBuffer End Select ElseIf recvResult = SOCKET_ERROR Then 'ノンンブロッキングもの以外のエラーはループを抜ける。 If Not Err.LastDllError = WSAEWOULDBLOCK Then MsgBox "SOCKET_ERROR " & GetFormatMessageString(Err.LastDllError) GoTo EXIT_POINT: End If End If Loop EXIT_POINT: If closesocket(ListenSocketHandle) = SOCKET_ERROR Then MsgBox "closesocket failed with error：" & GetFormatMessageString(Err.LastDllError) End If If WSACleanup() <> 0 Then MsgBox "Windows Sockets error occurred in Cleanup.", vbExclamation End If 'ここで自分自身を閉じる。 ThisWorkbook.Close Application.Quit End Sub Public Sub UDPSendTo(ByRef Msg As String) ' WSAStartup -> socket → sendto → closesocket WSACleanup Dim RetCode As Long Dim WSAData As WSAData Dim SendSocketHandle As Long Dim DstAddr As SOCKADDR_IN 'パラメータ Dim ip As String: ip = "127.0.0.1" Dim TargetPort As Long: TargetPort = 60051 Dim strbuffer As String strbuffer = Msg 'スタートアップ RetCode = WSAStartup(MAKEWORD(2, 2), WSAData) If RetCode <> 0 Then MsgBox "WSAStartup failed with error：" & GetFormatMessageString(RetCode) Exit Sub End If 'UDP socket SendSocketHandle = SOCKET(AF.AF_INET, SOCKTYPE.SOCK_DGRAM, PROTOCOL.IPPROTO_UDP) If SendSocketHandle = INVALID_SOCKET Then MsgBox "SOCKET failed with error：" & GetFormatMessageString(Err.LastDllError) GoTo EXIT_POINT End If DstAddr.sin_family = AF.AF_INET DstAddr.sin_addr = inet_addr(ip) DstAddr.sin_port = htons(Convert_u_short_PortNumber(TargetPort)) 'sendto 送信 RetCode = sendto(SendSocketHandle, strbuffer, Len(strbuffer), 0, DstAddr, Len(DstAddr)) If RetCode = SOCKET_ERROR Then MsgBox "sendto failed with error：" & GetFormatMessageString(Err.LastDllError) GoTo EXIT_POINT Else Debug.Print "Sendto:" & PrintIPAndPortNumber(DstAddr) End If EXIT_POINT: If closesocket(SendSocketHandle) = SOCKET_ERROR Then MsgBox "closesocket failed with error：" & GetFormatMessageString(Err.LastDllError) End If If WSACleanup() <> 0 Then MsgBox "Windows Sockets error occurred in Cleanup.", vbExclamation End If End Sub Function PrintIPAndPortNumber(ByRef Addr As SOCKADDR_IN) As String Dim s As String Dim s2 As String s = String(100, vbNullChar) Call InetNtopW(AF.AF_INET, Addr.sin_addr, s, 128) s2 = Replace(s, vbNullChar, "") PrintIPAndPortNumber = "IPv4アドレス：" & s2 & "ポート番号" & u_short_PortNumberToLong(ntohs(Addr.sin_port)) End Function Sub MainForMultiProcess() Dim SVApp As Application Dim SVWb As Workbook '別プロセスをサーバとして起動 Set SVApp = New Application SVApp.Visible = True 'デバッグ用に表示、不要であればfalseにすればよい Set SVWb = SVApp.Workbooks.Open(ThisWorkbook.FullName, _ UpdateLinks:=False, _ ReadOnly:=True) 'サーバプロセス起動 '※この時呼ばれるプロシージャにはOnTimeのみを記述し直ちに応答を返す。 Call SVApp.Run("'" & SVWb.Name & "'!OnTimeUDPRecvFrom") End Sub 'UDPRecvFromの起動 Private Sub OnTimeUDPRecvFrom() Application.OnTime Now + TimeValue("00:00:1"), "UDPRecvFrom" ' MsgBox "SubProc UDPRecvFrom 実行" End Sub 'サンプル電文 Sub testHELLO() Call UDPSendTo("HELLO") End Sub Sub testElse() Call UDPSendTo("else message ") End Sub Sub testQUIT() Call UDPSendTo("QUIT") End Sub 'ポート番号をu_short（16bitの符号なし整数型）に変換したデータの可読用表示用変換 Function u_short_PortNumberToLong(ByVal u_short_PortNumber As Integer) As Long u_short_PortNumberToLong = 65535 And u_short_PortNumber End Function ' 'ポート番号をu_short（16bitの符号なし整数型）に変換する。 'VBでは、16bitの型はIntegerになるが、符号あり整数ため、32767以上の整数値を代入するとオーバーフローする。 'そのためBitレベルで,Integer型にはめ込む Function Convert_u_short_PortNumber(ByVal PortNumber As Long) As Integer Select Case PortNumber Case Is < 0&: Err.Raise "UnderFlow PortNumber is 0 - 65535" Case 0 To 32767: Convert_u_short_PortNumber = PortNumber Case 32768 To 65535: Convert_u_short_PortNumber = PortNumber - 65536 Case Is > 65535: Err.Raise Number:=513, Description:="OverFlow PortNumber is 0 - 65535" End Select End Function |
コメント