Get IP Address

'Get IP Address

'need 1 module And 1 form




'in form

Private Sub Form_Load()

MsgBox "IP-address: " + GetIPAddress, vbOKOnly, "RockessAlpha.blogspot.com"

End Sub



'In module

Public Const MIN_SOCKETS_REQD As Long = 1

Public Const WS_VERSION_REQD As Long = &H101

Public Const WS_VERSION_MAJOR As Long = WS_VERSION_REQD \ _

&H100 And &HFF&

Public Const WS_VERSION_MINOR As Long = WS_VERSION_REQD And _

&HFF&



Public Const SOCKET_ERROR As Long = -1

Public Const WSADESCRIPTION_LEN = 257

Public Const WSASYS_STATUS_LEN = 129

Public Const MAX_WSADescription = 256

Public Const MAX_WSASYSStatus = 128



Public 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



Type WSADataInfo

   
wVersion As Integer

   
wHighVersion As Integer

   
szDescription As String * WSADESCRIPTION_LEN

   
szSystemStatus As String * WSASYS_STATUS_LEN

   
iMaxSockets As Integer

   
iMaxUdpDg As Integer

   
lpVendorInfo As String

End Type



Public Type HOSTENT

   
hName As Long

   
hAliases As Long

   
hAddrType As Integer

   
hLen As Integer

   
hAddrList As Long

End Type



Declare Function WSAStartupInfo Lib "WSOCK32" Alias "WSAStartup" _

(ByVal wVersionRequested As Integer, lpWSADATA
As WSADataInfo) _

As Long

Declare Function WSACleanup Lib "WSOCK32" () As Long

Declare Function WSAGetLastError Lib "WSOCK32" () As Long

Declare Function WSAStartup Lib "WSOCK32" _

(ByVal wVersionRequired As Long, lpWSADATA
As WSAData) As Long

Declare Function GetHostName Lib "WSOCK32" _

(ByVal szHost As String, ByVal dwHostLen As Long) As Long

Declare Function GetHostbyName Lib "WSOCK32" _

(ByVal szHost As String) As Long

Declare Sub CopyMemoryIP 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."

SocketsCleanup

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."

SocketsCleanup

Exit Function

End If



CopyMemoryIP HOST, lpHost, Len(HOST)

CopyMemoryIP dwIPAddr, HOST.hAddrList, 4

ReDim tmpIPAddr(1 To HOST.hLen)

CopyMemoryIP tmpIPAddr(1), dwIPAddr, HOST.hLen



For I = 1 To HOST.hLen

sIPAddr = sIPAddr & tmpIPAddr(I) & "."

Next



GetIPAddress = Mid$(sIPAddr, 1, Len(sIPAddr) - 1)

SocketsCleanup

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."

SocketsCleanup

Exit Function

End If



GetIPHostName = Left$(sHostName, InStr(sHostName, Chr(0)) - 1)

SocketsCleanup

End Function



Public Function HiByte(ByVal wParam As Integer)

HiByte = wParam \ &H100 And &HFF&

End Function



Public Function LoByte(ByVal wParam As Integer)

LoByte = wParam And &HFF&

End Function



Public Sub SocketsCleanup()

If WSACleanup() <> ERROR_SUCCESS Then

MsgBox "Socket error occurred in Cleanup."

End If

End Sub



Public Function SocketsInitialize()
As Boolean

Dim WSAD As WSAData

Dim sLoByte As String

Dim sHiByte As String



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



If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or _

(LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And _

HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then

sHiByte = CStr(HiByte(WSAD.wVersion))

sLoByte = CStr(LoByte(WSAD.wVersion))

MsgBox "Sockets version " & sLoByte & "." & sHiByte & _

" is not supported by 32-bit Windows Sockets."

SocketsInitialize = False

Exit Function

End If



'must be OK, so lets do it

SocketsInitialize = True

End Function