[dba-VB] Obtaining IP Address

Drew Wutka DWUTKA at Marlow.com
Thu Mar 22 09:46:03 CDT 2007


Here's a function that does that:

Private Function GetMyIPs()
On Error GoTo ErrorHandler
Dim strSubNet As String
Dim rg As Registry
Dim rg2 As Registry
Dim rk As RegistryKey
Dim rv As RegistryValue
Dim i As Long
Dim j As Long
Set rg = New Registry
rg.RootKey = HKEY_LOCAL_MACHINE
rg.CurrentKey =
"SYSTEM\CurrentControlSet\Services\Tcpip\Parameters\Interfaces"
For i = 1 To rg.KeyCount
    Set rk = rg.KeyInfo(i)
    Set rg2 = New Registry
    rg2.RootKey = rg.RootKey
    rg2.CurrentKey = rg.CurrentKey & "\" & rk.KeyName
    Set rv = rg2.ValueByName("IPAddress")
    If rv.ValueData <> "0.0.0.0" And rv.ValueData <> "" And Not
OneOfMyIPAddresses(rv.ValueData) Then
        MyIPs.Add rv.ValueData, rv.ValueData
        Set rv = rg2.ValueByName("SubnetMask")
        strSubNet = rv.ValueData
        GetIPRange MyIPs(MyIPs.Count), strSubNet
    End If
    Set rv = rg2.ValueByName("DhcpIPAddress")
    If rv.ValueData <> "0.0.0.0" And rv.ValueData <> "" And Not
OneOfMyIPAddresses(rv.ValueData) Then
        MyIPs.Add rv.ValueData, rv.ValueData
        Set rv = rg2.ValueByName("DhcpSubnetMask")
        strSubNet = rv.ValueData
        GetIPRange MyIPs(MyIPs.Count), strSubNet
    End If
Next i
Set rv = Nothing
Set rk = Nothing
Set rg2 = Nothing
Set rg = Nothing
Exit Function

ErrorHandler:
issErrorHandler.Module = "LocalNetwork"
issErrorHandler.Procedure = "GetMyIPs"
issErrorHandler.ErrorNumber = Err.Number
issErrorHandler.ErrorDescription = Err.Description
issErrorHandler.RaiseError
Err.Clear
End Function

Here's the RegistryKey class:

Option Explicit
Public KeyName As String

Here's the RegistryValue Class:

Option Explicit
Public KeyName As String

Here's the Registry Class:

Option Explicit
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias
"RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal
ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As
Long) As Long
Private Declare Function RegEnumValue Lib "advapi32.dll" Alias
"RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal
lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long,
lpType As Long, lpData As Byte, lpcbData As Long) As Long
Private Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias
"RegEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName
As String, lpcbName As Long, lpReserved As Long, ByVal lpClass As
String, lpcbClass As Long, lpftLastWriteTime As FILETIME) As Long
Private Const ERROR_SUCCESS = 0&
Private Const ERROR_NO_MORE_ITEMS = 259&
Private Const REG_SZ = 1
Private Const REG_EXPAND_SZ = 2                  ' Unicode nul
terminated string
Private Const REG_BINARY = 3                     ' Free form binary
Private Const REG_DWORD = 4                      ' 32-bit number
Private Const STANDARD_RIGHTS_ALL = &H1F0000
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_SET_VALUE = &H2
Private Const KEY_CREATE_SUB_KEY = &H4
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_CREATE_LINK = &H20
Private Const KEY_NOTIFY = &H10
Private Const SYNCHRONIZE = &H100000
Private Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE
Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or
KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE))
Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
Public Enum RegistryRoot
    HKEY_CLASSES_ROOT = &H80000000
    HKEY_CURRENT_CONFIG = &H80000005
    HKEY_CURRENT_USER = &H80000001
    HKEY_DYN_DATA = &H80000006
    HKEY_LOCAL_MACHINE = &H80000002
    HKEY_PERF_ROOT = HKEY_LOCAL_MACHINE
    HKEY_PERFORMANCE_DATA = &H80000004
    HKEY_USERS = &H80000003
