msgsvc.prg

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

      ENDIF
      THIS.aItems[ lnTemp+ 1]= PROPER( tcType)
      THIS.aItems[ lnTemp+ 2]= txItem
    ENDIF
    llRetVal= .T.
    THIS.ItemCount= IIF(ISNULL( THIS.aItems[1]), 0 , ALEN( THIS.aItems,1))
  RETURN llRetVal

 *====================================
 *-- cPackage::Release()
 *====================================
 * Clean up this item and release
 *
 FUNCTION Release
  LOCAL lni
  FOR lni= 1 TO ALEN(THIS.aItems,1)
    IF TYPE("THIS.aItems[lni, 2].cClassId") <> "U" AND THIS.aItems[lni, 2].cClassId= THIS.cClassId
      THIS.aItems[lni, 2].Release()
    ENDIF
    THIS.aItems[lni, 1]= .NULL.
    THIS.aItems[lni, 2]= .NULL.
  ENDFOR

  RELEASE THIS

ENDDEFINE

*//////////////////////////////////////////////////////////////////////////////
* CLASS....: c T O D B u t t o n
*          : Tip of the day button
* Version..: March 31 1996
*//////////////////////////////////////////////////////////////////////////////
DEFINE CLASS cTODButton AS CommandButton
  Height  = 24
  Width   = 90
  FontName= "MS Sans Serif"
  FontSize= 8
  FontBold= .F.
  Name    = "TipOfTheDayButton"
ENDDEFINE

*
*-- EndDefine: tod
**************************************************



*//////////////////////////////////////////////////////////////////////////////
* CLASS....: c C m d M s g S v c
* Version..: March 31 1996
*//////////////////////////////////////////////////////////////////////////////
DEFINE CLASS cCmdMsgSvc AS CommandButton
  Height= 23
  FontName= "MS SANS Serif"
  FontSize= 8
  FontBold= .F.
  DIMENSION aRetVals[4]

 *====================================
 *-- cCmdMsgSvc::Init(o)
 *====================================
 *
 FUNCTION Init( toSpecPackage)
    THIS.aRetVals[1]= ''   && Original language caption
    THIS.aRetVals[2]= 0    && Button number
    THIS.aRetVals[3]= .F.  && First button
    THIS.aRetVals[4]= 0    && MESSAGEBOX()-Compatible

 *====================================
 *-- cCmdMsgSvc::
 *====================================
 * Pass the return values up the tree
  FUNCTION Click
    THISFORM.aRetVals[1]= THIS.aRetVals[1]  && Original language caption
    THISFORM.aRetVals[2]= THIS.aRetVals[2]  && Button number
    THISFORM.aRetVals[3]= THIS.aRetVals[3]  && First button
    THISFORM.aRetVals[4]= THIS.aRetVals[4]  && MESSAGEBOX()-Compatible

    THISFORM.Release()

ENDDEFINE

*//////////////////////////////////////////////////////////////////////////////
* CLASS....: c T m r M s g S v c
* Version..: March 31 1996
*//////////////////////////////////////////////////////////////////////////////
DEFINE CLASS cTmrMsgSvc AS Timer
 *====================================
 *-- cTmrMsgSvc::Init
 *====================================
 *
 FUNCTION Init( toSpecPackage)
   LOCAL loMessageSpec
   loMessageSpec= toSpecPackage.GetItem( "Message spec")
   IF VAL( loMessageSpec.cTimeout) > 0
     THIS.Interval= VAL( loMessageSpec.cTimeout)*1000
   ENDIF

 FUNCTION Timer
   THISFORM.Release()

ENDDEFINE


*//////////////////////////////////////////////////////////////////////////////
* CLASS....: c A b s t r a c t M s g C o n t a i n e r
* Version..: March 31 1996
*//////////////////////////////////////////////////////////////////////////////
DEFINE CLASS cAbstractMsgContainer AS Container
  FUNCTION Init( o)
  FUNCTION SetPercent(n)
  FUNCTION GetPercent(n)
ENDDEFINE

*//////////////////////////////////////////////////////////////////////////////
* CLASS....: c L i n T h e r m
* Version..: March 31 1996
*//////////////////////////////////////////////////////////////////////////////
DEFINE CLASS cLinTherm AS Line
  BorderColor = RGB( 192, 192, 192)
  BorderWidth = 2
ENDDEFINE

