From jwcolby at colbyconsulting.com Thu Mar 22 08:59:18 2007 From: jwcolby at colbyconsulting.com (JWColby) Date: Thu, 22 Mar 2007 09:59:18 -0400 Subject: [dba-VB] Obtaining IP Address Message-ID: <003001c76c8a$498ccf40$657aa8c0@m6805> 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 From DWUTKA at Marlow.com Thu Mar 22 09:46:03 2007 From: DWUTKA at Marlow.com (Drew Wutka) Date: Thu, 22 Mar 2007 09:46:03 -0500 Subject: [dba-VB] Obtaining IP Address In-Reply-To: <003001c76c8a$498ccf40$657aa8c0@m6805> Message-ID: 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 From jwcolby at colbyconsulting.com Thu Mar 22 10:13:34 2007 From: jwcolby at colbyconsulting.com (JWColby) Date: Thu, 22 Mar 2007 11:13:34 -0400 Subject: [dba-VB] Obtaining IP Address In-Reply-To: References: <003001c76c8a$498ccf40$657aa8c0@m6805> Message-ID: <004301c76c94$a921e940$657aa8c0@m6805> 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 From DWUTKA at Marlow.com Thu Mar 22 10:17:17 2007 From: DWUTKA at Marlow.com (Drew Wutka) Date: Thu, 22 Mar 2007 10:17:17 -0500 Subject: [dba-VB] Obtaining IP Address In-Reply-To: <004301c76c94$a921e940$657aa8c0@m6805> Message-ID: Denada (sp?) ;) 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 10:14 AM To: dba-vb at databaseadvisors.com Subject: Re: [dba-VB] Obtaining IP Address 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 _______________________________________________ dba-VB mailing list dba-VB at databaseadvisors.com http://databaseadvisors.com/mailman/listinfo/dba-vb http://www.databaseadvisors.com From jwcolby at colbyconsulting.com Thu Mar 22 08:59:18 2007 From: jwcolby at colbyconsulting.com (JWColby) Date: Thu, 22 Mar 2007 09:59:18 -0400 Subject: [dba-VB] Obtaining IP Address Message-ID: <003001c76c8a$498ccf40$657aa8c0@m6805> 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 From DWUTKA at Marlow.com Thu Mar 22 09:46:03 2007 From: DWUTKA at Marlow.com (Drew Wutka) Date: Thu, 22 Mar 2007 09:46:03 -0500 Subject: [dba-VB] Obtaining IP Address In-Reply-To: <003001c76c8a$498ccf40$657aa8c0@m6805> Message-ID: 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 From jwcolby at colbyconsulting.com Thu Mar 22 10:13:34 2007 From: jwcolby at colbyconsulting.com (JWColby) Date: Thu, 22 Mar 2007 11:13:34 -0400 Subject: [dba-VB] Obtaining IP Address In-Reply-To: References: <003001c76c8a$498ccf40$657aa8c0@m6805> Message-ID: <004301c76c94$a921e940$657aa8c0@m6805> 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 From DWUTKA at Marlow.com Thu Mar 22 10:17:17 2007 From: DWUTKA at Marlow.com (Drew Wutka) Date: Thu, 22 Mar 2007 10:17:17 -0500 Subject: [dba-VB] Obtaining IP Address In-Reply-To: <004301c76c94$a921e940$657aa8c0@m6805> Message-ID: Denada (sp?) ;) 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 10:14 AM To: dba-vb at databaseadvisors.com Subject: Re: [dba-VB] Obtaining IP Address 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 _______________________________________________ dba-VB mailing list dba-VB at databaseadvisors.com http://databaseadvisors.com/mailman/listinfo/dba-vb http://www.databaseadvisors.com From jwcolby at colbyconsulting.com Thu Mar 22 08:59:18 2007 From: jwcolby at colbyconsulting.com (JWColby) Date: Thu, 22 Mar 2007 09:59:18 -0400 Subject: [dba-VB] Obtaining IP Address Message-ID: <003001c76c8a$498ccf40$657aa8c0@m6805> 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 From DWUTKA at Marlow.com Thu Mar 22 09:46:03 2007 From: DWUTKA at Marlow.com (Drew Wutka) Date: Thu, 22 Mar 2007 09:46:03 -0500 Subject: [dba-VB] Obtaining IP Address In-Reply-To: <003001c76c8a$498ccf40$657aa8c0@m6805> Message-ID: 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 From jwcolby at colbyconsulting.com Thu Mar 22 10:13:34 2007 From: jwcolby at colbyconsulting.com (JWColby) Date: Thu, 22 Mar 2007 11:13:34 -0400 Subject: [dba-VB] Obtaining IP Address In-Reply-To: References: <003001c76c8a$498ccf40$657aa8c0@m6805> Message-ID: <004301c76c94$a921e940$657aa8c0@m6805> 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 From DWUTKA at Marlow.com Thu Mar 22 10:17:17 2007 From: DWUTKA at Marlow.com (Drew Wutka) Date: Thu, 22 Mar 2007 10:17:17 -0500 Subject: [dba-VB] Obtaining IP Address In-Reply-To: <004301c76c94$a921e940$657aa8c0@m6805> Message-ID: Denada (sp?) ;) 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 10:14 AM To: dba-vb at databaseadvisors.com Subject: Re: [dba-VB] Obtaining IP Address 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 _______________________________________________ dba-VB mailing list dba-VB at databaseadvisors.com http://databaseadvisors.com/mailman/listinfo/dba-vb http://www.databaseadvisors.com From jwcolby at colbyconsulting.com Thu Mar 22 08:59:18 2007 From: jwcolby at colbyconsulting.com (JWColby) Date: Thu, 22 Mar 2007 09:59:18 -0400 Subject: [dba-VB] Obtaining IP Address Message-ID: <003001c76c8a$498ccf40$657aa8c0@m6805> 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 From DWUTKA at Marlow.com Thu Mar 22 09:46:03 2007 From: DWUTKA at Marlow.com (Drew Wutka) Date: Thu, 22 Mar 2007 09:46:03 -0500 Subject: [dba-VB] Obtaining IP Address In-Reply-To: <003001c76c8a$498ccf40$657aa8c0@m6805> Message-ID: 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 From jwcolby at colbyconsulting.com Thu Mar 22 10:13:34 2007 From: jwcolby at colbyconsulting.com (JWColby) Date: Thu, 22 Mar 2007 11:13:34 -0400 Subject: [dba-VB] Obtaining IP Address In-Reply-To: References: <003001c76c8a$498ccf40$657aa8c0@m6805> Message-ID: <004301c76c94$a921e940$657aa8c0@m6805> 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 From DWUTKA at Marlow.com Thu Mar 22 10:17:17 2007 From: DWUTKA at Marlow.com (Drew Wutka) Date: Thu, 22 Mar 2007 10:17:17 -0500 Subject: [dba-VB] Obtaining IP Address In-Reply-To: <004301c76c94$a921e940$657aa8c0@m6805> Message-ID: Denada (sp?) ;) 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 10:14 AM To: dba-vb at databaseadvisors.com Subject: Re: [dba-VB] Obtaining IP Address 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 _______________________________________________ dba-VB mailing list dba-VB at databaseadvisors.com http://databaseadvisors.com/mailman/listinfo/dba-vb http://www.databaseadvisors.com