End Enum
Private Type ByteArray
    FirstByte As Byte
    ByteBuffer(255) As Byte
End Type
Dim intCurrentRoot As Long
Dim strCurrentKey As String
Dim Values As Collection
Dim Keys As Collection
Dim hKey As Long
Private Function GetKeyInformation()
On Error Resume Next
Dim dwReturn As Long
Dim rk As RegistryKey
Dim rv As RegistryValue
Dim intIndex As Long
Dim intBuffer As Long
Dim ftReg As FILETIME
Dim RegValue As ByteArray
Dim intDataType As Long
Dim intValueBuffer As Long
Dim strTempName As String
Dim i As Long
RegCloseKey hKey
dwReturn = RegOpenKeyEx(intCurrentRoot, strCurrentKey, 0,
KEY_ALL_ACCESS, hKey)
Set Keys = New Collection
Set Values = New Collection
If dwReturn = ERROR_SUCCESS Then
    dwReturn = 0
    intIndex = 0
    Do Until dwReturn = ERROR_NO_MORE_ITEMS
        intBuffer = 255
        Set rk = New RegistryKey
        strTempName = Space(intBuffer)
        dwReturn = RegEnumKeyEx(hKey, intIndex, strTempName, intBuffer,
ByVal 0&, vbNullString, ByVal 0&, ftReg)
        If dwReturn = ERROR_SUCCESS Then
            rk.KeyName = Left(strTempName, intBuffer)
            Keys.Add rk
            Set rk = Nothing
            intIndex = intIndex + 1
        End If
    Loop
    dwReturn = 0
    intIndex = 0
    Do Until dwReturn = ERROR_NO_MORE_ITEMS
        intBuffer = 255
        Set rv = New RegistryValue
        strTempName = Space(intBuffer)
        For i = 0 To 255
            RegValue.ByteBuffer(i) = 0
        Next i
        intValueBuffer = 255
        dwReturn = RegEnumValue(hKey, intIndex, strTempName, intBuffer,
0, intDataType, RegValue.FirstByte, intValueBuffer)
        If dwReturn = ERROR_SUCCESS Then
            rv.ValueName = Left(strTempName, intBuffer)
            Select Case intDataType
                Case REG_SZ, REG_EXPAND_SZ
                    rv.ValueData = Chr(RegValue.FirstByte)
                    For i = 0 To intValueBuffer - 3
                        rv.ValueData = rv.ValueData &
Chr(RegValue.ByteBuffer(i))
                    Next i
                Case 7
                    rv.ValueData = Chr(RegValue.FirstByte)
                    For i = 0 To intValueBuffer - 3
                        If RegValue.ByteBuffer(i) = 0 Then
                            Exit For
                        Else
                            rv.ValueData = rv.ValueData &
Chr(RegValue.ByteBuffer(i))
                        End If
                    Next i
                Case REG_DWORD
                    rv.ValueData = Trim(Str(RegValue.FirstByte + (256 *
RegValue.ByteBuffer(0)) + (65536 * RegValue.ByteBuffer(1)) + (16777216 *
RegValue.ByteBuffer(2))))
                Case REG_BINARY
                    rv.ValueData = Trim(Hex(RegValue.FirstByte))
                    For i = 0 To intValueBuffer - 2
                        rv.ValueData = rv.ValueData & " " &
Trim(Hex(RegValue.ByteBuffer(i)))
                    Next i
                Case Else
                    rv.ValueData = "Unsupported Data Type: " &
intDataType
            End Select
            intIndex = intIndex + 1
            Values.Add rv, rv.ValueName
            Set rv = Nothing
        End If
    Loop
End If
End Function
Property Let CurrentKey(strEnter As String)
On Error GoTo ErrorHandler
strCurrentKey = strEnter
GetKeyInformation
Exit Property

ErrorHandler:
issErrorHandler.Module = "Registry"
issErrorHandler.Procedure = "CurrentKey_Get"
issErrorHandler.ErrorNumber = Err.Number
issErrorHandler.ErrorDescription = Err.Description
issErrorHandler.RaiseError
Err.Clear
End Property
Property Get CurrentKey() As String
On Error GoTo ErrorHandler
CurrentKey = strCurrentKey
Exit Property

