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