changecl.prg

MSComm控件资料,Visual Basic 6.0(以下简称VB) 是一种功能强大、简单易学的程序设计语言。它不但保留了原先Basic语言的全部功能

*--------------------------------------------------
*-- Example of a call to the Change Class Location program
*-- 
*--   =ChangeCL( "CBIZED.VCX", "CBIZCT.VCX" )
*--
*--   This example searches all class libraries that
*--   are a part of the project you point to 
*--   and changes the location of all classes that
*--   used CBIZED.VCX and points them to CBIZCT.VCX.
*--   It also recompiles all classes in a .VCX
*--   whose class location was modified.  Passing a 
*--   .T. in the third parameter ensures that the
*--   recompile step is skipped.
*--
*--   WARNING: 
*-- 
*--   This program assumes that the renamed class
*--   library is located in the exact same directory
*--   as it was in when it used its previous name.
*--   For example, if you renamed CBIZED.VCX
*--   to CBIZCT.VCX this program assumes that the
*--   newly named CBIZCT.VCX is located in the same
*--   directory where the CBIZED.VCX originally 
*--   resided.
*-- 
*-- CHANGE - PDH - August 02, 1998 - 17:00:56
*--	Updated to make sure projects are closed, if open,
*--	when SetIncl.Prg is run.  Also opens the project
*-- selected for updating.
*---------------------------------------------------
LPARAMETERS tcCurrentClassLibrary , ;
            tcNewClassLibrary     , ;
            tlSkipCompile         , ;
            lcOldSetProc 

lcOldSetProc = SET('PROCEDURE')
SET PROCEDURE TO setup.prg
SET PROCEDURE TO utility.prg ADDITIVE

IF PCOUNT() = 0
   =DoForm( 'frmChangeClassLibrary' )
ELSE
   =ChangeClassLibraryNames( tcCurrentClassLibrary, tcNewClassLibrary, tlSkipCompile )
ENDIF

*------------------------------------------
*-- Reset the environment to the way it was
*------------------------------------------
SET PROCEDURE TO &lcOldSetProc
   


*------------------------------------------------------------------------------------------
FUNCTION ChangeClassLibraryNames( tcCurrentClassLibrary, tcNewClassLibrary, tlSkipCompile )
*------------------------------------------------------------------------------------------

   LOCAL lcOriginalProject, ;
         lcProjectFileAlias, ;
         llRetVal

   lcProjectFileAlias = ""

   *--------------------------------------------
   *-- CHANGE - PDH - July 21, 1998 - 21:42:23
   *   Store the selected project to open after
   *   processing is complete...
   *--------------------------------------------
   lcOriginalProject  = ""

   *--------------------------------------------
   *-- CHANGE - PDH - August 02, 1998 - 16:51:59
   *    Initialize llRetVal...
   *-- CHANGE - CTB - Added authorization to 
   *--  continue method to ensure folks back
   *--  their stuff up first ... or lie about
   *--  doing it ... that way ... I'm off the 
   *--  hook <s>.
   *--------------------------------------------
   llRetVal = GetAuthorizationToContinue()
   

   *===========================================================================*
   *=====                     Main Program Processing                     =====*
   *===========================================================================*
   IF llRetVal
      CLOSE TABLES

      *--------------------------------------------
      *-- CHANGE - PDH - August 02, 1998 - 16:51:18
      *   Make sure ALL databases are closed...
      *CLOSE DATABASES
      *--------------------------------------------
      CLOSE DATABASES ALL

      llRetVal = llRetVal AND ;
                 ValidateCurrentClassLibrary( tcCurrentClassLibrary )

      llRetVal = llRetVal AND ;
                 ValidateNewClassLibrary( tcNewClassLibrary )

      llRetVal = llRetVal AND ;
                 GetProjectFile( @lcProjectFileAlias )

      llRetVal = llRetVal AND ;
                 GetClassLibraryNamesFromProject( lcProjectFileAlias )
                                                      
      llRetVal = llRetVal AND ;
                 MakeClassLibraryReplacements( tcCurrentClassLibrary , ;
                                               tcNewClassLibrary     , ;
                                               tlSkipCompile           )

      *--------------------------------------------
      *-- CHANGE - PDH - August 02, 1998 - 16:59:04
      *   Open the project that was updated...
      *--------------------------------------------
      IF !EMPTY( lcOriginalProject )
	     MODIFY PROJECT ( lcOriginalProject ) NOWAIT SAVE
      ENDIF

   ENDIF

   RETURN llRetVal