*//////////////////////////////////////////////////////////////////////////////
* CLASS....: c C t r T h e r m
* Version..: March 31 1996
*//////////////////////////////////////////////////////////////////////////////
DEFINE CLASS cCtrThermBar AS cAbstractMsgContainer
  BackColor    = RGB( 0, 0, 255)
  BackStyle    = 1     && 1= Opaque
  BorderWidth  = 0
  SpecialEffect= 1     && 1= Sunken


ENDDEFINE

*//////////////////////////////////////////////////////////////////////////////
* CLASS....: c C t r T h e r m
* Version..: March 31 1996
*//////////////////////////////////////////////////////////////////////////////
DEFINE CLASS cCtrTherm AS cAbstractMsgContainer
  BackColor    = RGB( 192, 192, 192)
  BackStyle    = 1     && 1= Opaque
  BorderWidth  = 1
  Height= 20
  SpecialEffect= 1     && 1= Sunken
  Width= 285

  nBorder= 3
  nPercent= 0
 *====================================
 *-- cCtrTherm::Init(o)
 *====================================
 * Build the thermometer bar illusion
  FUNCTION INIT( toSpecPackage)
  THIS.AddObject( "oLabel", "cThermBarLblMsgSvc")
  WITH THIS.oLabel
    .Top  = (THIS.Height/2)- (.Height/2) +1
    .Left = (THIS.Width/2)- (TXTWIDTH(.Caption, .FontName, .FontSize)/2)
    .Visible= .T.
  ENDWITH

  THIS.AddObject( "oTherm", "cCtrThermBar")

  WITH THIS.oTherm
    .Top= THIS.nBorder
    .Left=THIS.nBorder
    .Height= THIS.Height-(2*THIS.nBorder)
    .Visible      = .T.
    .AddObject( "oLabel", "cThermBarLblMsgSvc")
    WITH .oLabel
      .Top  = THIS.Height/2- .Height/2- THIS.nBorder
      .ForeColor= RGB(255,255,255)
      .Visible= .F.
    ENDWITH
  ENDWITH

  *-- Lay down therm bar separators
  LOCAL lnI, lcI
  THIS.oLabel.Visible= .F.
  FOR lnI= 1 TO 19
    lcI=ALLTRIM(STR( lni,2))
    THIS.AddObject("oSep"+lcI, "cLinTherm")
    WITH THIS.oSep&lcI.
      .Visible=.T.
      .Left= lni*THIS.Width/20
      .Height= THIS.Height- 5
      .Width= 0
      .Top= 3
    ENDWITH
  ENDFOR

  IF THIS.SpecialEffect= 1  && Sunken
    THIS.AddObject("H3D", "Line")
    WITH THIS.H3D
      .BorderColor=RGB(255,255,255)
      .BorderWidth=1
      .Top=THIS.Height-1
      .Left=1
      .Width=THIS.Width-2
      .Height=0
      .Visible= .T.
    ENDWITH
    THIS.AddObject("V3D", "Line")
    WITH THIS.V3D
      .BorderColor=RGB(255,255,255)
      .BorderWidth=1
      .Top= 1
      .Left= THIS.Width-1
      .Width=0
      .Height=THIS.height-1
      .Visible= .T.
    ENDWITH
  ENDIF

  THIS.RefreshTherm()

 *====================================
 *-- cCtrTherm::GetPercent(n)
 *====================================
  FUNCTION GetPercent( tnPercent)
    RETURN THIS.nPercent

 *====================================
 *-- cCtrTherm::SetPercent(n)
 *====================================
  FUNCTION SetPercent( tnPercent)
    DO CASE
    CASE TYPE( "tnPercent") <> "N"
    CASE tnPercent >= 100
      THISFORM.Release()
    CASE tnPercent < 0
      THIS.nPercent = 0
    OTHERWISE
      THIS.nPercent= tnPercent
    ENDCASE
    THIS.RefreshTherm()

 *====================================
 *-- cCtrTherm::RefreshTherm()
 *====================================
  FUNCTION RefreshTherm
   THIS.oLabel.Caption=ALLTRIM(STR(INT(THIS.nPercent),3))+ " %"
   WITH THIS.oTherm
     .Width= MAX(0, MIN(THIS.nPercent,100))/100 * (THIS.Width - (2*THIS.nBorder))
     WITH .oLabel
       .Caption=ALLTRIM(STR(THIS.nPercent,3,0))+ " %"
       .Left = THIS.Width/2- TXTWIDTH(.Caption, ;
                                     .FontName, ;
                                     .FontSize)/2 ;
                          - THIS.nBorder-1

       .ForeColor= RGB(255,255,255)
       .Visible= .F.
     ENDWITH
   ENDWITH
ENDDEFINE


