[AccessD] Obtaining IP Address

JWColby jwcolby at colbyconsulting.com
Thu Mar 22 09:36:48 CDT 2007


That worked.  The only issue is that there are often more than one IP
addresses and this only returns one.  My laptop for example has two, one for
the wireless connection and one for the cable connection.  But this is a
good start.

Thanks,

John W. Colby
Colby Consulting
www.ColbyConsulting.com

-----Original Message-----
From: accessd-bounces at databaseadvisors.com
[mailto:accessd-bounces at databaseadvisors.com] On Behalf Of Gustav Brock
Sent: Thursday, March 22, 2007 10:14 AM
To: accessd at databaseadvisors.com
Subject: Re: [AccessD] Obtaining IP Address

Hi John

This is more convoluted than you might believe.
Here is one method: MachineHostAddress

<module>

Option Compare Database
Option Explicit

Private Const MAX_WSADescription  As Long = 256
Private Const MAX_WSASYSStatus    As Long = 128
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 Const ERROR_NONE          As Long = 0
Private Const IP_SUCCESS          As Long = 0

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 Declare Function GetHostName Lib "wsock32.dll" Alias "gethostname" (
_
  ByVal szHost As String, _
  ByVal dwHostLen As Long) _
  As Long

Private Declare Function GetHostByName Lib "wsock32.dll" Alias
"gethostbyname" ( _
  ByVal Hostname As String) _
  As Long
 
Private Declare Function WSAStartup Lib "wsock32.dll" ( _
  ByVal wVersionRequired As Long, _
  ByRef lpWSADATA As WSADATA) _
  As Long
   
Private Declare Function WSACleanup Lib "wsock32.dll" () _
  As Long

Private Declare Function inet_ntoa Lib "wsock32.dll" ( _
  ByVal addr As Long) _
  As Long
                       
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
  ByRef xDest As Any, _
  ByRef xSource As Any, _
  ByVal nbytes As Long)

Private Declare Function lstrcpyA Lib "kernel32" ( _
  ByVal RetVal As String, _
  ByVal Ptr As Long) _
  As Long

Private Declare Function lstrlenA Lib "kernel32" ( _
  ByRef lpString As Any) _
  As Long

Public Function MachineHostName() _
  As String
  
' Retrieves the host name of this machine.
'
' The host name is preserved in a static variable to ' reduce look up time
for repeated calls.

  Static strHostname    As String
  
  If Len(strHostname) = 0 Then
    ' Host name has not been looked up previously.
    If WinSocketsStart() = True Then
      ' Obtain and store the host name.
      strHostname = GetMachineName()
      
      Call WinSocketsClean
    End If
  End If
  
  MachineHostName = strHostname

End Function

Public Function MachineHostAddress( _
  Optional ByVal strHostname As String) _
  As String
  
' Retrieves IP address of the machine with the host name ' strHostname.
' If a zero length host name or no host name is passed, the ' address of
this machine is returned.
' If host name localhost is passed, 127.0.0.1 is returned.
' If the host name cannot be resolved, 0.0.0.0 is returned.
'
' The host addresses are preserved in a static collection to ' reduce look
up time for repeated calls.

  ' If strHostname is an empty string, the local host address
  ' will be looked up.
  ' However, an empty string cannot be a key in a collection.
  ' Use this key to store the local host address.
  Const cstrKeyThisHost As String = " "
  
  Static colAddress     As New Collection
  
  Dim strIpAddress      As String
  
  ' Ignore error when looking up a key in collection
  ' colAddress that does not exist.
  On Error Resume Next
  
  If Len(strHostname) = 0 Then
    strHostname = cstrKeyThisHost
  End If
  strIpAddress = colAddress.Item(strHostname)
  ' If strHostname is not found, an error is raised.
  If Err.Number <> 0 Then
    ' This host name has not been looked up previously.
    If WinSocketsStart() = True Then
      ' Obtain the host address.
      ' Trim strHostname to pass a zero length string when
      ' looking up the address of the local host.
      strIpAddress = GetIPFromHostName(Trim(strHostname))
      ' Store the host address.
      colAddress.Add strIpAddress, strHostname
      
      Call WinSocketsClean
    End If
  End If
  
  MachineHostAddress = strIpAddress
  
End Function

Public Sub ShowHostNameAddress()

' Displays host name and IP address of local machine.

  Const cstrMsgTitle  As String = "Host name and IP address"
  Const clngMsgStyle0 As Long = vbExclamation + vbOKOnly
  Const clngMsgStyle1 As Long = vbInformation + vbOKOnly
  Const cstrMsgPrompt As String = "No access to address information."
  
  Dim strHostname   As String
  Dim strIpAddress  As String
  Dim strMsgPrompt  As String
  
  If WinSocketsStart() = True Then
    ' Obtain and pass the host address.
    strHostname = GetMachineName()
    strIpAddress = GetIPFromHostName(strHostname)
    ' Display name and address.
    strMsgPrompt = _
      "Host name: " & strHostname & vbCrLf & _
      "IP address: " & strIpAddress
    MsgBox strMsgPrompt, clngMsgStyle1, cstrMsgTitle
    
    Call WinSocketsClean
  Else
    MsgBox cstrMsgPrompt, clngMsgStyle0, cstrMsgTitle
  End If
  