ENDFUNC

*===========================================================================*
*=====                 Program Processing Functions                    =====*
*===========================================================================*

*============================================
FUNCTION GetProjectFile( tcProjectFileAlias )
*============================================
   LOCAL llRetVal , ;
         lcProjectFile
   
   lcProjectFile = GETFILE( "PJX", "Project:" )

   IF .NOT. EMPTY( lcProjectFile ) AND ;
      FILE( lcProjectFile )
      llRetVal = .T.
   ELSE
      llRetVal = .F.
   ENDIF
   
   IF llRetVal
      *---------------------------------------------
      *--{CHANGE - PDH - August 02, 1998 - 16:52:44
   	  *   Save the selected project and open it
   	  *   after we're finished...
   	  *---------------------------------------------
	  lcOriginalProject = lcProjectFile

	  *-----------------------------------------------
	  *...and make sure it's closed before using it...
      *-----------------------------------------------
   	  CLOSE ALL
   	  *--}
   	  
      SELECT 0
      USE( lcProjectFile ) ALIAS project
   ENDIF
   
   IF USED( 'project')
      tcProjectFileAlias = "project"
   ELSE
      llRetVal = .F.
   ENDIF
   
   RETURN llRetVal    

ENDFUNC

*=========================================================
FUNCTION GetClassLibraryNamesFromProject( tcProjectAlias )
*=========================================================
   LOCAL llRetVal
   
   SELECT name FROM ( tcProjectAlias ) ;
    WHERE Type = "V"    ;
     INTO CURSOR crsVCX
     
  IF USED( 'crsVCX') AND RECCOUNT( 'crsVCX' ) > 0
     llRetVal = .T.
  ELSE
     llRetVal = .F.
  ENDIF
  
  IF USED( tcProjectAlias )
     USE IN ( tcProjectAlias )
  ENDIF
  
  RETURN llRetVal     
                
ENDFUNC


*============================================================
FUNCTION ValidateCurrentClassLibrary( tcCurrentClassLibrary )
*============================================================
   LOCAL llRetVal
         
   llRetVal = ( TYPE( 'tcCurrentClassLibrary' ) == "C" ) AND ;
              .NOT. EMPTY( tcCurrentClassLibrary )

   IF .NOT. llRetVal
      =MESSAGEBOX( "You did not specify the current class library ... " + ;
                   "the one that needs to be replaced. Process aborted." )
   ENDIF
   
   RETURN llRetVal
   
ENDFUNC

*====================================================
FUNCTION ValidateNewClassLibrary( tcNewClassLibrary )
*====================================================
   LOCAL llRetVal
         
   llRetVal = ( TYPE( 'tcNewClassLibrary' ) == "C" ) AND ;
              .NOT. EMPTY( tcNewClassLibrary )

   IF .NOT. llRetVal
      =MESSAGEBOX( "You did not specify the new class library ... " + ;
                   "the one that is replacing the currently defined class library. Process aborted." )
   ENDIF
   
   RETURN llRetVal
   
ENDFUNC

