|
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 |
Option Explicit Public Const SOCKET_ERROR As Long = -1 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 '/*** 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 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 '自分自身のホスト名を取得 Public Function GetMyhostname() As String Dim WSA As WSADATA Dim sName As String sName = String(1024, vbNullChar) Dim RetCode As Long RetCode = WSAStartup(MAKEWORD(2, 2), WSA) If (RetCode <> 0) Then Call WSACleanup Exit Function End If If gethostname(sName, Len(sName)) = SOCKET_ERROR Then Debug.Print Err.LastDllError Debug.Print Err.Number Debug.Print ErrMessage_GetLastError(Err.LastDllError) Debug.Print WSAGetLastError End If Call WSACleanup End Function Public Function MAKEWORD(Lo As Byte, Hi As Byte) As Integer MAKEWORD = Lo + Hi * 256& Or 32768 * (Hi > 127) 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 ' |
ホスト名（いわゆるコンピュータ名）を取得するサンプル
gethostnameというAPIを使っている。このサンプルではホスト名が文字列で出力される。IPアドレスが取得できるgethostbynameとは違うので注意
コメント