msgsvc.prg

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

*_FRM

*//////////////////////////////////////////////////////////////////////////////
* CLASS....: c F r m M s g S v c
* Version..: March 31 1996
*//////////////////////////////////////////////////////////////////////////////
DEFINE CLASS cfrmMsgSvc AS FORM
  * Base class for message services forms
  * ER's
  *   ? HalfHeightCaption option
  *   ? No title bar option
  *   ? ShowTips option
  *   ? Help option

*-- Standard form properties
  *  MinHeight= 84
  MinHeight  = 15
  MinWidth   = 175
  MaxWidth   = SYSMETRIC(1) * 0.62
  AlwaysOnTop= .T.
  AutoCenter = .T.
  BackColor  = RGB( 192, 192, 192)
  BorderStyle= 0 && no border
  Caption    = "MsgSvc"
  Closable   = .T.
  ColorSource= 4 && Windows control panel
  ControlBox = .F.
  Desktop    = .T.
  FontName   = "MS Sans Serif"
  FontSize   = 8
  FontBold   = .F.
  Height     = 175
  MaxButton  = .F.
  ShowWindow = 1
  MinButton  = .F.
  WindowType = 1   && Modal

*-- Custom properties
  oReturnPointer= .NULL.
  nReturnIndex = 1
  Type = "Dialog"
  nHDBU=  6   && Horizontal Dialog Base Units
  nVDBU=  8   && Vertical and


  *-- Initialize the return array
  DIMENSION aRetVals[4]  && For button return values

 *====================================
 *-- cFrmMsgSvc::Init
 *====================================
  FUNCTION Init
    *-- Initialize array (bin) of return values
    THIS.aRetVals[1]= ''   && Original language caption
    THIS.aRetVals[2]= 0    && Button number
    THIS.aRetVals[3]= .F.  && First button
    THIS.aRetVals[4]= 0    && MESSAGEBOX()-Compatible

    *-- Horizontal and Vertical dialog base units
    THIS.nHDBU = FONTMETRIC(6, THIS.FontName, THIS.FontSize)/4
    THIS.nVDBU = FONTMETRIC(1, THIS.FontName, THIS.FontSize)/8

 *====================================
 *-- cFrmMsgSvc::GetPercent( n)
 *====================================
 *
  FUNCTION GetPercent
    RETURN 0

 *====================================
 *-- cFrmMsgSvc::SetPercent( n)
 *====================================
 *
  FUNCTION SetPercent( tnPassed)
  IF TYPE( "THISFORM.oImageTimer")= "O" AND ;
    THISFORM.oImageTimer.Enabled

    *-- Force an image animation
    THISFORM.oImageTimer.Timer()

  ENDIF

 *====================================
 *-- cFrmMsgSvc::SetText( c)
 *====================================
 *
  FUNCTION SetText( tcPassed)
  IF TYPE( "THIS.oText") = "O" AND ;
     TYPE( "tcPassed") = "C"

     THIS.oText.Value= ALLTRIM(tcPassed)
  ENDIF


 *====================================
 *-- cFrmMsgSvc::Unload
 *====================================
 * Pass the return values up the tree
  FUNCTION Unload
    IF ! ISNULL( THIS.oReturnPointer)
      THIS.oReturnPointer.ReturnValue= THIS.aRetVals[ THIS.nReturnIndex]
    ENDIF
ENDDEFINE


*//////////////////////////////////////////////////////////////////////////////
* CLASS....: c F r m T h e r m M s g S v c
* Version..: March 31 1996
*//////////////////////////////////////////////////////////////////////////////
DEFINE CLASS cFrmThermMsgSvc AS cFrmMsgSvc
  Height= 100
  Width = 300
  WindowType= 0  && Modeless

