Check Proxy server + can I do this?

[swaink]

Hi All

This is a new area for me so I would really appreciate any guidance please.

I have a workbook in which the code retrieves data from a public web page.

I intend to use some of my team to test the final result but I need to control it's release.

The tool does exactly what it is supposed to do, but for the purpose of testing I want to restrict the users to only those people who are employed staff initially.

In order to acheive this I would like to have the code check for the proxy server settings if they match what is expected then the tool will continue and do its work, however if the proxy setting don't match then produce a msgbox indicating the error. The error box I can do but checking the proxy settings is one step too far

All advice appreciated

Regards

Kevin

 

[tony.reynolds]

I have a very simalar scenario where i have worked on a houshold budget and money tracker for a few years releasing new versions to members of my faimly. But i dont want it to get outside the family
I have a userform that opens on workbook open event and users have to enter a licence key to activate their copy.
then to protect the code (holds the keys) ive protected the VBA project.
If they close the Userform the workbook closes.

I would also love to have my workbook check a server somehow for activation and alert me of the activation via email..

 

[Ruddles]

If you can locate the registry key which holds the information you need, it's not too difficult to extract the value of the key and check it.

Is that any help?

 

[Ruddles]

Okay, here we go...

Create three new general code modules and paste the following code into them:-

Option Explicit
 
Public Const REG_SZ As Long = 1
Public Const REG_DWORD As Long = 4
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
Public Const ERROR_NONE = 0
Public Const ERROR_BADDB = 1
Public Const ERROR_BADKEY = 2
Public Const ERROR_CANTOPEN = 3
Public Const ERROR_CANTREAD = 4
Public Const ERROR_CANTWRITE = 5
Public Const ERROR_OUTOFMEMORY = 6
Public Const ERROR_ARENA_TRASHED = 7
Public Const ERROR_ACCESS_DENIED = 8
Public Const ERROR_INVALID_PARAMETERS = 87
Public Const ERROR_NO_MORE_ITEMS = 259
Public Const KEY_QUERY_VALUE = &H1
Public Const KEY_SET_VALUE = &H2
Public Const KEY_ALL_ACCESS = &H3F
Public Const REG_OPTION_NON_VOLATILE = 0
'----------------------------------------------------------------------------------------------
'
' Acknowledgements
'
' [URL]http://support.microsoft.com/kb/145679[/URL]
'
' Kenneth Ives ([EMAIL="kenaso@home.com"]kenaso@home.com[/EMAIL])
' [URL]http://www.programmersheaven.com/mb/vba/371593/371593/change-registry-settings-in-vba/[/URL]
'
'----------------------------------------------------------------------------------------------

Option Explicit
 
Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Declare Function RegCreateKeyEx Lib "advapi32.dll" _
   Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, ByVal lpSecurityAttributes As Long, phkResult As Long, lpdwDisposition As Long) As Long
 
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
Declare Function RegQueryValueExString Lib "advapi32.dll" _
   Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
Declare Function RegQueryValueExLong Lib "advapi32.dll" _
   Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Long, lpcbData As Long) As Long
Declare Function RegQueryValueExNULL Lib "advapi32.dll" _
   Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As Long, lpcbData As Long) As Long
Declare Function RegSetValueExString Lib "advapi32.dll" _
   Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As String, ByVal cbData As Long) As Long
Declare Function RegSetValueExLong Lib "advapi32.dll" _
   Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, ByVal cbData As Long) As Long
Declare Function RegDeleteKey Lib "advapi32.dll" _
   Alias "RegDeleteKeyA" (ByVal lngRootKey As Long, ByVal lpSubKey As String) As Long
