msgsvc.prg

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

*  Program...........: MSGSVC.PRG
*************************************************************************
*                      Public Domain Edition
*************************************************************************
*  Version...........: 5.00.53 June 6 1997
*  Latest Version....: Check http://www.stevenblack.com
*  Description.......: Central Square for Messages.
*  Author............: Steven M. Black - email: [e-mail]
*  Special thanks to.: Dale Kiefling
*                      Andrew MacNeill
*                      Alan Schwartz
*                      Drew Speedie
*
*} Project...........: INTL
*  Created...........: 09/22/93
*  Copyright.........: None (Public Domain)
*)
*] Dependencies......: Assumes that if MsgSvc.DBF is open, it is
*]                     ORDER()'d properly
*
*  Calling Samples
*          Typical...: =msgsvc( "Some Key Expression")
*     String Swaps...: =msgvvc( "SomeKey", "Two~three~ain't bad"]
*  Thermometer bar...: =msgsvc( "in-bar message", "Therm", 30)
*
*  Parameter List....: tcMessageKey
*                      txVariable
*                      tnHowFar
*  Returns...........: Either Character, Numeric, or Logical depending
*                      on the cRetType field in MSGSVC.DBF
*
#DEFINE ccCr_Lf         CHR( 13) + CHR( 10)
#DEFINE ccParseDelim    "~"
#DEFINE FALSE           .F.
#DEFINE TRUE            .T.
#DEFINE cnSideMargin    18


*==============================================================
* If your development language is NOT English, then modify
* the lines below and specify your own native language terms
* for OK, Cancel, Yes, No, etc...
#DEFINE ccOK     "Ok"
#DEFINE ccCANCEL "Cancel"
#DEFINE ccABORT  "Abort"
#DEFINE ccRETRY  "Retry"
#DEFINE ccIGNORE "Ignore"
#DEFINE ccYES    "Yes"
#DEFINE ccNO     "No"


*===============================================================
LPARAMETERS txPara1, txPara2, txPara3

IF TYPE("_Screen.oMsgSvc")="U"
  _SCREEN.AddObject("oMsgSvc", "cMsgSvc")
ENDIF

RETURN _Screen.oMsgSvc.MsgSvc(  txPara1, txPara2, txPara3)


*//////////////////////////////////////////////////////////////////////////////
* CLASS....: c A b s t r a c t D i r e c t o r
* Version..: February 27 1997
*-- Roles of the message "director"
*--    Created by client
*--    Creates/Maintains builders
*--    Notifies builders
*--    Retrieves results from builder and displays the result
*//////////////////////////////////////////////////////////////////////////////
DEFINE CLASS cAbstractDirector AS Line

  * DataSession     = 1   && Public
  cDefaultBuilder = .NULL.
  *-- Supported sorts of PROPER(message ID) and the dialog builder class
  DIMENSION aBuilders[1,2]
  aBuilders[1,1]= .NULL.
  aBuilders[1,2]= "Unknown"

 *====================================
 *-- cAbstractDirector::GetBuilder()
 *====================================
 * Retrieve items from the aBuilders array
 *
  FUNCTION GetBuilder( tcFunction)
    IF ISNULL( tcFunction)
      RETURN .NULL.
    ENDIF

    LOCAL ;
          lcFunction, ;
          lnHit, ;
          lcRetVal

    lcRetVal= THIS.cDefaultBuilder
    IF TYPE( "tcFunction") <> "C"
      RETURN lcRetVal
    ENDIF

    lcFunction= PROPER( ALLTRIM( TokenNum( tcFunction, 1)))
    lnHit= ASCAN( THIS.aBuilders, lcFunction)
    IF lnHit> 0
      RETURN THIS.aBuilders[ lnHit+1]
    ELSE
      lnHit= ASCAN( THIS.aBuilders, "Default")
      IF lnHit> 0
        RETURN THIS.aBuilders[ lnHit+1]
      ELSE
        RETURN lcRetVal
      ENDIF
    ENDIF

 *====================================
 *-- cAbstractDirector::SetBuilder
 *====================================
 * Add items to the aBuilders array
 *
  FUNCTION SetBuilder( tcId, tcClass)
  LOCAL llRetVAal

  IF ISNULL( tcId) OR ISNULL( tcClass)
    RETURN .NULL.
  ENDIF

  llRetVal= .F.

  IF EMPTY( tcId) OR ;
     EMPTY( tcClass) OR ;
     TYPE( "tcId") <> "C" OR ;
     TYPE( "tcClass") <> "C"

    RETURN llRetVal
  ENDIF

  llRetVal= .T.

  LOCAL lnFound, lntemp
  lnFound=ASCAN( THIS.aBuilders, tcId)
  IF lnFound > 0
    THIS.aBuilders( lnFound+1)= ALLTRIM(tcClass)
  ELSE
    lnTemp= ALEN(aBuilders)
    DIMENSION THIS.aBuilders[ lnTemp+ 2]
    THIS.aBuilders[ lnTemp+ 1]= PROPER( tcId)
    THIS.aBuilders[ lnTemp+ 2]= PROPER( tcClass)
  ENDIF
  RETURN llRetVal