*-- Custom properties
  Type= "Therm"
  cFirstLine= ""


 *====================================
 *-- cFrmThermMsgSvc::GetPercent( n)
 *====================================
 *
  FUNCTION GetPercent( tnPassed)
    IF TYPE( "THIS.oTherm") = "O" AND ;
       !ISNULL( THIS.oTherm)

       RETURN THIS.oTherm.GetPercent( )
    ELSE
      RETURN 0
    ENDIF


 *====================================
 *-- cFrmThermMsgSvc::SetPercent( n)
 *====================================
 *
  FUNCTION SetPercent( tnPassed)
    IF TYPE( "THIS.oTherm") = "O" AND ;
       !ISNULL( THIS.oTherm)

       cFrmMsgSvc::SetPercent()

       THIS.oTherm.SetPercent( tnPassed)
       IF TYPE( "THIS.oButtons")= "O"
         THIS.oButtons.Controls(1).SetFocus()
       ENDIF
    ENDIF

 *====================================
 *-- cFrmThermMsgSvc::SetText( c)
 *====================================
 *
  FUNCTION SetText( tcPassed)
    IF ISNULL( tcPassed)
      RETURN .NULL.
    ENDIF
    IF TYPE( "tcPassed") <> "C"
      RETURN .F.
    ENDIF
    Local lcPassed
    lcPassed= ALLTRIM( tcPassed)

    IF THIS.GetPercent()= 0
      THIS.cFirstLine= lcPassed
      tcPassed= ccCR_LF
    ENDIF


    IF ! EMPTY( THIS.cFirstLine)
      lcPassed= THIS.cFirstLine+ ;
                ccCR_LF+ ;
                tcPassed
    ENDIF

    cFrmMsgSvc::SetText( lcPassed)



ENDDEFINE

*//////////////////////////////////////////////////////////////////////////////
* CLASS....: c F r m W o r k i n g M s g S v c
* Version..: March 31 1996
*//////////////////////////////////////////////////////////////////////////////
DEFINE CLASS cFrmWorkingMsgSvc AS cFrmMsgSvc
  Height    = 100
  Width     = 300
  WindowType= 0  && Modeless
  Type      = "Working"
ENDDEFINE



*//////////////////////////////////////////////////////////////////////////////
* CLASS....: c F R M T O D M s g S v c
* Version..: April 3 1996
*//////////////////////////////////////////////////////////////////////////////
DEFINE CLASS cFrmTODMsgSvc AS cfrmMsgSvc
  ScaleMode  = 3
  Height     = 230
  Width      = 427
  DoCreate   = .T.
  AutoCenter = .T.
  BackColor  = RGB(192,192,192)
  BorderStyle= 2
  Caption    = "Tip Of The Day"
  FontSize   = 8
  MaxButton  = .F.
  MaxWidth   = 430
  MinButton  = .F.
  WindowType = 1
  WindowState= 0

  *-- The active workarea prior to TOD
  noldarea= 1
  Name    = "Tip"
  Type    = "Tip Of The Day"

  *-- Did we open TOD?
  ltodopened = .F.

  *-- Do we want random tips
  lRandomTip= .T.

  ADD OBJECT shape1 AS shape WITH ;
    BackColor    = RGB(192,192,192), ;
    Height       = 185, ;
    Left         = 12, ;
    Top          = 12, ;
    Width        = 301, ;
    SpecialEffect= 0, ;
    Name         = "Shape1"

  ADD OBJECT shape2 AS shape WITH ;
    BackColor  = RGB(255,255,255), ;
    BorderStyle= 1, ;
    Height     = 171, ;
    Left       = 19, ;
    Top        = 19, ;
    Width      = 287, ;
    Name       = "Shape2"

  ADD OBJECT cmdOk AS cTODButton WITH ;
    Top     = 12, ;
    Left    = 325, ;
    Caption = ccOK, ;
    Name    = "cmdOk"


  ADD OBJECT cmdNextTip AS cTODButton WITH ;
    Top     = 41, ;
    Left    = 325, ;
    Caption = "\<Next Tip...", ;
    Name    = "cmdNextTip"


  ADD OBJECT cmdMoreTips AS cTODButton WITH ;
    Top     = 80, ;
    Left    = 325, ;
    Caption = "\<More Tips", ;
    Name    = "cmdMoreTips"


  ADD OBJECT cmdHelp AS cTODButton WITH ;
    Top     = 109, ;
    Left    = 325, ;
    Caption = "\<Help", ;
    Name    = "cmdHelp"


  ADD OBJECT check1 AS checkbox WITH ;
    Top      = 203, ;
    Left     = 12, ;
    Height   = 18, ;
    Width    = 300, ;
    FontName = "MS Sans Serif", ;
    FontSize = 8, ;
    FontBold = .F., ;
    BackColor= RGB(192,192,192), ;
    Caption  = "\<Show Tips at Startup", ;
    Name     = "Check1"

  ADD OBJECT edit1 AS editbox WITH ;
    BackColor    = RGB(255,255,255), ;
    BackStyle    = 0, ;
    BorderStyle  = 0, ;
    FontName     = "MS Sans Serif", ;
    FontSize     = 8, ;
    FontBold     = .F., ;
    Height       = 122, ;
    Left         = 25, ;
    Top          = 66, ;
    Width        = 275, ;
    SpecialEffect= 1, ;
    ReadOnly     = .T., ;
    ScrollBars   = 0, ;
    TabStop      = .F., ;
    Name         = "Edit1"


  ADD OBJECT label1 AS clblMsgSvc WITH ;
    FontName= "MS Sans Serif", ;
    FontSize= 8, ;
    FontBold= .T., ;
    Caption = "Did you know...", ;
    Height  = 18, ;
    Left    = 65, ;
    Top     = 38, ;
    Width   = 200, ;
    Name    = "Label1"


  ADD OBJECT image1 AS image WITH ;
    Picture= "tod.bmp", ;
    Height = 40, ;
    Left   = 24, ;
    Top    = 24, ;
    Width  = 39, ;
    Name   = "Image1"


  PROCEDURE Load
    THIS.nOldArea=SELECT()
    SELECT *, " " AS Temp FROM MsgSvc ;
      INTO CURSOR __Tod ;
     WHERE UPPER(cKey) = "TIP"


  FUNCTION Init
    THIS.Edit1.BackStyle=1
    IF THIS.lRandomTip
      LOCAL lnRecords
      =RAND(-1)
      lnRecords=RAND()* RECCOUNT("__Tod")

      SKIP INT(lnRecords) IN __Tod
      IF EOF()
        GO BOTTOM
      ENDIF
    ENDIF
      THIS.Edit1.Controlsource= "__TOD.cOriginal"

    *? Kluge
    THIS.Edit1.BackStyle=0

  PROCEDURE Destroy
    SELECT (THIS.nOldArea)
    IF THIS.lTODOpened
      USE IN __Tod
    ENDIF



  PROCEDURE cmdOk.Click
    RELEASE THISFORM


  PROCEDURE cmdNextTip.Click
    LOCAL lnOldArea
    lnOldArea= SELECT()
    SELECT __Tod
    SKIP
    IF EOF()
      LOCATE
    ENDIF
    SELECT (lnOldArea)
    THISFORM.REFRESH


  PROCEDURE cmdMoreTips.Click
    =MsgSvc("Subclass to suit")

  PROCEDURE check1.Interactivechange( tnIndex)
    =MsgSvc("Subclass to suit")

  PROCEDURE cmdHelp.Click
    Help

