Check Proxy server + can I do this?

swaink

swaink

Active Member
Joined
Feb 15, 2002
Messages
432
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
 

Excel Facts

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.
Sort by date Sort by votes
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.. :-)
 
Upvote 0
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?
 
Upvote 0
Okay, here we go...

Create three new general code modules and paste the following code into them:-
Code: 
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]
'
'----------------------------------------------------------------------------------------------

Code: 
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]
'
'----------------------------------------------------------------------------------------------

Code: 
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:-
Code: 
Option Explicit
 
Public Sub Demo()
 
  Const sKey As String = "Software\Microsoft\Windows\CurrentVersion\Internet Settings"
 
  MsgBox QueryValue(sKey, HKEY_CURRENT_USER, "ProxyServer")
 
End Sub
 
Last edited:
Upvote 0
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
 
Upvote 0
swaink said:
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
Click to expand...

This is really handy code

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

Works perfectly

Thanks all
 
Upvote 0
You must log in or register to reply here.

Similar threads

O
  • Question Question
Frustrating intermittent VBA error dialog telling me that "User-define Type Not Defined"
Replies
1
Views
257
Micron
M
D
  • Question Question
VBA to Create Outlook Email Not Working for All Users
Replies
9
Views
359
Logit
Logit
rjplante
  • Solved
Change from Set as Default to Set as Active printer
Replies
1
Views
679
NdNoviceHlp
NdNoviceHlp
D
  • Solved
Providing message if red coloured cells found in specific columns
2
Replies
10
Views
967
NdNoviceHlp
NdNoviceHlp
S
  • Question Question
Using VBA to Flag and Calculate Overlapping Shift Times
Replies
0
Views
475
Snort
S

Forum statistics

Threads
1,224,599
Messages
6,179,828
Members
452,946
Latest member
JoseDavid

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top