End Sub

Private Function WinSocketsStart() _
  As Boolean

' Start up Windows sockets before use.

  Const cstrMsgTitle  As String = "Windows Sockets"
  Const clngMsgStyle  As Long = vbCritical + vbOKOnly
  Const cstrMsgPrompt As String = "Error at start up of Windows sockets."
  
  Dim typWSA      As WSADATA
  Dim booSuccess  As Boolean
  
  If WSAStartup(WS_VERSION_REQD, typWSA) = IP_SUCCESS Then
    booSuccess = True
  End If
  
  If booSuccess = False Then
    MsgBox cstrMsgPrompt, clngMsgStyle, cstrMsgTitle
  End If
  
  WinSocketsStart = booSuccess
   
End Function

Private Function WinSocketsClean() _
  As Boolean

' Clean up Windows sockets after use.

  Const cstrMsgTitle  As String = "Windows Sockets"
  Const clngMsgStyle  As Long = vbExclamation + vbOKOnly
  Const cstrMsgPrompt As String = "Error at clean up of Windows sockets."
  
  Dim booSuccess  As Boolean

  If WSACleanup() = ERROR_NONE Then
    booSuccess = True
  End If
   
  If booSuccess = False Then
    MsgBox cstrMsgPrompt, clngMsgStyle, cstrMsgTitle
  End If

  WinSocketsClean = booSuccess

End Function
  
Private Function GetMachineName() As String

' Retrieves the host name of this machine.

  ' Assign buffer for maximum length of host name plus
  ' a terminating null char.
  Const clngBufferLen As Long = 255 + 1
  
  Dim stzHostName As String * clngBufferLen
  Dim strHostname As String
  
  If GetHostName(stzHostName, clngBufferLen) = ERROR_NONE Then
    ' Trim host name from buffer string.
    strHostname = Left(stzHostName, InStr(1, stzHostName, vbNullChar,
vbBinaryCompare) - 1)
  End If
  
  GetMachineName = strHostname
  
End Function

Private Function GetIPFromHostName( _
  ByVal strHostname As String) _
  As String

' Converts a host name to its IP address.
'
' If strHostname
'   - is zero length, local IP address is returned.
'   - is "localhost", IP address 127.0.0.1 is returned.
'   - cannot be resolved, unknown IP address 0.0.0.0 is returned.

  Const clngAddressNone   As Long = 0
  ' The Address is offset 12 bytes from the
  ' start of the HOSENT structure.
  Const clngAddressOffset As Long = 12
  ' Size of address part.
  Const clngAddressChunk  As Long = 4
  ' Address to return if none found.
  Const cstrAddressZero   As String = "0.0.0.0"

  ' Address of HOSENT structure.
  Dim ptrHosent           As Long
  ' Address of name pointer.
  Dim ptrName             As Long
  ' Address of address pointer.
  Dim ptrAddress          As Long
  Dim ptrIPAddress        As Long
  Dim ptrIPAddress2       As Long
  Dim stzHostName         As String
  Dim strAddress          As String

  stzHostName = strHostname & vbNullChar
  ptrHosent = GetHostByName(stzHostName)

  If ptrHosent = clngAddressNone Then
    ' Return address zero.
    strAddress = cstrAddressZero
  Else
    ' Assign pointer addresses and offset Null-terminated list
    ' of addresses for the host.
    ' Note:
    ' We are retrieving only the first address returned.
    ' To return more than one, define strAddress as a string array
    ' and loop through the 4-byte ptrIPAddress members returned.
    ' The last item is a terminating null.
    ' All addresses are returned in network byte order.
    ptrAddress = ptrHosent + clngAddressOffset
    
    ' Get the IP address.
    CopyMemory ptrAddress, ByVal ptrAddress, clngAddressChunk
    CopyMemory ptrIPAddress, ByVal ptrAddress, clngAddressChunk
    CopyMemory ptrIPAddress2, ByVal ptrIPAddress, clngAddressChunk
    
    strAddress = GetInetStrFromPtr(ptrIPAddress2)
  End If
  
  GetIPFromHostName = strAddress
  
End Function

Private Function GetInetStrFromPtr( _
  ByVal lngAddress As Long) _
  As String
 
' Converts decimal IP address to IP address string.

  GetInetStrFromPtr = GetStrFromPtrA(inet_ntoa(lngAddress))

End Function

Private Function GetStrFromPtrA( _
  ByVal lpszA As Long) _
  As String
  
' Copies string from pointer.

  ' Create buffer string.
  GetStrFromPtrA = String(lstrlenA(ByVal lpszA), vbNullChar)
  ' Copy value from pointer to buffer string.
  Call lstrcpyA(ByVal GetStrFromPtrA, ByVal lpszA)
  
End Function

</module>

/gustav

>>> jwcolby at colbyconsulting.com 22-03-2007 14:59 >>>
Is there VBA code out there to obtain the IP address of the current
workstation?  I found code that goes through the registry, and it ALMOST
works, in fact it does work in many instances but...
 
John W. Colby
Colby Consulting
www.ColbyConsulting.com 

--
AccessD mailing list
AccessD at databaseadvisors.com
http://databaseadvisors.com/mailman/listinfo/accessd
Website: http://www.databaseadvisors.com




More information about the AccessD mailing list