ErrorHandler:
issErrorHandler.Module = "Registry"
issErrorHandler.Procedure = "CurrentKey_Get"
issErrorHandler.ErrorNumber = Err.Number
issErrorHandler.ErrorDescription = Err.Description
issErrorHandler.RaiseError
Err.Clear
End Property
Property Get RootKey() As RegistryRoot
On Error GoTo ErrorHandler
RootKey = intCurrentRoot
Exit Property

ErrorHandler:
issErrorHandler.Module = "Registry"
issErrorHandler.Procedure = "RootKey_Get"
issErrorHandler.ErrorNumber = Err.Number
issErrorHandler.ErrorDescription = Err.Description
issErrorHandler.RaiseError
Err.Clear
End Property
Property Let RootKey(intEnter As RegistryRoot)
On Error GoTo ErrorHandler
intCurrentRoot = intEnter
GetKeyInformation
Exit Property

ErrorHandler:
issErrorHandler.Module = "Registry"
issErrorHandler.Procedure = "RootKey_Let"
issErrorHandler.ErrorNumber = Err.Number
issErrorHandler.ErrorDescription = Err.Description
issErrorHandler.RaiseError
Err.Clear
End Property
Property Get ValueCount() As Long
On Error GoTo ErrorHandler
ValueCount = Values.Count
Exit Property

ErrorHandler:
issErrorHandler.Module = "Registry"
issErrorHandler.Procedure = "ValueCount_Get"
issErrorHandler.ErrorNumber = Err.Number
issErrorHandler.ErrorDescription = Err.Description
issErrorHandler.RaiseError
Err.Clear
End Property
Property Get ValueByName(strName As String) As RegistryValue
On Error GoTo ErrorHandler
Set ValueByName = Values(strName)
Exit Property

ErrorHandler:
Dim rv As RegistryValue
Set rv = New RegistryValue
rv.ValueName = ""
rv.ValueData = ""
Set ValueByName = rv
Set rv = Nothing
Err.Clear
End Property
Property Get ValueInfo(intPos As Long) As RegistryValue
On Error GoTo ErrorHandler
Set ValueInfo = Values(intPos)
Exit Property

ErrorHandler:
issErrorHandler.Module = "Registry"
issErrorHandler.Procedure = "ValueInfo_Get"
issErrorHandler.ErrorNumber = Err.Number
issErrorHandler.ErrorDescription = Err.Description
issErrorHandler.RaiseError
Err.Clear
End Property
Property Get KeyCount() As Long
On Error GoTo ErrorHandler
KeyCount = Keys.Count
Exit Property

ErrorHandler:
issErrorHandler.Module = "Registry"
issErrorHandler.Procedure = "KeyCount_Get"
issErrorHandler.ErrorNumber = Err.Number
issErrorHandler.ErrorDescription = Err.Description
issErrorHandler.RaiseError
Err.Clear
End Property
Property Get KeyInfo(intPos As Long) As RegistryKey
On Error GoTo ErrorHandler
Set KeyInfo = Keys(intPos)
Exit Property

ErrorHandler:
issErrorHandler.Module = "Registry"
issErrorHandler.Procedure = "KeyInfo_Get"
issErrorHandler.ErrorNumber = Err.Number
issErrorHandler.ErrorDescription = Err.Description
issErrorHandler.RaiseError
Err.Clear
End Property

Drew




-----Original Message-----
From: dba-vb-bounces at databaseadvisors.com
[mailto:dba-vb-bounces at databaseadvisors.com] On Behalf Of JWColby
Sent: Thursday, March 22, 2007 8:59 AM
To: 'Access Developers discussion and problem solving';
dba-vb at databaseadvisors.com
Subject: [dba-VB] Obtaining IP Address

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
 
_______________________________________________
dba-VB mailing list
dba-VB at databaseadvisors.com
http://databaseadvisors.com/mailman/listinfo/dba-vb
http://www.databaseadvisors.com




More information about the dba-VB mailing list