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