*===============================================================================================
FUNCTION MakeClassLibraryReplacements( tcCurrentClassLibrary, tcNewClassLibrary, tlSkipCompile )
*===============================================================================================
   LOCAL lcVCX , ;
         lcClassLoc , ;
         lcNewClassLibrary , ;
         lcCurrentClassLibrary , ;
         llAtLeastOneReplacementTookPlace, ;
         lcVersion
      
   SELECT crsVCX
   lcNewClassLibrary     = ALLTRIM( LOWER( tcNewClassLibrary ) )
   lcCurrentClassLibrary = ALLTRIM( LOWER( tcCurrentClassLibrary ) )
   
   *-----------------------------------------------------------
   *-- SCAN through each class library file (.VCX) and search
   *-- that file for class library locations that need updating
   *-----------------------------------------------------------
   SCAN
      lcVCX = UPPER(crsVCX.Name)
      WAIT WINDOW "Processing class library ... " + lcVCX NOWAIT
      
      *----------------------------------------------------------
      *-- All Codebook framework class libraries are named 
      *-- LIBS\ as a standard.  Therefore, since this program
      *-- is interested in replacing the include file in Codebook
      *-- classes ONLY, skip the processing of any .VCX files
      *-- that are not stored in the Codebook default locations
      *----------------------------------------------------------
      IF !("LIBS\" $ lcVCX)
         LOOP
      ENDIF
        
      SELECT 0

      IF USED('classlib')
         USE IN classlib
      ENDIF
      
      *----------------------------------------------------------------
      *-- Open the class library file as if it were a reg'ler ol' table
      *-- but only if it exists.
      *----------------------------------------------------------------
      IF FILE( lcVCX)
         USE ( lcVCX ) ALIAS classlib
      ELSE
         LOOP
      ENDIF     
      
      IF USED('classlib')
      
         llAtLeastOneReplacementTookPlace = .F.
         *------------------------------------------------------------------
         *-- Find all classes that use the currently specified class library
         *------------------------------------------------------------------
         SCAN FOR lcCurrentClassLibrary $ ALLTRIM(LOWER( classlib.classloc) )

           *-------------------------------------------------
           *-- Pull the current class library location out of 
           *-- the .VCX and prepare it for transformation
           *-------------------------------------------------
           lcClassLoc = ALLTRIM( LOWER( classlib.classloc ) )

           *--------------------------------------------------------
           *-- Transform the current class library location into the 
           *-- new class library location
           *--------------------------------------------------------
           lcNewClassLocation = STRTRAN( lcClassLoc            , ;
                                         lcCurrentClassLibrary , ;
                                         lcNewClassLibrary       ) 
                                              
           *------------------------------------------------------- 
           *-- Update the class library with the new class location
           *------------------------------------------------------- 
           REPLACE classlib.classloc WITH lcNewClassLocation

           *--------------------------------------------
           *-- Ensure the class library is recompiled if
           *-- a library file transformation took place
           *--------------------------------------------
           llAtLeastOneReplacementTookPlace = .T.

         ENDSCAN

         IF USED('classlib')
            USE IN classlib
         ENDIF

         *-------------------------------------------------------------
         *-- If any replacements of include files took place, recompile
         *-- the .VCX and it should be ready to go.
         *-------------------------------------------------------------
         IF .NOT. tlSkipCompile AND ;
            llAtLeastOneReplacementTookPlace

            lcVersion = VERSION()

            DO CASE
            CASE "03.00" $ lcVersion
               COMPILE FORM (lcVCX)
            CASE "05.00" $ lcVersion
               COMPILE CLASSLIB (lcVCX)
            OTHERWISE
               *---------------------------------------
               *-- Assume VFP 6 or higher is being used
               *---------------------------------------
               COMPILE CLASSLIB (lcVCX)
            ENDCASE            

         ENDIF
      ELSE &&- Used( 'ClassLib' )
         LOOP
      ENDIF
         
      SELECT crsVCX
      
   ENDSCAN
   
   
   IF USED( 'crsVCX' )
      USE IN crsVCX
   ENDIF
   
   WAIT WINDOW "The Change Class Library Location utility has completed processing !!!" TIMEOUT 2
   
   WAIT CLEAR
   
ENDFUNC

*------------------------------------
FUNCTION GetAuthorizationToContinue()
*------------------------------------
   LOCAL lnAnswer
   
   lnAnswer = MESSAGEBOX( "HAVE YOU BACKED UP YOUR ENTIRE PROJECT DIRECTORY?", ;
                          16 + 4, "Change Class Library Name Utility Warning" )

   IF lnAnswer <> 6
      =MESSAGEBOX( "Processing cancelled ... very wise move ... please backup your project before running any utility of this nature.", ;
                    64, "Change Class Library Name Utility Message" )
      RETURN .F.
   ELSE
      RETURN .T.
   ENDIF

ENDFUNC