Attribute VB_Name = "modIPHostInfo"
Option Explicit

Private Const MAX_WSADescription As Long = 256
Private Const MAX_WSASYSStatus As Long = 128
Private Const ERROR_SUCCESS       As Long = 0
Private Const WS_VERSION_REQD     As Long = &H101
Private Const WS_VERSION_MAJOR    As Long = WS_VERSION_REQD \ &H100 And &HFF&
Private Const WS_VERSION_MINOR    As Long = WS_VERSION_REQD And &HFF&
Private Const MIN_SOCKETS_REQD    As Long = 1
Private Const SOCKET_ERROR        As Long = -1

Private Type HOSTENT
   hName      As Long
   hAliases   As Long
   hAddrType  As Integer
   hLen       As Integer
   hAddrList  As Long
End Type

Private Type WSADATA
   wVersion      As Integer
   wHighVersion  As Integer
   szDescription(0 To MAX_WSADescription)   As Byte
   szSystemStatus(0 To MAX_WSASYSStatus)    As Byte
   wMaxSockets   As Integer
   wMaxUDPDG     As Integer
   dwVendorInfo  As Long
End Type

Private Declare Function WSAGetLastError Lib "wsock32" () As Long
Private Declare Function WSAStartup Lib "wsock32" (ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long
Private Declare Function WSACleanup Lib "wsock32" () As Long
Private Declare Function gethostname Lib "wsock32" (ByVal szHost As String, ByVal dwHostLen As Long) As Long
Private Declare Function gethostbyname Lib "wsock32" (ByVal szHost As String) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)

Public Function GetIPAddress() As String
    Dim sHostName As String * 256
    Dim lpHost As Long
    Dim HOST  As HOSTENT
    Dim dwIPAddr As Long
    Dim tmpIPAddr() As Byte
    Dim i As Integer
    Dim sIPAddr As String
   
    If Not SocketsInitialize() Then
       GetIPAddress = ""
       Exit Function
    End If
     
    If gethostname(sHostName, 256) = SOCKET_ERROR Then
       GetIPAddress = ""
       MsgBox "Windows Sockets error " & Str$(WSAGetLastError()) & " has occurred. Unable to successfully get Host Name."
         If WSACleanup() <> ERROR_SUCCESS Then MsgBox "Socket error occurred in Cleanup."
         Exit Function
    End If
    
    sHostName = Trim$(sHostName)
    lpHost = gethostbyname(sHostName)
    If lpHost = 0 Then
       GetIPAddress = ""
       MsgBox "Windows Sockets are not responding. " & "Unable to successfully get Host Name."
       If WSACleanup() <> ERROR_SUCCESS Then MsgBox "Socket error occurred in Cleanup."
       Exit Function
    End If
     
    CopyMemory HOST, lpHost, Len(HOST)
    CopyMemory dwIPAddr, HOST.hAddrList, 4
    ReDim tmpIPAddr(1 To HOST.hLen)
    CopyMemory tmpIPAddr(1), dwIPAddr, HOST.hLen
    For i = 1 To HOST.hLen
       sIPAddr = sIPAddr & tmpIPAddr(i) & "."
    Next
    GetIPAddress = Mid$(sIPAddr, 1, Len(sIPAddr) - 1)
    If WSACleanup() <> ERROR_SUCCESS Then MsgBox "Socket error occurred in Cleanup."
End Function

Public Function GetIPHostName() As String
    Dim sHostName As String * 256
    If Not SocketsInitialize() Then
        GetIPHostName = ""
        Exit Function
    End If
    If gethostname(sHostName, 256) = SOCKET_ERROR Then
        GetIPHostName = ""
        MsgBox "Windows Sockets error " & Str$(WSAGetLastError()) & " has occurred.  Unable to successfully get Host Name."
        If WSACleanup() <> ERROR_SUCCESS Then MsgBox "Socket error occurred in Cleanup."
        Exit Function
    End If
    GetIPHostName = Left$(sHostName, InStr(sHostName, Chr(0)) - 1)
    If WSACleanup() <> ERROR_SUCCESS Then MsgBox "Socket error occurred in Cleanup."
End Function

Public Function SocketsInitialize() As Boolean
    Dim WSAD As WSADATA
    Dim sLoByte As String
    Dim sHiByte As String
    Dim byteLo As Byte
    Dim byteHi As Byte
    
    If WSAStartup(WS_VERSION_REQD, WSAD) <> ERROR_SUCCESS Then
       MsgBox "The 32-bit Windows Socket is not responding."
       SocketsInitialize = False
       Exit Function
    End If
    If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then
         MsgBox "This application requires a minimum of " & CStr(MIN_SOCKETS_REQD) & " supported sockets."
         SocketsInitialize = False
         Exit Function
     End If
    
    byteLo = CByte(WSAD.wVersion And &HFF&)
    byteHi = CByte((WSAD.wVersion And &HFF00&) \ (&H100))
    If ((byteLo < WS_VERSION_MAJOR) Or ((byteLo = WS_VERSION_MAJOR) And (byteHi < WS_VERSION_MINOR))) Then
         sLoByte = CStr(byteLo)
         sHiByte = CStr(byteHi)
         MsgBox "Sockets version " & sLoByte & "." & sHiByte & " is not supported by 32-bit Windows Sockets."
         SocketsInitialize = False
         Exit Function
    End If
    SocketsInitialize = True
End Function
