gotchas.prg

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

   IF EMPTY( tcAlias)
     tcAlias= THIS.GetAlias()
     IF EMPTY( tcAlias)
       tcAlias= TRIMPATH( tcFileName, .T.)
     ENDIF
     IF EMPTY( tcAlias)
       RETURN .F.
     ENDIF
   ENDIF
   IF ! ("." $ tcFileName)
     tcFileName=tcFileName+ THIS.cSuffix
   ENDIF
   IF ! FILE( tcFIleName)
     RETURN .F.
   ENDIF

   LOCAL lnErrorFlag, lcOldError
   lnErrorFlag= 0
   lcOldError= ON("Error")
   ON ERROR lnErrorFlag=1

   USE (tcFilename) ALIAS (tcAlias) AGAIN SHARED IN 0

   IF ! EMPTY( lcOldError)
     ON ERROR &lcOldError
   ELSE
     ON ERROR
   ENDIF
   IF lnErrorFlag=0
     THIS.ProgrammaticChange()
     THIS.lTableOpened= .T.
   ENDIF
   RETURN lnErrorFlag=0

 *====================================
 *-- cTableIterator::Prior()
 *====================================
 * Go to the previous record
 *
 FUNCTION Prior
   LOCAL llRetVal, lcAlias
   lcAlias= THIS.GetAlias()
   IF ! USED( lcAlias)
     RETURN .F.
   ENDIF

   IF ! BOF( lcAlias)
     SKIP -1 IN ( lcAlias)
     IF BOF( lcAlias)
       LOCATE
       RETURN .F.
     ENDIF
   ELSE
     RETURN .F.
   ENDIF
   THIS.ProgrammaticChange()

 *====================================
 *-- cTableIterator::SetAlias( c)
 *====================================
 * Set the alias of the file to iterate
 *
 FUNCTION SetAlias( tcPassed )
   THIS.cAlias= PROPER( tcPassed)

 *====================================
 *-- cTableIterator::SetStructure( c)
 *====================================
 * Set the table to iterate
 *
 FUNCTION SetStructure( tcPassed)
   THIS.cStructure= UPPER( tcPassed)

ENDDEFINE


*///////////////////////////////////
* C P R O J E C T I T E R A T O R
*  
* A general purpose project iterator
*///////////////////////////////////
DEFINE CLASS cProjectIterator AS cTableIterator
  PROTECTED cProjectHomeDir
  
  cProjectHomeDir= ""
  cType          = "Project"
  cSuffix        = ".PJX"

  
  *====================================
  *-- cProjectIterator::Init( x)
  *====================================
  * Parameters: 
  *   tcPassed: the .PJX file
  *
  FUNCTION Init( tcPassed)
 
    IF TYPE( "tcPassed") <> "C"
      RETURN .F.
    ENDIF
    
    LOCAL llRetVal 
    *-- Adjust for missing file name suffix
    IF ! "." $ tcpassed
      tcpassed=ALLTRIM(tcpassed+THIS.cSuffix)
    ENDIF
    
    *-- Open the table as usual
    llRetVal= cTableIterator::Init( tcPassed)
    
    *-- Set the project home directory property
    IF llRetVal
      LOCAL lcAliasHandle
      lcAliasHandle=THIS.GetAlias()
      THIS.SetProjectHomeDir( &lcAliasHandle..HomeDir)
    ELSE
      *? Raise an exception
    ENDIF
    RETURN llRetVal

  *====================================
  *-- cProjectIterator::GetCurrentSourceID()
  *====================================
  *-- Return the full path of the project element
  *
  FUNCTION GetCurrentSourceID()
    LOCAL lcAlias
    lcAlias=THIS.GetAlias()
    RETURN FULLPATH( STRTRAN( ALLTRIM( &lcAlias..Name), CHR(0)), THIS.GetHomeDir())

  *====================================
  *-- cProjectIterator::GetHomeDir()
  *====================================
  * Return the project home directory
  *
  FUNCTION GetHomeDir()
    RETURN THIS.cProjectHomeDir

  *====================================
  *-- cProjectIterator::SetprojectHomeDir( c)
  *====================================
  * Set the project home directory property
  *
  PROTECTED FUNCTION SetProjectHomeDir( tcPath)
    THIS.cProjectHomeDir= AddBs( STRTRAN( ALLTRIM( tcPath), CHR(0)))
    