Declare Function RegOpenKey Lib "advapi32.dll" _
   Alias "RegOpenKeyA" (ByVal lngRootKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Declare Function RegDeleteValue Lib "advapi32.dll" _
   Alias "RegDeleteValueA" (ByVal lngRootKey As Long, ByVal lpValueName As String) As Long
'----------------------------------------------------------------------------------------------
'
' Acknowledgements
'
' [URL]http://support.microsoft.com/kb/145679[/URL]
'
' Kenneth Ives ([EMAIL="kenaso@home.com"]kenaso@home.com[/EMAIL])
' [URL]http://www.programmersheaven.com/mb/vba/371593/371593/change-registry-settings-in-vba/[/URL]
'
'----------------------------------------------------------------------------------------------

Option Explicit
 
Public Sub DeleteSubKey(sKeyName As String, lPredefinedKey As Long, sValueName As String)
 
  Dim hKey As Long
  Dim lRetCode As Long
 
  lRetCode = RegOpenKey(lPredefinedKey, sKeyName, hKey)
  lRetCode = RegDeleteValue(hKey, sValueName)
 
  RegCloseKey (hKey)
 
End Sub
 
Public Sub DeleteKey(sKeyName As String, lPredefinedKey As Long, ByVal sValueName As String)
 
  Dim hKey As Long
  Dim lRetCode As Long
 
  lRetCode = RegOpenKey(lPredefinedKey, sKeyName, hKey)
  lRetCode = RegDeleteKey(hKey, sValueName)
 
  RegCloseKey (hKey)
 
End Sub
 
Public Sub CreateNewKey(sNewKeyName As String, lPredefinedKey As Long)
 
  Dim hNewKey As Long
  Dim lRetCode As Long
  lRetCode = RegCreateKeyEx(lPredefinedKey, sNewKeyName, 0&, vbNullString, _
            REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hNewKey, lRetCode)
 
  RegCloseKey (hNewKey)
 
End Sub
 
Public Sub SetKeyValue(sKeyName As String, lPredefinedKey As Long, sValueName As String, _
  vValueSetting As Variant, lValueType As Long)
 
  Dim hKey As Long
  Dim lRetCode As Long
  lRetCode = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_SET_VALUE, hKey)
  lRetCode = SetValueEx(hKey, sValueName, lValueType, vValueSetting)
 
  RegCloseKey (hKey)
 
End Sub
 
Public Function QueryValue(sKeyName As String, lPredefinedKey As Long, sValueName As String) As Variant
 
  Dim hKey As Long
  Dim lRetCode As Long
  Dim vValue As Variant
  lRetCode = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_QUERY_VALUE, hKey)
  lRetCode = QueryValueEx(hKey, sValueName, vValue)
 
  QueryValue = vValue
 
  RegCloseKey (hKey)
 
End Function
 
Public Function SetValueEx(ByVal hKey As Long, sValueName As String, lType As Long, _
  vValue As Variant) As Long
 
  Dim lValue As Long
  Dim sValue As String
 
  Select Case lType
    Case REG_SZ
      sValue = vValue & Chr$(0)
      SetValueEx = RegSetValueExString(hKey, sValueName, 0&, lType, sValue, Len(sValue))
    Case REG_DWORD
      lValue = vValue
      SetValueEx = RegSetValueExLong(hKey, sValueName, 0&, lType, lValue, 4)
  End Select
 
End Function
 
Public Function QueryValueEx(ByVal lhKey As Long, ByVal szValueName As String, vValue As Variant) As Long
 
  Dim cch As Long
  Dim lrc As Long
  Dim lType As Long
  Dim lValue As Long
  Dim sValue As String
  On Error GoTo QueryValueExError
  ' determine the size and type of data to be read
  lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
  If lrc <> ERROR_NONE Then Error 5
  Select Case lType
    ' for strings
    Case REG_SZ
      sValue = String(cch, 0)
      lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, sValue, cch)
      If lrc = ERROR_NONE Then
        vValue = Left$(sValue, cch - 1)
      Else
        vValue = Empty
      End If
    ' for DWORDS
    Case REG_DWORD
      lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, lValue, cch)
      If lrc = ERROR_NONE Then vValue = lValue
    Case Else
      ' all other data types not supported
      lrc = -1
  End Select
QueryValueExExit:
  QueryValueEx = lrc
  Exit Function
QueryValueExError:
  Resume QueryValueExExit
 
End Function

Now one final general code module containing this code to demonstrate how to read the value of a registry key:-

Option Explicit
 
Public Sub Demo()
 
  Const sKey As String = "Software\Microsoft\Windows\CurrentVersion\Internet Settings"
 
  MsgBox QueryValue(sKey, HKEY_CURRENT_USER, "ProxyServer")
 
End Sub

 

[swaink]

Hi Both

Ruddles this works for me really well and i'm sure Tony will be pleased too

Thank you for your time

it has been appreciated

Kevin

 

[Ruddles]

I'm glad you got it working fairly painlessly!

http://www.mrexcel.com/forum/showthread.php?t=550350&nojs=1#goto_threadtools

 

[swaink]

Hi Ruddles

No pain at all it, I followed your guidance and it worked great

Kev

 

[tony.reynolds]

Hi Both

Ruddles this works for me really well and i'm sure Tony will be pleased too

Thank you for your time

it has been appreciated

Kevin

This is really handy code

I have allowed only those with the right machine serial number .

Works perfectly

Thanks all

 

[Ruddles]

http://www.mrexcel.com/forum/showthread.php?t=550350&nojs=1#goto_threadrating