DOCUMENT:Q179615  21-JAN-1998  [vbwin]
TITLE   :HOWTO: Specify or Change a Remote Server's Location at Run-time
PRODUCT :Microsoft Visual Basic for Windows
PROD/VER:WINDOWS:5.0
OPER/SYS:NT WINDOWS
KEYWORDS:vb5all vb5howto

======================================================================
---------------------------------------------------------------------
The information in this article applies to:

 - Microsoft Visual Basic Learning, Professional, and Enterprise Editions
   for Windows, version 5.0
   on the following platform: NT
---------------------------------------------------------------------

SUMMARY
=======

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.

MORE INFORMATION
================

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

You 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 If

SetRemoteServer 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

NOTE: The Remote ActiveX Server applications must be set up and functioning
correctly for the code above to work properly.

Additional query words: DCOM RemoteServerName DCOMCNFG OLEView
======================================================================
Keywords          : vb5all vb5howto
Version           : WINDOWS:5.0
Platform          : NT WINDOWS
Issue type        : kbhowto

=============================================================================

THE INFORMATION PROVIDED IN THE MICROSOFT KNOWLEDGE BASE IS
PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND.  MICROSOFT DISCLAIMS
ALL WARRANTIES, EITHER EXPRESS OR IMPLIED, INCLUDING THE WARRANTIES
OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  IN NO
EVENT SHALL MICROSOFT CORPORATION OR ITS SUPPLIERS BE LIABLE FOR
ANY DAMAGES WHATSOEVER INCLUDING DIRECT, INDIRECT, INCIDENTAL,
CONSEQUENTIAL, LOSS OF BUSINESS PROFITS OR SPECIAL DAMAGES, EVEN IF
MICROSOFT CORPORATION OR ITS SUPPLIERS HAVE BEEN ADVISED OF THE
POSSIBILITY OF SUCH DAMAGES.  SOME STATES DO NOT ALLOW THE EXCLUSION
OR LIMITATION OF LIABILITY FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES
SO THE FOREGOING LIMITATION MAY NOT APPLY.

Copyright Microsoft Corporation 1998.