[dba-VB] Obtaining IP Address

JWColby jwcolby at colbyconsulting.com
Thu Mar 22 10:13:34 CDT 2007


Muchas gracias.

John W. Colby
Colby Consulting
www.ColbyConsulting.com

-----Original Message-----
From: dba-vb-bounces at databaseadvisors.com
[mailto:dba-vb-bounces at databaseadvisors.com] On Behalf Of Drew Wutka
Sent: Thursday, March 22, 2007 10:46 AM
To: dba-vb at databaseadvisors.com
Subject: Re: [dba-VB] Obtaining IP Address

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

_______________________________________________
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