ENDDEFINE

*//////////////////////////////////////////////////////////////////////////////
* CLASS....: c M e s s a g e D i r e c t o r
* Version..: March 31 1996
*//////////////////////////////////////////////////////////////////////////////
DEFINE CLASS cMessageDirector AS cAbstractDirector

  cDefaultBuilder= "cDialogBuilder"

  *-- The name of the message resource file.
  cTable= "MSGSVC.DBF"

  *-- The alias of the message resource file
  cAlias= "MsgSvc"

  *-- Global switch for optional icon animation on slower systems.
  *-- Set to .F. to disable all animation
  lAnimateIcons= .T.

  *-- The return value from the message or dialog we will build.
  ReturnValue= ''

  *-- Supported sorts of PROPER(message ID) and the dialog builder class
  DIMENSION aBuilders[1,2]
  aBuilders[1,1]= "Default"
  aBuilders[1,2]= "cDialogBuilder"

  *-- Array of currently active dialogs.  Messages get put on this
  *-- stack so more than one message can be up at one time.
  DIMENSION aDialogs[1]
  aDialogs[1]= .NULL.

  *-- Abstract Methods of this class
  FUNCTION GetDialogHandle(c)
  FUNCTION MsgSvc( x1, x2, x3)
  FUNCTION OpenTable
  FUNCTION CloseTable

 *====================================
 *-- cAbstractDirector::cdx_msgsvc()
 *====================================
 * Reindex the resource file.
 * Named for backward compatibility with prior versions of MsgSvc.
 *
  FUNCTION cdx_msgsvc

    LOCAL lnOldArea, lcOldError, lnError

    lnError= 0
    lcOldError= ON("Error")
    ON ERROR lnError=1

    lnOldArea = SELECT(0)

    IF ! USED( THIS.cAlias)
      USE (THIS.cTable) IN 0 EXCLUSIVE
    ELSE
      SELECT ( THIS.cAlias)
    ENDIF

    IF lnError= 0
      DELETE TAG ALL
      INDEX ON UPPER( cKey) TAG cKey
    ENDIF

    SELECT (lnOldArea)
    ON ERROR &lcOldError

    RETURN lnError==0


 *====================================
 *-- cAbstractDirector::GetDialogHandle(c)
 *====================================
 * Retrieve the LIFO dialog of a given tipe
 * from the dialog stack
 *
  FUNCTION GetDialogHandle( tcType)
    LOCAL loRetVal, lnI
    loRetVal= .NULL.
    IF TYPE( "tcType")= "C"
      FOR lnI= ALEN( THIS.aDialogs) TO 1 STEP -1
        IF TYPE( "THIS.aDialogs[ lnI]") = "O" AND ;
           ! ISNULL( THIS.aDialogs[ lnI])
          IF UPPER( ALLTRIM( THIS.aDialogs[ lni].Type))== UPPER( ALLTRIM( tcType))
            loRetVal= THIS.aDialogs[ lni]
          ENDIF
        ENDIF
      ENDFOR
    ENDIF
    RETURN loRetVal



ENDDEFINE


