Add the following constants, declarations, and the two public functions to a standard module in your project:
'API Function and Constant Declarations
Public Const REG_NONE = 0 'No value type
Public Const REG_SZ = 1 'Unicode null terminated string
Public Const REG_EXPAND_SZ = 2 'Unicode null terminated string
Public Const REG_BINARY = 3 'Free form binary
Public Const REG_DWORD = 4 '32-bit number
Public Const REG_DWORD_LITTLE_ENDIAN = 4 '(same as REG_DWORD)
Public Const REG_DWORD_BIG_ENDIAN = 5 '32-bit number
Public Const REG_LINK = 6 'Symbolic Link (unicode)
Public Const REG_MULTI_SZ = 7 'Multiple Unicode strings
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 HKEY_CURRENT_CONFIG = &H80000005
Public Const ERROR_SUCCESS = 0
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_INVALID_PARAMETER = 7
Public Const ERROR_ACCESS_DENIED = 8
Public Const ERROR_INVALID_PARAMETERS = 87
Public Const ERROR_NO_MORE_ITEMS = 259
Public Const KEY_ALL_ACCESS = &H3F
Public Const REG_OPTION_NON_VOLATILE = 0
Private Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" _
Alias "RegOpenKeyA" (ByVal hKey As Long, _
ByVal lpSubKey As String, _
phkResult As Long) As Long
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 RegQueryValue Lib "advapi32.dll" _
Alias "RegQueryValueA" _
(ByVal hKey As Long, _
ByVal lpSubKey As String, _
ByVal lpValue As String, _
lpcbValue As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" _
Alias "RegQueryValueExA" _
(ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal lpReserved As Long, _
lpType As Long, _
lpData As Any, _
lpcbData As Long) As Long
Private Declare Function RegSetValue Lib "advapi32.dll" _
Alias "RegSetValueA" _
(ByVal hKey As Long, _
ByVal lpSubKey As String, _
ByVal dwType As Long, _
ByVal lpData As String, _
ByVal cbData As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" _
Alias "RegSetValueExA" _
(ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal Reserved As Long, _
ByVal dwType As Long, _
lpData As Any, _
ByVal cbData As Long) As Long 'GetRemoteServer function
Public Function GetRemoteServer(ClassName As String) As String
Dim lRetVal As Long 'result of the API functions
Dim hKey As Long 'handle of opened key
Dim sKeyName As String
Dim lpType As Long
Dim lpData As String
Dim lpcbData As Long
Dim myclsid As String
Dim MyServerName As String
sKeyName = ClassName
If sKeyName = "" Then
MsgBox "This is not a valid class name"
GetRemoteServer = "None"
Exit Function
End If
lRetVal = RegOpenKey(HKEY_CLASSES_ROOT, sKeyName, hKey)
If lRetVal = ERROR_SUCCESS Then
lpcbData = 40
lpData = Space$(40)
lRetVal = RegQueryValue(hKey, "CLSID", lpData, lpcbData)
If lRetVal = ERROR_NONE Then
myclsid = Left$(lpData, lpcbData - 1)
RegCloseKey (hKey)
sKeyName = "AppID\" & myclsid
lRetVal = RegOpenKeyEx(HKEY_CLASSES_ROOT, sKeyName, 0, _
KEY_ALL_ACCESS, hKey)
If lRetVal = ERROR_SUCCESS Then
lpcbData = 255
lpData = Space$(255)
lRetVal = RegQueryValueEx(ByVal hKey, "RemoteServerName", 0, _
ByVal lpType, ByVal lpData, lpcbData)
If lRetVal = ERROR_NONE Then
MyServerName = Left$(lpData, lpcbData - 1)
GetRemoteServer = MyServerName
Else
MsgBox lRetVal & " - This class is not registered remotely."
GetRemoteServer = "None"
End If
Else
MsgBox lRetVal & " - Cannot find CLSID for " & sKeyName
GetRemoteServer = "None"
End If
RegCloseKey (hKey)
End If
Else
MsgBox lRetVal & " - Cannot find class name - " & sKeyName
GetRemoteServer = "None"
End If
Exit Function
QueryValueExExit:
MsgBox lRetVal
GetRemoteServer = "None"
Exit Function
QueryValueExError:
Resume QueryValueExExit
End Function 'SetRemoteServer function
Public Function SetRemoteServer(ClassName As String, _
NewRemote As String) As String
Dim lRetVal As Long 'result of the API functions
Dim hKey As Long 'handle of opened key
Dim sKeyName As String
Dim lpType As Long
Dim lpData As String
Dim lpcbData As Long
Dim myclsid As String
Dim MyServerName As String
If NewRemote <> "" Then
MyServerName = NewRemote
sKeyName = ClassName
If sKeyName = "" Then
MsgBox "You did not enter a class name"
SetRemoteServer = "None"
Exit Function
End If
lRetVal = RegOpenKey(HKEY_CLASSES_ROOT, sKeyName, hKey)
If lRetVal = ERROR_SUCCESS Then
lpcbData = 40
lpData = Space$(40)
lRetVal = RegQueryValue(hKey, "CLSID", lpData, lpcbData)
If lRetVal = ERROR_NONE Then
myclsid = Left$(lpData, lpcbData - 1)
RegCloseKey (hKey)
sKeyName = "AppID\" & myclsid
lRetVal = RegOpenKeyEx(HKEY_CLASSES_ROOT, sKeyName, 0&, _
KEY_ALL_ACCESS, hKey)
If lRetVal = ERROR_SUCCESS Then
lpcbData = Len(MyServerName) + 1
lpData = MyServerName
lpType = REG_SZ
lRetVal = RegSetValueEx(hKey, "RemoteServerName", 0&, lpType, _
ByVal lpData, lpcbData)
If lRetVal = ERROR_NONE Then
SetRemoteServer = MyServerName
Else
MsgBox lRetVal & " - This class is not registered remotely."
SetRemoteServer = "None"
End If
Else
MsgBox lRetVal & " - Cannot find CLSID for " & sKeyName
SetRemoteServer = "None"
End If
RegCloseKey (hKey)
End If
Else
MsgBox lRetVal & " - Cannot find class name - " & sKeyName
SetRemoteServer = "None"
End If
Else
MsgBox "Invalid Parameter - NewRemote"
SetRemoteServer = "None"
End If
Exit Function
QueryValueExExit:
MsgBox lRetVal
SetRemoteServer = "None"
Exit Function
QueryValueExError:
Resume QueryValueExExit
End FunctionYou can now call these functions from anywhere in your project.
NOTE: The server object must be declared using late binding:
Private MyServer as Object
Set MyServer = CreateObject("YourServer.YourClass")GetRemoteServer Function
You can call this function at anytime to retrieve the current remote machine name that a remotely-registered class is setup to use. Pass the object.classname to the function and its return value will be either the RemoteMachineName or "None" if there was an error. For example:
Dim ClassName as String
Dim MachineName as String ClassName = "YourServer.YourClass" 'The name of your object
MachineName = GetRemoteServer(ClassName)
If MachineName = "None" Then
MsgBox "Error retrieving machine name"
Else
MsgBox "The machine name is " & MachineName
End IfSetRemoteServer Function
NOTE: It is recommended that you set any current references to this object to "Nothing" before changing the server location via this function. To change the remote machine that your server will run on, pass the object.classname and the new remote machine name to this method. The return value will be either the New remote machine name or "None" if there was an error. The next CreateObject that is called for this object will then use the new server location. For example:
dim MyServer as Object
dim ClassName as String
dim MachineName as String
dim NewMachine as String Set MyServer = Nothing 'Clear existing reference
ClassName = "YourServer.YourClass" 'The name of your object
NewMachine = "MachineToChangeTo" 'The name of the new machine
MachineName = SetRemoteServer(ClassName, NewMachine)
If MachineName = NewMachine Then
Set MyServer = CreateObject(ClassName) 'connect to the new machine
Else
MsgBox "Error Setting machine name"
End If
'API Function and Constant Declarations
Public Const REG_NONE = 0 'No value type
Public Const REG_SZ = 1 'Unicode null terminated string
Public Const REG_EXPAND_SZ = 2 'Unicode null terminated string
Public Const REG_BINARY = 3 'Free form binary
Public Const REG_DWORD = 4 '32-bit number
Public Const REG_DWORD_LITTLE_ENDIAN = 4 '(same as REG_DWORD)
Public Const REG_DWORD_BIG_ENDIAN = 5 '32-bit number
Public Const REG_LINK = 6 'Symbolic Link (unicode)
Public Const REG_MULTI_SZ = 7 'Multiple Unicode strings
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 HKEY_CURRENT_CONFIG = &H80000005
Public Const ERROR_SUCCESS = 0
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_INVALID_PARAMETER = 7
Public Const ERROR_ACCESS_DENIED = 8
Public Const ERROR_INVALID_PARAMETERS = 87
Public Const ERROR_NO_MORE_ITEMS = 259
Public Const KEY_ALL_ACCESS = &H3F
Public Const REG_OPTION_NON_VOLATILE = 0
Private Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" _
Alias "RegOpenKeyA" (ByVal hKey As Long, _
ByVal lpSubKey As String, _
phkResult As Long) As Long
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 RegQueryValue Lib "advapi32.dll" _
Alias "RegQueryValueA" _
(ByVal hKey As Long, _
ByVal lpSubKey As String, _
ByVal lpValue As String, _
lpcbValue As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" _
Alias "RegQueryValueExA" _
(ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal lpReserved As Long, _
lpType As Long, _
lpData As Any, _
lpcbData As Long) As Long
Private Declare Function RegSetValue Lib "advapi32.dll" _
Alias "RegSetValueA" _
(ByVal hKey As Long, _
ByVal lpSubKey As String, _
ByVal dwType As Long, _
ByVal lpData As String, _
ByVal cbData As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" _
Alias "RegSetValueExA" _
(ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal Reserved As Long, _
ByVal dwType As Long, _
lpData As Any, _
ByVal cbData As Long) As Long 'GetRemoteServer function
Public Function GetRemoteServer(ClassName As String) As String
Dim lRetVal As Long 'result of the API functions
Dim hKey As Long 'handle of opened key
Dim sKeyName As String
Dim lpType As Long
Dim lpData As String
Dim lpcbData As Long
Dim myclsid As String
Dim MyServerName As String
sKeyName = ClassName
If sKeyName = "" Then
MsgBox "This is not a valid class name"
GetRemoteServer = "None"
Exit Function
End If
lRetVal = RegOpenKey(HKEY_CLASSES_ROOT, sKeyName, hKey)
If lRetVal = ERROR_SUCCESS Then
lpcbData = 40
lpData = Space$(40)
lRetVal = RegQueryValue(hKey, "CLSID", lpData, lpcbData)
If lRetVal = ERROR_NONE Then
myclsid = Left$(lpData, lpcbData - 1)
RegCloseKey (hKey)
sKeyName = "AppID\" & myclsid
lRetVal = RegOpenKeyEx(HKEY_CLASSES_ROOT, sKeyName, 0, _
KEY_ALL_ACCESS, hKey)
If lRetVal = ERROR_SUCCESS Then
lpcbData = 255
lpData = Space$(255)
lRetVal = RegQueryValueEx(ByVal hKey, "RemoteServerName", 0, _
ByVal lpType, ByVal lpData, lpcbData)
If lRetVal = ERROR_NONE Then
MyServerName = Left$(lpData, lpcbData - 1)
GetRemoteServer = MyServerName
Else
MsgBox lRetVal & " - This class is not registered remotely."
GetRemoteServer = "None"
End If
Else
MsgBox lRetVal & " - Cannot find CLSID for " & sKeyName
GetRemoteServer = "None"
End If
RegCloseKey (hKey)
End If
Else
MsgBox lRetVal & " - Cannot find class name - " & sKeyName
GetRemoteServer = "None"
End If
Exit Function
QueryValueExExit:
MsgBox lRetVal
GetRemoteServer = "None"
Exit Function
QueryValueExError:
Resume QueryValueExExit
End Function 'SetRemoteServer function
Public Function SetRemoteServer(ClassName As String, _
NewRemote As String) As String
Dim lRetVal As Long 'result of the API functions
Dim hKey As Long 'handle of opened key
Dim sKeyName As String
Dim lpType As Long
Dim lpData As String
Dim lpcbData As Long
Dim myclsid As String
Dim MyServerName As String
If NewRemote <> "" Then
MyServerName = NewRemote
sKeyName = ClassName
If sKeyName = "" Then
MsgBox "You did not enter a class name"
SetRemoteServer = "None"
Exit Function
End If
lRetVal = RegOpenKey(HKEY_CLASSES_ROOT, sKeyName, hKey)
If lRetVal = ERROR_SUCCESS Then
lpcbData = 40
lpData = Space$(40)
lRetVal = RegQueryValue(hKey, "CLSID", lpData, lpcbData)
If lRetVal = ERROR_NONE Then
myclsid = Left$(lpData, lpcbData - 1)
RegCloseKey (hKey)
sKeyName = "AppID\" & myclsid
lRetVal = RegOpenKeyEx(HKEY_CLASSES_ROOT, sKeyName, 0&, _
KEY_ALL_ACCESS, hKey)
If lRetVal = ERROR_SUCCESS Then
lpcbData = Len(MyServerName) + 1
lpData = MyServerName
lpType = REG_SZ
lRetVal = RegSetValueEx(hKey, "RemoteServerName", 0&, lpType, _
ByVal lpData, lpcbData)
If lRetVal = ERROR_NONE Then
SetRemoteServer = MyServerName
Else
MsgBox lRetVal & " - This class is not registered remotely."
SetRemoteServer = "None"
End If
Else
MsgBox lRetVal & " - Cannot find CLSID for " & sKeyName
SetRemoteServer = "None"
End If
RegCloseKey (hKey)
End If
Else
MsgBox lRetVal & " - Cannot find class name - " & sKeyName
SetRemoteServer = "None"
End If
Else
MsgBox "Invalid Parameter - NewRemote"
SetRemoteServer = "None"
End If
Exit Function
QueryValueExExit:
MsgBox lRetVal
SetRemoteServer = "None"
Exit Function
QueryValueExError:
Resume QueryValueExExit
End FunctionYou can now call these functions from anywhere in your project.
NOTE: The server object must be declared using late binding:
Private MyServer as Object
Set MyServer = CreateObject("YourServer.YourClass")GetRemoteServer Function
You can call this function at anytime to retrieve the current remote machine name that a remotely-registered class is setup to use. Pass the object.classname to the function and its return value will be either the RemoteMachineName or "None" if there was an error. For example:
Dim ClassName as String
Dim MachineName as String ClassName = "YourServer.YourClass" 'The name of your object
MachineName = GetRemoteServer(ClassName)
If MachineName = "None" Then
MsgBox "Error retrieving machine name"
Else
MsgBox "The machine name is " & MachineName
End IfSetRemoteServer Function
NOTE: It is recommended that you set any current references to this object to "Nothing" before changing the server location via this function. To change the remote machine that your server will run on, pass the object.classname and the new remote machine name to this method. The return value will be either the New remote machine name or "None" if there was an error. The next CreateObject that is called for this object will then use the new server location. For example:
dim MyServer as Object
dim ClassName as String
dim MachineName as String
dim NewMachine as String Set MyServer = Nothing 'Clear existing reference
ClassName = "YourServer.YourClass" 'The name of your object
NewMachine = "MachineToChangeTo" 'The name of the new machine
MachineName = SetRemoteServer(ClassName, NewMachine)
If MachineName = NewMachine Then
Set MyServer = CreateObject(ClassName) 'connect to the new machine
Else
MsgBox "Error Setting machine name"
End If
RegConnectRegistry
The RegConnectRegistry function establishes a connection to a predefined registry handle on another computer. LONG RegConnectRegistry(
LPTSTR lpMachineName,
// address of name of remote computer
HKEY hKey, // predefined registry handle
PHKEY phkResult // address of buffer for remote registry handle
);
Parameters
lpMachineName
Pointer to a null-terminated string containing the name of the remote computer. The string has the following form:
\\computername If lpMachineName is NULL, the local computer name is used. hKey
Specifies the one of the following predefined registry handles on the remote computer.
HKEY_LOCAL_MACHINE
HKEY_USERS
Windows NT: HKEY_PERFORMANCE_DATA, if the remote computer is running Windows NT
Windows 95 and Windows 98: HKEY_DYN_DATA, if the remote computer is running Windows 95 or Windows 98
Windows 95 and Windows 98: HKEY_CURRENT_CONFIG, if the remote computer is running Windows 95 or Windows 98 You cannot specify the HKEY_CLASSES_ROOT or HKEY_CURRENT_USER value for this parameter. phkResult
Pointer to a variable that receives a key handle identifying the predefined handle on the remote computer.
Return Values
If the function succeeds, the return value is ERROR_SUCCESS.If the function fails, the return value is a nonzero error code defined in WINERROR.H. You can use the FormatMessage function with the FORMAT_MESSAGE_FROM_SYSTEM flag to get a generic description of the error.Res
When a handle returned by RegConnectRegistry is no longer needed, it should be closed by calling RegCloseKey. QuickInfo
Windows NT: Requires version 3.1 or later.
Windows: Requires Windows 95 or later.
Windows CE: Unsupported.
Header: Declared in winreg.h.
Import Library: Use advapi32.lib.
Unicode: Implemented as Unicode and ANSI versions on Windows NT.See Also
Registry Overview, Registry Functions, RegCloseKey