Stuart McLachlan
stuart at lexacorp.com.pg
Tue Jun 30 08:02:07 CDT 2009
On 30 Jun 2009 at 13:50, Gustav Brock wrote:
> However, no function is included to reveal the subnet mask. The only "human" method I
>can locate for this purpose is to look up the registry:
I just found another API call which returns more info including the SubNet mask(s) so I've
modified clsResolve to include GetMyIPMask:
Option Compare Database
Option Explicit
'// define constants
Private Const IP_SUCCESS As Long = 0
Private Const SOCKET_ERROR As Long = -1
Private Const MAX_WSADescription As Long = 256
Private Const MAX_WSASYSStatus As Long = 128
Private Const MIN_SOCKETS_REQD As Long = 1
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 WSADescription_Len As Long = 256
Private Const WSASYS_Status_Len As Long = 128
Private Const AF_INET As Long = 2
'// structures
Private Type HOSTENT
hName As Long
hAliases As Long
hAddrType As Integer
hLength 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 Long
wMaxUDPDG As Long
dwVendorInfo As Long
End Type
Private Type IPINFO
dwAddr As Long ' IP address
dwIndex As Long ' interface index
dwMask As Long ' subnet mask
dwBCastAddr As Long ' broadcast address
dwReasmSize As Long ' assembly size
unused1 As Integer ' not currently used
unused2 As Integer '; not currently used
End Type
Private Type MIB_IPADDRTABLE
dEntrys As Long 'number of entries in the table
mIPInfo(5) As IPINFO 'array of IP address entries assumes maximum of 5 Interfaces
End Type
Private Type IP_Array
mBuffer As MIB_IPADDRTABLE
BufferLen As Long
End Type
'// api
'kernel32
Private Declare Sub apiCopyMemory Lib "kernel32" Alias "RtlMoveMemory" (xDest As Any,
xSource As Any, ByVal nBytes As Long)
Private Declare Function apiStrLen Lib "kernel32" Alias "lstrlenA" (lpString As Any) As Long
'wsock32
Private Declare Function apiGetHostByName Lib "wsock32.dll" Alias "gethostbyname"
(ByVal hostname As String) As Long
Private Declare Function apiWSAStartup Lib "wsock32.dll" Alias "WSAStartup" (ByVal
wVersionRequired As Long, lpWSADATA As WSADATA) As Long
Private Declare Function apiWSACleanup Lib "wsock32.dll" Alias "WSACleanup" () As Long
Private Declare Function apiInetAddr Lib "wsock32.dll" Alias "inet_addr" (ByVal s As String)
As Long
Private Declare Function apiGetHostByAddr Lib "wsock32.dll" Alias "gethostbyaddr" (haddr
As Long, ByVal hnlen As Long, ByVal addrtype As Long) As Long
Private Declare Function apiGetHostName Lib "wsock32.dll" Alias "gethostname" (ByVal
hostname$, ByVal HostLen As Integer) As Long
'IPHlpAPI
Private Declare Function GetIpAddrTable Lib "IPHlpApi" (pIPAdrTable As Byte, pdwSize As
Long, ByVal Sort As Long) As Long
'// private functions
Private Function InitializeSocket() As Boolean
Dim WSAD As WSADATA
'attempt to initialize the socket
InitializeSocket = apiWSAStartup(WS_VERSION_REQD, WSAD) = IP_SUCCESS
End Function
Private Sub CloseSocket()
'try to close the socket
If apiWSACleanup() <> 0 Then
MsgBox "Error calling apiWSACleanup.", vbCritical
End If
End Sub
Public Function GetIPFromHostName(ByVal sHostName As String) As String
'converts a host name to an IP address.
Dim nBytes As Long
Dim ptrHosent As Long
Dim hstHost As HOSTENT
Dim ptrName As Long
Dim ptrAddress As Long
Dim ptrIPAddress As Long
Dim sAddress As String 'declare this as Dim sAddress(1) As String if you want 2 ip
addresses returned
'try to initalize the socket
If InitializeSocket() = True Then
'try to get the IP
ptrHosent = apiGetHostByName(sHostName & vbNullChar)
If ptrHosent <> 0 Then
'get the IP address
apiCopyMemory hstHost, ByVal ptrHosent, LenB(hstHost)
apiCopyMemory ptrIPAddress, ByVal hstHost.hAddrList, 4
'fill buffer
sAddress = Space$(4)
'if you want multiple domains returned,
'fill all items in sAddress array with 4 spaces
apiCopyMemory ByVal sAddress, ByVal ptrIPAddress, hstHost.hLength
'change this to
'CopyMemory ByVal sAddress(0), ByVal ptrIPAddress, hstHost.hLength
'if you want an array of ip addresses returned
'(some domains have more than one ip address associated with it)
'get the IP address
GetIPFromHostName = IPToText(sAddress)
'if you are using multiple addresses, you need IPToText(sAddress(0)) & "," &
IPToText(sAddress(1))
'etc
End If
Else
MsgBox "Failed to open Socket."
End If
End Function
Private Function IPToText(ByVal IPAddress As String) As String
'converts characters to numbers
IPToText = CStr(Asc(IPAddress)) & "." & _
CStr(Asc(Mid$(IPAddress, 2, 1))) & "." & _
CStr(Asc(Mid$(IPAddress, 3, 1))) & "." & _
CStr(Asc(Mid$(IPAddress, 4, 1)))
End Function
Private Function ConvertAddressToString(longAddr As Long) As String
Dim myByte(3) As Byte
Dim Cnt As Long
CopyMemory myByte(0), longAddr, 4
For Cnt = 0 To 3
ConvertAddressToString = ConvertAddressToString + CStr(myByte(Cnt)) + "."
Next Cnt
ConvertAddressToString = Left$(ConvertAddressToString, Len(ConvertAddressToString)
- 1)
End Function
Public Function GetHostNameFromIP(ByVal sIPAddress As String) As String
Dim ptrHosent As Long
Dim hAddress As Long
Dim sHost As String
Dim nBytes As Long
'try to open the socket
If InitializeSocket() = True Then
'convert string address to long datatype
hAddress = apiInetAddr(sIPAddress)
'check if an error ocucred
If hAddress <> SOCKET_ERROR Then
'obtain a pointer to the HOSTENT structure
'that contains the name and address
'corresponding to the given network address.
ptrHosent = apiGetHostByAddr(hAddress, 4, AF_INET)
If ptrHosent <> 0 Then
'convert address and
'get resolved hostname
apiCopyMemory ptrHosent, ByVal ptrHosent, 4
nBytes = apiStrLen(ByVal ptrHosent)
If nBytes > 0 Then
'fill the IP address buffer
sHost = Space$(nBytes)
apiCopyMemory ByVal sHost, ByVal ptrHosent, nBytes
GetHostNameFromIP = sHost
End If
Else
MsgBox "Call to gethostbyaddr failed."
End If
'close the socket
CloseSocket
Else
MsgBox "Invalid IP address"
End If
Else
MsgBox "Failed to open Socket"
End If
End Function
Public Function GetMyHostName() As String
'Finds local HostName
Dim strHostname As String
Dim lngHostLen As Long
'try to initalize the socket
If InitializeSocket() = True Then
lngHostLen = 256
strHostname = Space$(lngHostLen)
If apiGetHostName(strHostname, lngHostLen) = SOCKET_ERROR Then
MsgBox "Windows Sockets error getting Host Name"
Else
strHostname = Trim$(strHostname)
strHostname = Left$(strHostname, Len(strHostname) - 1)
End If
Else
MsgBox "Failed to open Socket."
End If
GetMyHostName = strHostname
End Function
Public Function GetMyIPAddress() As String
GetMyIPAddress = GetIPFromHostName(GetMyHostName)
End Function
Public Function GetMyIPMask()
Dim Ret As Long
Dim bBytes() As Byte
Dim tel As Long
Dim Listing As MIB_IPADDRTABLE
On Error GoTo END1
GetIpAddrTable ByVal 0&, Ret, True
If Ret <= 0 Then Exit Function
ReDim bBytes(0 To Ret - 1) As Byte
'retrieve the data
GetIpAddrTable bBytes(0), Ret, False
'Get the first 4 bytes to get the entry's.. ip installed
CopyMemory Listing.dEntrys, bBytes(0), 4
'Copy whole structure to Listing and return for Adapter 1 (Adapter 0 = Loopback)
CopyMemory Listing.mIPInfo(1), bBytes(4 + (Len(Listing.mIPInfo(0)))),
Len(Listing.mIPInfo(1))
GetIPMask = ConvertAddressToString(Listing.mIPInfo(1).dwMask)
Exit Function
END1:
MsgBox "Error Resolving Subnet Mask"
End Function