ホスト名からIPアドレスを取得する処理サンプルを作ろうとgethostbynameと悪戦苦闘しているが、いまいちうまくできない。他に何か方法がないか調べていたら、たまたま stackoverflow
のサイトを調べていたらgetaddrinfoを使ったホスト名からIPアドレスを取得するサンプルコードを発見。
そこで、そのコードを軸にちょっとだけ自分流にアレンジ
サンプルコード改
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 |
Option Explicit Private Const AF_UNSPEC As Long = 0 Private Const AF_INET As Long = 2 Private Const AF_INET6 As Long = 23 Private Const SOCK_STREAM As Long = 1 Private Const INADDR_ANY As Long = 0 Private Const IPPROTO_TCP As Long = 6 'AI_flags Private Const AI_PASSIVE As Long = &H1 Private Const ai_canonName As Long = &H2 Private Const AI_NUMERICHOST As Long = &H4 Private Const AI_ALL As Long = &H100 Private Const AI_ADDRCONFIG As Long = &H400 Private Const AI_V4MAPPED As Long = &H800 Private Const AI_NON_AUTHORITATIVE As Long = &H4000 Private Const AI_SECURE As Integer = &H8000 Private Const AI_RETURN_PREFERRED_NAMES As Long = &H10000 Private Const AI_FQDN As Long = &H20000 Private Const AI_FILESERVER As Long = &H40000 Private Const INVALID_SOCKET As Long = -1 Private Type in_addr s_addr As LongPtr End Type Private Type sockaddr_in sin_family As Integer '2 bytes sin_port As Integer '2 bytes sin_addr As in_addr '4 bytes or 8 bytes sin_zero(7) As Byte '8 bytes End Type 'Total 16 bytes or 24 bytes Private Type sockaddr sa_family As Integer '2 bytes sa_data(25) As Byte '26 bytes End Type 'Total 28 bytes Private Type addrinfo ai_flags As Long ai_family As Long ai_socktype As Long ai_protocol As Long ai_addrlen As Long ai_canonName As LongPtr 'strptr ai_addr As LongPtr 'p sockaddr ai_next As LongPtr 'p addrinfo End Type '/*** Fromat Message ' Constants - 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 Any) _ As Long ' To initialize Winsock. Private Const WSADESCRIPTION_LEN As Integer = 256 Private Const WSASYS_STATUS_LEN As Integer = 128 Private Type WSADATA wVersion As Integer wHighVersion As Integer szDescription(0 To WSADESCRIPTION_LEN) As Byte szSystemstatus(0 To WSADESCRIPTION_LEN) As Byte iMaxSockets As Integer iMaxUdpDg As Integer lpVendorInfo As Long End Type Private Declare PtrSafe Function WSAStartup Lib "wsock32.dll" (ByVal wVersionRequested As Integer, lpWSAData As Any) As Long Private Declare PtrSafe Function WSACleanup Lib "wsock32.dll" () As Long Private Declare PtrSafe Function gethostname Lib "wsock32.dll" (ByVal name As String, ByVal namelen As Long) As Long Private Declare PtrSafe Function socket Lib "ws2_32.dll" (ByVal af As Long, ByVal stype As Long, ByVal Protocol As Long) As Long Private Declare PtrSafe Function getaddrinfo Lib "ws2_32.dll" (ByVal NodeName As String, ByVal ServName As String, ByVal lpHints As LongPtr, lpResult As LongPtr) As Long Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) Private Declare PtrSafe Function ntohs Lib "ws2_32.dll" (ByVal neshort As Long) As Integer '1つの引数(文字列として渡されるホスト名)が必要です。 '2番目の引数は、返すIPアドレスの最大数(整数として渡されます)ですが、オプションです。 '2番目の引数が空白の場合、すべてのIPアドレスが返されます。ゼロ以外の値に設定すると、その値がホストのIPアドレスの最大数になります。 Public Function HostNameToIPaddress(ByVal HostName As String, Optional MaxReturn As Integer = 0) As String Dim sa_local As sockaddr_in Dim sa_dest As sockaddr Dim RetCode As Long Dim RetString As String Dim Hints As addrinfo Dim ptrResult As LongPtr Dim IPaddress As String Dim AddressList As String Dim AddressType As Long Dim Cnt As Integer Dim WSADATA As WSADATA Dim hSocket As Long Dim sServer As String 'winsock setup RetCode = WSAStartup(MAKEWORD(2, 2), WSADATA) If RetCode <> 0 Then RetString = ErrMessage_GetLastError(RetCode) GoTo EXCEPTION End If AddressType = AF_INET If HostName = "" Then RetString = "第一引数のHostNameが空です。設定してください。" GoTo EXCEPTION End If 'Create TCP socket hSocket = socket(AddressType, SOCK_STREAM, IPPROTO_TCP) If hSocket = INVALID_SOCKET Then RetString = ErrMessage_GetLastError(RetCode) GoTo EXCEPTION End If 'Populate the local sockaddr sa_local.sin_family = AddressType sa_local.sin_port = ntohs(0&) sa_local.sin_addr.s_addr = INADDR_ANY 'Recover info about the destination. 'Hints.ai_flags = AI_NON_AUTHORITATIVE Hints.ai_flags = 0 Hints.ai_family = AddressType sServer = HostName & vbNullChar 'Null terminated string sServer = HostName RetCode = getaddrinfo(sServer, 0, VarPtr(Hints), ptrResult) If RetCode <> 0 Then RetString = ErrMessage_GetLastError(RetCode) GoTo EXCEPTION End If Cnt = 0 Hints.ai_next = ptrResult 'Pointer to first structure in linked list Do While Hints.ai_next > 0 And (Cnt < MaxReturn Or MaxReturn = 0) CopyMemory Hints, ByVal Hints.ai_next, LenB(Hints) 'Copy next address info to Hints CopyMemory sa_dest, ByVal Hints.ai_addr, LenB(sa_dest) 'Save sockaddr portion Select Case sa_dest.sa_family Case AF_INET IPaddress = sa_dest.sa_data(2) & "." & sa_dest.sa_data(3) & "." & sa_dest.sa_data(4) & "." & sa_dest.sa_data(5) Case AF_INET6 IPaddress = sa_dest.sa_data(0) & ":" & sa_dest.sa_data(1) & ":" & sa_dest.sa_data(2) & "::" & sa_dest.sa_data(3) & ":" & sa_dest.sa_data(4) Case Else IPaddress = "" End Select Cnt = Cnt + 1 If AddressList = "" Then AddressList = IPaddress Else AddressList = AddressList & "," & IPaddress End If Loop RetString = AddressList FINALLY: HostNameToIPaddress = RetString Call WSACleanup Exit Function EXCEPTION: RetString = "エラー発生:" & RetString GoTo FINALLY End Function Public Function ErrMessage_GetLastError(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) Else lpBuffer = "" End If ErrMessage_GetLastError = lpBuffer ErrMessage_GetLastError = lpBuffer & "(" & dwMessageId & ")" End Function Public Function MAKEWORD(Lo As Byte, Hi As Byte) As Integer MAKEWORD = Lo + Hi * 256& Or 32768 * (Hi > 127) End Function Sub DebugTest() Debug.Print "--------テスト結果1---------" Debug.Print HostNameToIPaddress("com", 0) Debug.Print "--------テスト結果2---------" Debug.Print HostNameToIPaddress("www.ntt.com", 0) Debug.Print "--------テスト結果3---------" Debug.Print HostNameToIPaddress("yahoo.co.jp", 0) Debug.Print "--------テスト結果4---------" Debug.Print HostNameToIPaddress("google.com", 0) End Sub |
実行結果
1 2 3 4 5 6 7 8 |
--------テスト結果1--------- エラー発生:そのようなホストは不明です。 (11001) --------テスト結果2--------- 23.42.121.60 --------テスト結果3--------- 183.79.135.206,182.22.59.229 --------テスト結果4--------- 172.217.26.14 |
ホスト名からIPアドレスが引けている!
コメント