*//////////////////////////////////////////////////////////////////////////////
* CLASS....: c M s g S v c ( class cMessageDirector)
*          : Concrete implementation of the abstract message director.
* Version..: March 31 1996
*//////////////////////////////////////////////////////////////////////////////
DEFINE CLASS cMsgSvc AS cMessageDirector

  *-- Stock builder ID's and builders
  DIMENSION aBuilders[16,2]

  aBuilders[1,1]= "Default"
  aBuilders[1,2]= "cDialogBuilder"

  aBuilders[2,1]= "Ok"
  aBuilders[2,2]= "cDialogBuilder"

  aBuilders[3,1]= "Ync"
  aBuilders[3,2]= "cDialogBuilder"

  aBuilders[4,1]= "Nyc"
  aBuilders[4,2]= "cDialogBuilder"

  aBuilders[5,1]= "Ari"
  aBuilders[5,2]= "cDialogBuilder"

  aBuilders[6,1]= "Yn"
  aBuilders[6,2]= "cDialogBuilder"

  aBuilders[7,1]= "Ny"
  aBuilders[7,2]= "cDialogBuilder"

  aBuilders[8,1]= "Text"
  aBuilders[8,2]= "cTextBuilder"

  aBuilders[9,1]= "Oc"
  aBuilders[9,2]= "cDialogBuilder"

  aBuilders[10,1]= "Rc"
  aBuilders[10,2]= "cDialogBuilder"

  aBuilders[11,1]= "Cancel"
  aBuilders[11,2]= "cDialogBuilder"

  aBuilders[12,1]= "Therm"
  aBuilders[12,2]= "cThermBuilder"

  aBuilders[13,1]= "Wait"
  aBuilders[13,2]= "cWaitWindBuilder"

  aBuilders[14,1]= "Nowait"
  aBuilders[14,2]= "cWaitWindBuilder"

  aBuilders[15,1]= "Working"
  aBuilders[15,2]= "cWorkingDialogBuilder"

  aBuilders[16,1]= "Tip"
  aBuilders[16,2]= "cTipBuilder"



 *====================================
 *-- cMsgSvc::MsgSvc
 *====================================
 * Workhorse function -- message "director"
 *
 * Interface notes (by type)
 *   CLL - Lookup in MsgSvc
 *
 *   CCL - Lookup with cookie substitution
 *
 *   CNL - Lookup [IF therm THEN setPercent(n)
 *
 *   NLL - IF EXIST( Therm) THEN LIFO therm update
 *         ELSE QuickTherm+update
 *
 *   NCL - IF EXIST( Therm )THEN LIFO therm/message update
 *         ELSE QuickTherm+update+message
 *
 *   LLL - IF EXIST( Working) THEN LIFO Working.Release()
 *
 *
  FUNCTION MsgSvc( txPassed1, txPassed2, txPassed3)

  LOCAL ;
    jcCounter, ;
    lcLangField, ;
    jcOldtalk, ;
    jcRetVal, ;
    jcVariable, ;
    jlNowait, ;
    llSwap, ;
    jnCounter, ;
    jnNumToSwap, ;
    jnWaitTime, ;
    lcFunction, ;
    lcWaitTime, ;
    llTherm, ;
    llWaitWind, ;
    llWorking, ;
    loParameterPackage, ;
    loSpecPackage, ;
    loSetExact, ;
    lcPTypes, ;
    lnI, ;
    lcI, ;
    lxPassed1, ;
    lxPassed2, ;
    lxPassed3

    lxPassed1= txPassed1
    lxPassed2= txPassed2
    lxPassed3= txPassed3

    loSetExact= CREATE("SetExact", "OFF")


    *-- Create a spec package to pass arround as a parameter
    loSpecPackage= CREATE( "cPackage")

    *-- Package the parameters
    loParameterPackage= CREATE( "cPackage")
    loSpecPackage.AddItem("Call parameters", loParameterPackage)

    *-- Place the call parameters in the package
    FOR lnI= 1 TO 3
      lcI=STR( lni,1)
      loParameterPackage.AddItem( "Parameter"+lcI, lxPassed&lci.)
    ENDFOR

    *-- loParameterPackage is already stored within loSpecPackage
    *-- so delete it now... it's no longer needed.
    loParameterPackage=.NULL.


    lcPTypes= TYPE("lxPassed1")+ ;
              TYPE("lxPassed2")+ ;
              TYPE("lxPassed3")

    *##########################################
    * Parameter pre-processing and dispatching
    *##########################################
    LOCAL loDialog
    DO CASE

    *-- If there is a number in the call, assume we are
    *-- dealing with a thermometer.
    CASE "N" $ lcPTypes
      *-- Assume a thermometer
      llTherm= .T.

      *-- If the numeric value is non-zero, then update
      *-- an existing therm.
      LOCAL lcZeroPos
      lcZeroPos= STR(AT("N", lcPTypes),1)

      IF lxPassed&lcZeroPos > 0
        *-- Is there a therm on the stack? If so,
        *-- update it and we're done.
        loDialog= THIS.GetDialogHandle("Therm")
        IF ! ISNULL( loDialog)
          LOCAL lni, lci, lxTest
          *-- Due to predicate dependency on nPercent,
          *-- process for percentage first
          FOR lni= 1 to 3
            lci= STR( lni,1)
            lxtest= lxPassed&lci
            IF TYPE( "lxtest")= "N"
              loDialog.SetPercent( lxTest)
              *-- ... which might kill loDialog...
              EXIT
            ENDIF
          ENDFOR

          *-- Process for Text next
          IF ! ISNULL( loDialog)
            FOR lni= 1 to 3
              lci= STR( lni,1)
              lxtest= lxPassed&lci
              IF TYPE( "lxtest")= "C"
                IF !(UPPER( lxTest)=="THERM")
                  loDialog.Settext( lxTest)
                ENDIF
              ENDIF
            ENDFOR
          ENDIF

          *-- Done
          RETURN
        ENDIF
      ENDIF

      *-- If we get here, then we're talking of
      *-- a new Dialog... Proceed as normal, except...
      IF lcPTypes= "NLL"
        lxPassed2= lxPassed1
        lxPassed1= "Therm Default"
      ENDIF

      *-- Swap the order if the numeric is first
      IF lcPTypes= "NC"
        LOCAL lx
        lx= lxPassed2
        lxPassed2= lxPassed1
        lxPassed1= lx
      ENDIF

    *-- Embedded cookie swapping
    CASE lcPTypes= "CC"
      llSwap = .T.


    CASE lcPTypes= "LLL"
      *-- Dismissing a Working message
      loDialog= THIS.GetDialogHandle("Working")