changesc.prg

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

*--------------------------------------------------
*-- Example of a cautious setting ...
*-- 
*--   =SetIncl( "EMPTYONLY", "CAUTIOUS" )
*--           ------ OR ------
*--   =SetIncl()
*--
*---------------------------------------------------
*-- Example of a ballsy setting ... 
*-- 
*--   =SetIncl( "ReplaceAll", "NoMessages" )
*--
*-- Note: "ReplaceAll" and "NoMessages" are keywords
*--       for the aggressive setting.  Anything
*--       else passed into this program, like the
*--       messages in the cautious setting above,
*--       (1) result in the default settings of 
*--       replacing the include file for those
*--       classes that as of yet do not have one
*--       defined (2) and confirmation messages
*--       being displayed.
*-- 
*---------------------------------------------------
PARAMETERS tcCurrentClassLibrary, tcNewClassLibrary

LOCAL llOK2Replace , ;
      llCautious , ;
      llRetVal
     
PRIVATE laClassLibNames , ;
        lcMessageBoxTitle , ;
        llDefaultCautiousValue , ;
        llDefaultEmptyOnlyValue , ;
        llBugOut , ;
        lcProjectFileAlias, ;
        llReplaceOnlyEmptyIncludeFiles

*========================================================*
*==            Application default values              ==*
*========================================================*
#DEFINE   COMMON_INCLUDE   "..\include\framincl.h"
#DEFINE   LOCAL_INCLUDE    "..\include\appincl.h"

DIMENSION laClassLibNames[1]
laClassLibNames[1] = ""
lcMessageBoxTitle       = "SAVI Include File Utility Message"
llDefaultCautiousValue  = .T.
llDefaultEmptyOnlyValue = .T.

llBugOut                       = .F.
llRetVal                       = .T.
llCautious                     = .T.
lcProjectFileAlias             = ""
llOK2Replace                   = .F.
llReplaceOnlyEmptyIncludeFiles = .T.


*===========================================================================*
*=====                     Main Program Processing                     =====*
*===========================================================================*
CLOSE TABLES
CLOSE DATABASES

llRetVal = llRetVal AND ;
           ValidateCurrentClassLibrary( tcCurrentClassLibrary )

llRetVal = llRetVal AND ;
           ValidateNewClassLibrary( tcNewClassLibrary )

llRetVal = llRetVal AND ;
           GetProjectFile( @lcProjectFileAlias )

llRetVal = llRetVal AND ;
           GetClassLibraryNamesFromProject( lcProjectFileAlias )
                                                      
llRetVal = llRetVal AND ;
           MakeSuperclassReplacements( tcCurrentClassLib, tcNewClassLib )

RETURN llRetVal


*===========================================================================*
*=====                 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
      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 MakeIncludeFileReplacements( tlReplaceOnlyEmptyIncludeFiles  , ;
                                      tlCautious                        )
