frog.raindrop.jp.knowledge

Attribute VB_Name = "basNetApi"
Option Explicit
Private Const mcstrMODULE_NAME  As String = "basNetApi"
Private Const MAX_PATH          As Long = 260&

Public Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Function lstrcpynA Lib "kernel32" (lpString1 As Any, lpString2 As Any, ByVal iMaxLength As Long) As Long
Public Declare Function lstrcpyA Lib "kernel32" (lpString1 As Any, lpString2 As Any) As Long
Public Declare Function lstrcpynW Lib "kernel32" (lpString1 As Any, lpString2 As Any, ByVal iMaxLength As Long) As Long
Public Declare Function lstrcpyW Lib "kernel32" (lpString1 As Any, lpString2 As Any) As Long

Private Declare Function NetServerGetInfo Lib "NETAPI32.DLL" (lpwszServerName As Any, ByVal dwLevel As Long, lpBufPtr As Any) As Long

Private Declare Function NetApiBufferFree Lib "NETAPI32.DLL" (lpBuffer As Any) As Long

Private Type mtypSERVER_INFO_100
    sv100_platform_id           As Long
    sv100_name                  As Long
End Type

Private Const FORMAT_MESSAGE_ALLOCATE_BUFFER As Long = &H100&
Private Const FORMAT_MESSAGE_IGNORE_INSERTS  As Long = &H200&
Private Const FORMAT_MESSAGE_FROM_STRING     As Long = &H400&
Private Const FORMAT_MESSAGE_FROM_HMODULE    As Long = &H800&
Private Const FORMAT_MESSAGE_FROM_SYSTEM     As Long = &H1000&
Private Const FORMAT_MESSAGE_ARGUMENT_ARRAY  As Long = &H2000&
Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK  As Long = &HFF&

Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, lpBuffer As Any, ByVal nSize As Long, Arguments As Long) As Long


'******************************************************************
'プロシージャ名:  :GetLocalHostName
'説明:            :ローカルコンピュータ名を取得する
'戻り値           :String型
'******************************************************************
Public Function GetLocalHostName() As String
'============= Declare ==============
Dim udtBuf          As mtypSERVER_INFO_100
Dim lngRet          As Long
Dim lngBuf          As Long
Dim rgbytBuf()      As Byte
Dim strRet          As String

'============= Initiarize ===========
On Error GoTo GetLocalHostName_E00
    GetLocalHostName = ""
'============= Main =================
        
    ' 情報を取得
    lngRet = NetServerGetInfo(ByVal 0&, 100, lngBuf)
    If lngRet Then Call DllErrRaise(Err.LastDllError, "NETAPI32")
On Error GoTo GetLocalHostName_E10
    
    ' ﾎﾟｲﾝﾀより構造体をｺﾋﾟｰ
    Call MoveMemory(udtBuf, ByVal lngBuf, Len(udtBuf))
    
    ' ｺﾝﾋﾟｭｰﾀ名ｺﾋﾟｰ
    ReDim rgbytBuf(MAX_PATH - 1&)
    Call lstrcpyW(rgbytBuf(0), ByVal udtBuf.sv100_name) ' 文字列型で受けるとﾕﾆｺｰﾄﾞに再変換されてしまうため、
    strRet = rgbytBuf                                   ' いったんﾊﾞｲﾄ配列で受ける
    
    GetLocalHostName = Left(strRet, InStr(strRet, vbNullChar) - 1&)
    
'============= Release ==============
GetLocalHostName_L00:
    Call NetApiBufferFree(ByVal lngBuf)
    Exit Function
'============= Error ================
GetLocalHostName_E10:
    Call NetApiBufferFree(ByVal lngBuf)
GetLocalHostName_E00:
    Call Err.Raise(vbObjectError Or Err.Number, mcstrMODULE_NAME & ".GetLocalHostName" & "(" & Err.Source & ")", Err.Description, Err.HelpFile, Err.HelpContext)

End Function

'******************************************************************
'プロシージャ名:  :pDllErrRaise
'説明:            :Err.LastDllErrorよりエラーを発生する
'引数:            :plngLastDllError   I   Err.LastDllError
'                 :pstrErrSource      O   エラーソース文字列
'******************************************************************
Public Sub DllErrRaise(ByVal plngLastDllError As Long, pstrErrSource As String)
'============= Declare ==============
Const clngMAX_BUFFER            As Long = 1024&
Dim bytBuf(clngMAX_BUFFER - 1&) As Byte 'バッファ
Dim lngRet                      As Long 'APIの戻り値
Dim strErrDescription           As String

'============= Initiarize ===========
    If plngLastDllError = 0& Then
        Exit Sub
    End If
    Erase bytBuf
    strErrDescription = ""
'============= Main =================
    
    '@@ ｴﾗｰ値に対応するメッセージを取得する
    lngRet = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS, _
                            ByVal 0&, _
                            plngLastDllError, _
                            0&, _
                            bytBuf(0), _
                            clngMAX_BUFFER, _
                            ByVal 0&)
    If lngRet Then
        strErrDescription = StrConv(LeftB(bytBuf, lngRet), vbUnicode)
    End If
    
    '@@ ｴﾗｰを発生する
    Call Err.Raise(plngLastDllError Or vbObjectError, pstrErrSource, strErrDescription)
    
End Sub