ENDDEFINE


*///////////////////////////////////
* C S C X I T E R A T O R
*
* A general purpose .SCX iterator
*///////////////////////////////////
DEFINE CLASS cSCXIterator AS cTableIterator
  cType          = "Form"
  cSuffix        = ".SCX"
ENDDEFINE

*///////////////////////////////////
* V C X I T E R A T O R
*
* A general purpose .VCX iterator
*///////////////////////////////////
DEFINE CLASS cVCXIterator AS cTableIterator
  cType          = "Visual Class Library"
  cSuffix        = ".VCX"
ENDDEFINE

*///////////////////////////////////
* M N X I T E R A T O R
*
* A general purpose .MNX iterator
*///////////////////////////////////
DEFINE CLASS cMNXIterator AS cTableIterator
  cType          = "Menu"
  cSuffix        = ".MNX"
ENDDEFINE

*///////////////////////////////////
* C F R X I T E R A T O R
*
* A general purpose .FRX iterator
*///////////////////////////////////
DEFINE CLASS cFRXIterator AS cTableIterator
  cType          = "Report"
  cSuffix        = ".FRX"
ENDDEFINE



*!*********************************************
*!
*!       Procedure: trimpath
*!
*!*********************************************
FUNCTION trimpath
PARAMETERS filename, trim_ext, plattype
PRIVATE at_pos

IF EMPTY( m.filename)
  RETURN ""
ENDIF
m.at_pos=AT( ":", m.filename)
IF m.at_pos>0
  m.filename=SUBSTR( m.filename, m.at_pos+ 1)
ENDIF
IF m.trim_ext
  m.filename=trimext( m.filename)
ENDIF
IF m.plattype
  m.filename=IIF( _DOS.OR._UNIX, UPPER( m.filename), LOWER( m.filename))
ENDIF
m.filename=ALLTRIM( SUBSTR( m.filename, AT( "\", m.filename, ;
           MAX( OCCURS( "\", m.filename), 1))+ 1))
DO WHILE LEFT( m.filename, 1)=="."
  m.filename=ALLTRIM( SUBSTR( m.filename, 2))
ENDDO
DO WHILE RIGHT( m.filename, 1)=="."
  m.filename=ALLTRIM( LEFT( m.filename, LEN( m.filename)- 1))
ENDDO
RETURN m.filename

*!*********************************************
*!
*!       Procedure: addbs
*!
*!*********************************************
FUNCTION AddBs( tcString)
LOCAL lcString
lcString= tcString
IF RIGHT( lcString,1)<> "\"
  lcString= lcString+ "\"
ENDIF
RETURN lcString


*====================================
*-- toleft( cc[ n])
*====================================
*  Program...........: TOLEFT.PRG
*  Author............: Steven M. Black
*} Project...........: INTL
*  Created...........: 10/05/93
*  Copyright.........: ( c) Steven Black Consulting, 1993
*) Description.......: Returns characters from a character expression
*)                     to the left of a specified string
*] Dependencies......: None
*  Calling Samples...: toleft( <expC1>, <expC2>[ , <expN>])
*                      tcSearch     - The string to search for
*                      tcExpression - The string that is searched
*                      tnOccurence  - Which occurence of C1 in C2
*  Parameter List....:
*  Returns...........:
*  Major change list.:
PROCEDURE toleft
PARAMETER tcSearch, tcExpression, tnOccurence
RETURN LEFTC( tcExpression, ;
             AT_C( tcSearch, ;
                 tcExpression, ;
                 IIF( EMPTY( tnOccurence), 1, tnOccurence)) - 1)

*====================================
*-- toright( cc[ n])
*====================================
*  Program...........: TORIGHT.PRG
*  Author............: Steven M. Black
*} Project...........: Common
*  Created...........: 10/05/93
*  Copyright.........: ( c) Steven Black Consulting, 1993
*) Description.......: Returns characters from a character expression
*)                     to the right of a specified string
*] Dependencies......: None
*  Calling Samples...: toright( <expC1>, <expC2>, [ , <expN>])
*  Parameter List....: tcToSearch   - The string to search for
*                      tcExpression - The string to search within
*                      tnOccurence  - Which occurence of C1 in C2
*  Returns...........:
*  Major change list.:
PROCEDURE toright
PARAMETER tcToSearch, tcExpression, tnOccurence
PRIVATE xnsplitpos
xnsplitpos = AT_C( tcToSearch, ;
                 tcExpression, ;
                 IIF( EMPTY( tnOccurence), ;
                      1, ;
                      tnOccurence))

