HOWTO: Specify or Change a Remote Server's Location at Run- TimeID: Q179615
|
This article demonstrates how to programmatically change a remote DCOM
server's actual machine location. This change enables a remote client to be
directed to any machine that has the server component installed without the
need to restart the client or register the new server object. This is
accomplished by using the WIN32 API to make modifications to the registry.
The sample below provides two functions that wrap the needed API calls
cleanly: SetRemoteServer and GetRemoteServer.
NOTE: Late binding must be used to accomplish this behavior at run-time.
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 Function
Private MyServer as Object
Set MyServer = CreateObject("YourServer.YourClass")
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 If
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
Additional query words:
DCOM RemoteServerName DCOMCNFG OLEView kbVBp500 kbVBp600 kbCOM
kbdse kbDSupport kbVBp
Keywords :
Version :
Platform : NT WINDOWS
Issue type : kbhowto
Last Reviewed: May 26, 1999