ENDDEFINE

*//////////////////////////////////////////////////////////////////////////////
* CLASS....: c P a c k a g e
*          : This class serves as a holder (package) of other objects so
*          : that several object references can be passed as one object.
*
* Pattern  : COMPOSITE
*
* Version..: April 6 1996
*//////////////////////////////////////////////////////////////////////////////
DEFINE CLASS cPackage AS Relation  && A lightweight.
  DIMENSION aItems[1,2]
  Itemcount= 0
  cClassId= "Package"

 *====================================
 *-- cPackage::Init
 *====================================
 *
 *
  FUNCTION Init
    THIS.aItems[1]= .NULL.
    THIS.aItems[2]= .NULL.

 *====================================
 *-- cPackage::GetItem(c)
 *====================================
 * Return the first item of a given type.
 *
  FUNCTION GetItem( tcType)
    IF ISNULL( tcType)
      RETURN .NULL.
    ENDIF

    LOCAL lcRetVal, lcType, lnHit

    lcRetVal= []
    IF TYPE( "tcType") <> "C"
      RETURN lcRetVal
    ENDIF

    lcType= PROPER( ALLTRIM( tcType))
    lnHit= ASCAN( THIS.aItems, lcType)
    IF lnHit> 0
      RETURN THIS.aItems[ lnHit+1]
    ELSE
      RETURN lcRetVal
    ENDIF

 *====================================
 *-- cPackage::AddItem(cx)
 *====================================
 * Add an item to this package
 *
  FUNCTION AddItem( tcType, txItem )
    LOCAL llRetVAal

    IF ISNULL( tcType) OR ISNULL( txItem)
      RETURN .NULL.
    ENDIF

    llRetVal= .F.

    IF EMPTY( tcType) OR ;
       TYPE( "tcType") <> "C"

      RETURN llRetVal
    ENDIF

    LOCAL lnFound, lntemp
    lnFound=ASCAN( THIS.aItems, tcType)
    IF lnFound > 0
      THIS.aItems( lnFound+1)= txItem
    ELSE
      IF ISNULL( THIS.aItems[ 1])
        lnTemp= 0
      ELSE
        lnTemp= ALEN( THIS.aItems)
        DIMENSION THIS.aItems[ lnTemp+ 2]