RETURN IIF( xnsplitpos=0, ;
            "", ;
            RIGHTC( tcExpression, ;
                   LENC( tcExpression)- xnsplitpos- LENC( tcToSearch)+ 1))


*====================================
*-- within( ccc[ n[ n]])
*====================================
*  Program...........: WITHIN.PRG
*  Author............: Steven M. Black
*} Project...........: Common
*  Created...........: 10/04/93
*  Copyright.........: ( c) Steven Black Consulting, 1993
*) Description.......: Returns string contained within two
*)                     others.  Case sensitive
*] Dependencies......:
*  Calling Samples...: within( <expC>, <expC>, <expC> [ , <expN> [ , <expN>]])
*  Parameter List....: tcExpression
*                      tcLeft
*                      tcRight
*                      tnFirstOne
*                      tnFollowing
*  Returns...........:
*  Major change list.:
PROCEDURE within
PARAMETER tcExpression, tcLeft, tcRight, tnFirstOne, tnFollowing

PRIVATE lcReturnVal, tnLeftpos
lcReturnVal = [ ]
tnLeftpos = AT_C( tcLeft, tcExpression, IIF( EMPTY( tnFirstOne), 1, tnFirstOne))
IF tnLeftpos> 0
    tnLeftpos = tnLeftpos+ LENC( tcLeft)
    IF tnLeftpos< LENC( tcExpression)
        lcReturnVal = SUBSTRC( tcExpression, ;
                              tnLeftpos, ;
                              AT_C( tcRight, ;
                                  SUBSTRC( tcExpression, tnLeftpos), ;
                                  IIF( EMPTY( tnFollowing), 1, tnFollowing))- 1)
    ENDIF
ENDIF
RETURN lcReturnVal

*====================================
*-- withinc( ccc[ n[ n]])
*====================================
*  Program...........: WITHINC.PRG
*  Author............: Steven M. Black
*} Project...........: Common
*  Created...........: 10/04/93
*  Copyright.........: ( c) Steven Black Consulting, 1993
*) Description.......: Returns string contained within two
*)                     others.  Case in- sensitive
*] Dependencies......:
*  Calling Samples...: within( <expC>, <expC>, <expC> [ , <expN> [ , <expN>]])
*  Parameter List....: tcExpression
*                      tcLeft
*                      tcRight
*                      tnFirstOne
*                      tnFollowing
*  Returns...........:
*  Major change list.:
PROCEDURE withinc
PARAMETER tcExpression,  tcLeft,  tcRight,  tnFirstOne,  tnFollowing
PRIVATE lcRetVal,  lnLeft
lcRetVal = [ ]
lnLeft = ATCC( tcLeft, tcExpression, IIF( EMPTY( tnFirstOne), 1, tnFirstOne))
IF lnLeft>0
    lnLeft = lnLeft+ LENC( tcLeft)
    IF lnLeft<LENC( tcExpression)
        lcRetVal = SUBSTRC( tcExpression, ;
                           lnLeft, ;
                           ATCC( tcRight, ;
                                SUBSTRC( tcExpression, lnLeft), ;
                                IIF( EMPTY( tnFollowing), 1, tnFollowing))- 1)
    ENDIF
ENDIF
RETURN lcRetVal