*============================================================================
   LOCAL lcClassName, ;
         lcIncludeFileName, ;
         lcMessage, ;
         lcInclude, ;
         llAtLeastOneReplacementTookPlace, ;
         llOK2Replace, ;
         lcVersion
         
         
   *----------------------------------------
   *-- If there are any class library files
   *-- in the current directory
   *----------------------------------------
   
   SELECT crsVCX
   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
        
      lcInclude = IIF( "\COMMON" $ lcVCX , ;
                       COMMON_INCLUDE    , ;
                       LOCAL_INCLUDE       )
      SELECT 0
      *----------------------------------------------------------------
      *-- Open the class library file as if it were a reg'ler ol' table
      *----------------------------------------------------------------
      USE (lcVCX) ALIAS classlib
        
      IF USED('classlib')
      
         llAtLeastOneReplacementTookPlace = .F.
      
         *----------------------------------------------------
         *-- Look for each record in the class library
         *-- that defines a class created by the developer
         *-- Note that this is how FoxPro itself determines
         *-- which records in the class library represent
         *-- classes so they can be displayed when you expand
         *-- the class library in the tree to view the classes.
         *-- The following SCAN/ENDSCAN loop looks for these
         *-- special records ...
         *-----------------------------------------------------
          SCAN FOR "CLASS" == ALLTRIM(UPPER( classlib.reserved1 ) ) AND EMPTY( parent )
         
            lcClassName       = UPPER( ALLTRIM( classlib.objname   ) )
            lcIncludeFileName = UPPER( ALLTRIM( classlib.reserved8 ) )
            llOK2Replace      = .F.
            
            DO CASE
            CASE EMPTY( classlib.reserved8 )
               *-------------------------------------------------------------
               *-- It's always OK to replace the include file of an empty 
               *-- class
               *-------------------------------------------------------------
               lcMessage = "There is no include file for "      + ;
                            CHR(13) + CHR(13) + ;
                            lcClassName + ".  "                 + ;
                            CHR(13) + CHR(13) + ;
                           "Would you like to change it to"     + ;
                            CHR(13) + CHR(13) + ;
                            lcInclude  + "???"
   
                  llOK2Replace = MessageYNC( lcMessage, tlCautious, @llBugOut )
                  
            CASE .NOT. EMPTY( classlib.reserved8 ) AND ;
                 .NOT. tlReplaceOnlyEmptyIncludeFiles
               *-------------------------------------------------------------
               *-- If an include file exists and they want to replace it with
               *-- the specified one ... make sure.
               *-------------------------------------------------------------
               lcMessage = lcClassName                               + ;
                           CHR(13) + CHR(13) + ;
                          " already has the following include file " + ;
                           CHR(13) + CHR(13) + ;
                           lcIncludeFileName + ".  "                 + ;
                           CHR(13) + CHR(13) + ;
                          "Do you want to replace it with "          + ;
                           CHR(13) + CHR(13) + ;
                           lcInclude + " ??? "
                              
               llOK2Replace = MessageYNC( lcMessage, tlCautious, @llBugout )
               
            ENDCASE
            
            IF llBugOut
               EXIT
            ENDIF
               
            IF llOK2Replace
               REPLACE classlib.reserved8 WITH lcInclude
               llAtLeastOneReplacementTookPlace = .T.
            ENDIF            

         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 llAtLeastOneReplacementTookPlace
         
            lcVersion = VERSION()
            
            DO CASE
            CASE "03.00" $ lcVersion
               COMPILE FORM (lcVCX)

            CASE "05.00" $ lcVersion
               COMPILE CLASSLIB (lcVCX)

            OTHERWISE
               *---------------------
               *-- Skip the recompile
               *---------------------
            ENDCASE            
         ENDIF
         
         IF llBugOut
            EXIT
         ENDIF

      ELSE &&- Used( 'ClassLib' )
         
         LOOP
            
      ENDIF
         
      SELECT crsVCX
      
   ENDSCAN
   
   
   IF USED( 'crsVCX' )
      USE IN crsVCX
   ENDIF
   
   WAIT WINDOW "The Set Include File Utility has completed processing !!!" TIMEOUT 2
   
   WAIT CLEAR
   
ENDFUNC

*==========================================
FUNCTION MessageYN( tcMessage, tlCautious )
*==========================================

LOCAL llRetVal, ;
      lnAnswer
      
   IF .NOT. tlCautious
      RETURN .T.
   ENDIF
   
   lnAnswer = MESSAGEBOX( tcMessage, 4, lcMessageBoxTitle )

   DO CASE
   CASE lnAnswer = 6  && Yes
      llRetVal = .T.
   CASE lnAnswer = 7  && No
      llRetVal = .F.
   OTHERWISE          && Unknown (don't take any chances )
      llRetVal = .F. 
   ENDCASE
   RETURN llRetVal
   
ENDFUNC

*=======================================================
FUNCTION MessageYNC( tcMessage, tlOK2Replace, tlBugOut )
*=======================================================

LOCAL llRetVal, ;
      lnAnswer

   tlOK2Replace = .F.
   tlBugOut     = .F.
         
   lnAnswer = MESSAGEBOX( tcMessage, 3, lcMessageBoxTitle )

   DO CASE
   CASE lnAnswer = 2  && Cancel
      tlBugOut = .T.
   CASE lnAnswer = 6  && Yes
      llRetVal = .T.
   CASE lnAnswer = 7  && No
      llRetVal = .F.
   OTHERWISE          && Unknown (don't take any chances )
      llRetVal = .F. 
   ENDCASE
   
   RETURN llRetVal
   
ENDFUNC