*//////////////////////////////////////////////////////////////////////////////
* CLASS....: c C t r C o m m a n d B u t t o n
* Version..: March 31 1996
*//////////////////////////////////////////////////////////////////////////////
DEFINE CLASS cCtrCommandButton AS cAbstractMsgContainer
 BackStyle= 0
 BorderWidth= 0
 Spacing= 6
 ButtonClass= "cCmdMsgSvc"

 DIMENSION aTrans[5]
 DIMENSION aOriginal[5]

 *====================================
 *-- cCtrCommandButton::Init(oo)
 *====================================
 FUNCTION Init( toSpecPackage)

   *-- Analyse toSpecPackage
   THIS.ButtonSpec( toSpecPackage)
   *-- localize the captions
   *-- Create Buttons
   THIS.AddButtons( THISFORM)

 *====================================
 *-- cCtrCommandButton::ButtonSpec(o)
 *====================================
 FUNCTION ButtonSpec( toSpecPackage)
 LOCAL lcFunction, lcUppFunction, loMessageSpec
 loMessageSpec=toSpecPackage.GetItem( "Message spec")

 lcFunction= loMessageSpec.cFunction

 IF EMPTY( lcFunction)
   lcFunction= ccOK
 ENDIF
 lcUppFunc = UPPER( ALLTRIM(lcFunction))

 DO CASE
 CASE lcUppFunc== [OK]
    DIMENSION THIS.aOriginal[1], THIS.aTrans[1]
    THIS.aOriginal[1]= ccOK
    THIS.aTrans[1]   =  [\!\<OK]

 CASE lcUppFunc== [OC]
    DIMENSION THIS.aOriginal[2], THIS.aTrans[2]
    THIS.aOriginal[1]= ccOK
    THIS.aOriginal[2]= ccCANCEL
    THIS.aTrans[1]   =  [\!\<] + ccOK 
    THIS.aTrans[2]   =  [\?\<] + ccCANCEL 

   CASE lcUppFunc== [YN]
    DIMENSION THIS.aOriginal[2], THIS.aTrans[2]
    THIS.aOriginal[1]= ccYES
    THIS.aOriginal[2]= ccNO
    THIS.aTrans[1]   =  [\!\<] + ccYES
    THIS.aTrans[2]   =  [\<] + ccNO

   CASE lcUppFunc== [NY]
    DIMENSION THIS.aOriginal[2], THIS.aTrans[2]
    THIS.aOriginal[1]= ccNO
    THIS.aOriginal[2]= ccYES
    THIS.aTrans[1]   =  [\<] + ccNO
    THIS.aTrans[2]   =  [\?\<] + ccYES

   CASE lcUppFunc== [YNC]
    DIMENSION THIS.aOriginal[3], THIS.aTrans[3]
    THIS.aOriginal[1]= ccYES
    THIS.aOriginal[2]= ccNO
    THIS.aOriginal[3]= ccCancel
    THIS.aTrans[1]   =  [\!\<]+ ccYes
    THIS.aTrans[2]   =  [\<]+ ccNO
    THIS.aTrans[3]   =  [\?\<]+ ccCANCEL

   CASE lcUppFunc== [NYC]
    DIMENSION THIS.aOriginal[3], THIS.aTrans[3]
    THIS.aOriginal[1]= ccNO
    THIS.aOriginal[2]= ccYES
    THIS.aOriginal[3]= ccCANCEL
    THIS.aTrans[1]   =  [\!\<] + ccNO
    THIS.aTrans[2]   =  [\<]+ ccYES
    THIS.aTrans[3]   =  [\?\<]+ ccCANCEL

   CASE lcUppFunc== [RC]
    DIMENSION THIS.aOriginal[2], THIS.aTrans[2]
    THIS.aOriginal[1]= ccRETRY
    THIS.aOriginal[2]= ccCANCEL
    THIS.aTrans[1]   =  [\!\<]+ ccRETRY
    THIS.aTrans[2]   =  [\?\<]+ ccCANCEL

   CASE lcUppFunc== [ARI]
    DIMENSION THIS.aOriginal[3], THIS.aTrans[3]
    THIS.aOriginal[1]= ccABORT
    THIS.aOriginal[2]= ccRETRY
    THIS.aOriginal[3]= ccIGNORE
    THIS.aTrans[1]   =  [\!\<] + ccABORT
    THIS.aTrans[2]   =  [\<]+ ccRETRY
    THIS.aTrans[3]   =  [\<] + ccIGNORE

   CASE lcUppFunc== [CANCEL]
    DIMENSION THIS.aOriginal[1], THIS.aTrans[1]
    THIS.aOriginal[1]= ccCANCEL
    THIS.aTrans[1]   =  [\?\<]+ ccCANCEL

   CASE lcUppFunc== [WORKING]
    llWorking= .T.

   * CASE [;] $ lcUppFunc
   OTHERWISE
    lcHoldVar = []
    jnNumButtons = tokens( lcFunction, [;], .T.)
    DIMENSION THIS.aOriginal[jnNumButtons], THIS.aTrans[jnNumButtons]
    FOR jni = 1 TO jnNumButtons
       jcThisWord      = tokennum( lcFunction, jni, [;], .T.)   && *? added .T. on a hunch
       THIS.aOriginal[jnI] = jcThisWord
       THIS.aTrans[jnI] =  jcThisword
       lcHoldVar       = lcHoldVar + THIS.aTrans[jnI] + [;]
    ENDFOR
    *-- Eliminate trailing ";"
    lcFunction = LEFT( lcHoldVar, LEN( lcHoldVar) - 1 )
 ENDCASE

 *====================================
 *-- cCtrCommandButton::AddButtons(oo)
 *   Add buttons to the button container
 *====================================
 FUNCTION AddButtons( toDialog)
   LOCAL lnI, lcI, loTemp, laTemp, lcMsgBox
   lcMsgBox= SPACE(9)+          ;
             PADR( ccOK,    10)+ ;
             PADR( ccCANCEL,10)+ ;
             PADR( ccABORT, 10)+ ;
             PADR( ccRETRY, 10)+ ;
             PADR( ccIGNORE,10)+ ;
             PADR( ccYES,   10)+ ;
             PADR( ccNO,    10)

   FOR lnI= 1 TO ALEN( THIS.aTrans)
     IF TYPE("THIS.aTrans[ lnI]")= "L"
       EXIT
     ENDIF
     lcName= "cmd"+STR( lnI,1)
     THIS.AddObject( lcName, THIS.ButtonClass)
     loTemp= THIS.&lcName.
     loTemp.Caption= NoOldHot(THIS.aTrans[ lnI])
     *-- Add button characteristics
     loTemp.aRetVals[1]= NOHOT(THIS.aOriginal[ lnI]) && Original language caption
     loTemp.aRetVals[2]= lnI                  && Button number
     loTemp.aRetVals[3]= (lnI=1)              && First button?
     loTemp.aRetVals[4]= INT(AT(loTemp.aRetVals[1], lcMsgBox)/10) && MessageBox() compatibility

     *-- Load ESC & Ctrl-Enter properties here
     IF "\!" $ THIS.aTrans[lnI]
       loTemp.Default=.T.
     ENDIF

     IF "\?" $ THIS.aTrans[lnI]
       loTemp.Cancel=.T.
     ENDIF
   ENDFOR

   *-- Lay them out
   LOCAL lnSpacing, lnHeight, lnMaxWidth, lnAvgWidth
   lnMaxWidth= 0
   lnAvgWidth= 0
   IF THIS.ControlCount > 0
     lnAvgWidth= FONTMETRIC(6, ;
                            THIS.Controls(1).FontName, ;
                            THIS.Controls(1).FontSize)

     *-- WIN95 guidelines
     lnSpacing= lnAvgWidth
     lnHeight=  FONTMETRIC(1, ;
                           THIS.Controls(1).FontName, ;
                           THIS.Controls(1).FontSize) * 7/4
   ENDIF


   FOR lnI=1 TO THIS.ControlCount
     lnMaxWidth= MAX( lnMaxWidth, lnAvgWidth* ;
                                  TXTWIDTH( NoHot(THIS.Controls(lnI).Caption), ;
                                  THIS.Controls(lnI).FontName, ;
                                  THIS.Controls(lnI).FontSize))
   ENDFOR
   lnMaxWidth= lnMaxWidth * (2.2)

   *-- Adjust the button sizes
   FOR lnI=1 TO THIS.ControlCount
     THIS.Controls(lnI).Width= lnMaxWidth
     THIS.Controls(lnI).Height= toDialog.nVDBU*14
     THIS.Controls(lnI).Left  = (toDialog.nHDBU*4)+ ;
                                ((lnI-1)* (lnMaxWidth+ (toDialog.nHDBU*4)))
     THIS.Controls(lnI).Top= 0
     THIS.Controls(lnI).Visible= .T.
   ENDFOR
   IF THIS.ControlCount> 0
     THIS.Height= THIS.Controls(1).Height
     THIS.Width = 2*(toDialog.nHDBU*4)+ ;
                  (THIS.ControlCoun