Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/OPBONUS.ZIP/WFIELD.LZH/WFIELD4.PAS

Pascal/Delphi Source File | 1990-10-02 | 18.5 KB | 668 lines

{$V-}

(*
   WFIELD4
   -------
   This program demonstrates several neat tricks made possible by the features
   added in Object Professional 1.01:

     - a menu embedded within another object derived from a command window
     - a scrolling entry screen embedded within a regular entry screen
     - storing a parent window and all its children within a stream
     - reloading a parent window and its children from a stream

   Points worth noting:

   1) Defining TestStream (by removing the '.' before the '$') causes the
      program to be compiled in such a way that the entry screen and all its
      children are instantiated, stored in the stream, then reinstantiated by
      rereading them from the stream. Note, however, that SES and MM are no
      longer valid objects once ES has been reread from the stream. Child
      windows are always allocated dynamically on the heap when they are read
      back from the stream. That's why the pointer variable 'MP^' is used to
      refer to the menu, rather than 'MM'.

   2) The scrolling entry screen (the child) is attached to the main entry
      screen (the parent) using AddWindowField. The menu is not a field,
      however, so it must be attached using the AddChild method.

   3) The menu can be activated/deactivated by pressing <F10>. In this
      do-nothing demo, selecting any menu item button outside the menu simply
      returns you to where you were before the menu was activated. Clicking
      the left mouse button outside the menu also returns you to where you
      were before, unless the mouse was clicked on a particular field. Notice
      that EraseAllSubMenus must be called when the menu is deactivated to
      insure that the submenus don't get overwritten by one of the fields in
      the parent entry screen.

   4) From within the main entry screen, the mouse can be used to select
      the child window, the menu, the "exit" hot spot, as well as any field
      in the entry screen. Note, however, that when you "jump" into the child
      entry screen, the cursor moves to the field in the entry screen that was
      current the last time you left.

   5) Notice that the InvokeMenu routine calls EntryScreen.EvaluateCommand,
      which according to the manual is supposed to be called only from within
      a post-edit routine. In general, the manual is correct on that point,
      but in the case of ccMouseSel it is safe to evaluate the command outside
      of a post-edit routine.

   6) The scrolling entry screen is both a field in the main entry screen and
      an entry screen in its own right. You can move in and out of the main
      entry screen using the basic field movement commands (<Enter>, <Tab>,
      <ShTab>, <Up>, <Down>), but once you are in the child entry screen the
      other field movement commands (<PgUp>, <PgDn>, <CtrlPgUp>, <CtrlPgDn>)
      are restricted to moving the cursor around the child window.

   7) In the scrolling entry screen, the Total field on each row is a
      protected field whose value is calculated dynamically by the post-edit
      routine.

   8) The wNoCoversBuffer option is used for the ScrollingEntryScreen field
      to limit memory usage.

*)

{.$DEFINE TestStream}

program WFIELD4;

{$I OPDEFINE.INC}

uses
  Dos,
  OpInline,
  OpString,
  OpRoot,
  OpCrt,
  {$IFDEF UseMouse}
  OpMouse,
  {$ENDIF}
  OpAbsFld,
  OpCmd,
  OpField,
  OpFrame,
  OpWindow,
  OpSelect,
  OpEntry,
  OpMenu;

  {$IFDEF UseMouse}
const
  MouseChar  : Char = #04;
  {$ENDIF}

{Color set used by entry screen}
const
  EsColors : ColorSet = (
    TextColor       : $1A; TextMono        : $0F;
    CtrlColor       : $1E; CtrlMono        : $08;
    FrameColor      : $1A; FrameMono       : $0F;
    HeaderColor     : $1F; HeaderMono      : $70;
    ShadowColor     : $08; ShadowMono      : $0F;
    HighlightColor  : $4F; HighlightMono   : $70;
    PromptColor     : $1F; PromptMono      : $0F;
    SelPromptColor  : $1F; SelPromptMono   : $0F;
    ProPromptColor  : $17; ProPromptMono   : $07;
    FieldColor      : $1A; FieldMono       : $07;
    SelFieldColor   : $2F; SelFieldMono    : $70;
    ProFieldColor   : $1B; ProFieldMono    : $07;
    ScrollBarColor  : $13; ScrollBarMono   : $07;
    SliderColor     : $13; SliderMono      : $0F;
    HotSpotColor    : $30; HotSpotMono     : $70;
    BlockColor      : $3E; BlockMono       : $0F;
    MarkerColor     : $3F; MarkerMono      : $70;
    DelimColor      : $1E; DelimMono       : $0F;
    SelDelimColor   : $31; SelDelimMono    : $0F;
    ProDelimColor   : $1E; ProDelimMono    : $0F;
    SelItemColor    : $2F; SelItemMono     : $70;
    ProItemColor    : $17; ProItemMono     : $07;
    HighItemColor   : $1F; HighItemMono    : $0F;
    AltItemColor    : $1F; AltItemMono     : $0F;
    AltSelItemColor : $2F; AltSelItemMono  : $70;
    FlexAHelpColor  : $1F; FlexAHelpMono   : $0F;
    FlexBHelpColor  : $1F; FlexBHelpMono   : $0F;
    FlexCHelpColor  : $1B; FlexCHelpMono   : $70;
    UnselXrefColor  : $1E; UnselXrefMono   : $09;
    SelXrefColor    : $5F; SelXrefMono     : $70;
    MouseColor      : $4F; MouseMono       : $70);

{Entry field constants}
const
  idAcctNo               = 0;
  idName                 = 1;
  idCompany              = 2;
  idAddress              = 3;
  idCity                 = 4;
  idState                = 5;
  idZipCode              = 6;
  idPhone                = 7;
  idEntries              = 8;

  {these ID's are relative to the ID for the first field on a given row--see
   PostEdit, below}
  idQuantity             = 0;
  idCost                 = 1;
  idDescription          = 2;
  idTotal                = 3;

  {Child window indexes}
  cwMenu                 = 1;
  cwSEntry               = 2;

{Menu item constants}
const
  miCalculate1    = 1;
  miGross2        = 2;
  miNet3          = 3;
  miSearch4       = 4;
  miAcct5         = 5;
  miName6         = 6;
  miCompany7      = 7;
  miAddress8      = 8;
  miCity9         = 9;
  miState10       = 10;
  miZip11         = 11;
  miPhone12       = 12;
  miHelp13        = 13;
  miQuit14        = 14;

const
  MaxEntries = 50;
type
  UserRecord =
    record
      AcctNo               : string[13];
      Name                 : string[30];
      Company              : string[35];
      Address              : string[35];
      City                 : string[25];
      State                : string[15];
      ZipCode              : string[10];
      Phone                : string[14];
    end;
  EntryRec =
    record
      Quantity             : Word;
      Cost                 : Real;
      Description          : string[20];
      Total                : Real;
    end;
  UserEntries = array[1..MaxEntries] of EntryRec;
var
  SES      : ScrollingEntryScreen;
  ES       : EntryScreen;
  MM       : Menu;
  MP       : ^Menu;
  UR       : UserRecord;
  UE       : UserEntries;
  I        : Word;
  Status   : Word;
  FramePos : FramePosType;
  HotCode  : Byte;
  BarPos   : LongInt;
  Quit     : Boolean;
  XAbs     : Integer;
  YAbs     : Integer;
  {$IFDEF TestStream}
  S      : BufIdStream;
  {$ENDIF}

function InitMenu(var M : Menu) : Word;
  {-Initialize menu system generated by MAKEMENU}
const
  Frame1 : FrameArray = '╥╚╥╝─═║║';
  WinOptions = wClear+wUserContents+wAllMouseEvents;
begin
  with M do begin
    if not InitCustom(14, 4, 66, 4, EsColors, WinOptions, Horizontal) then begin
      InitMenu := InitStatus;
      Exit;
    end;

    mnOptionsOn(
      mnAlphaMatch+mnSelectOnMatch+mnAllowPending+mnArrowSelect+mnAllHotSpots);
    mnOptionsOff(
      mnPopOnSelect+mnUseItemForTopic+mnMainSelect+mnSelectOnClick);

    AddItem(' Calculate ', 2, 2, miCalculate1);
      AddFramedSubMenu(16, 6, 22, 7, Vertical, Frame1);
      AddItem('Gross', 1, 1, miGross2);
      AddItem('Net', 2, 1, miNet3);
      ItemsDone;
    AddItem(' Search ', 14, 2, miSearch4);
      AddFramedSubMenu(28, 6, 37, 13, Vertical, Frame1);
      AddItem('Acct #', 1, 1, miAcct5);
      AddItem('Name', 2, 1, miName6);
      AddItem('Company', 3, 1, miCompany7);
      AddItem('Address', 4, 1, miAddress8);
      AddItem('City', 5, 1, miCity9);
      AddItem('State', 6, 1, miState10);
      AddItem('Zip code', 7, 1, miZip11);
      AddItem('Phone', 8, 1, miPhone12);
      ItemsDone;
    AddItem(' Help ', 23, 2, miHelp13);
    AddItem(' Quit ', 30, 2, miQuit14);
    ItemsDone;

    InitMenu := RawError;
  end;
end;

{$F+}
procedure PostEdit(ESP : EntryScreenPtr);
  {-Called just after a field has been edited}
var
  Row : Word;
begin
  with ESP^ do
    {do nothing if user didn't change the field}
    if CurrentFieldModified then begin
      {calculate the current row}
      Row := Succ(GetCurrentID div 4);

      {which column is it?}
      case GetCurrentID mod 4 of
        {was the cost or quantity changed?}
        idQuantity, idCost :
          with UE[Row] do begin
            {calculate Total for this row}
            if (Quantity = 0) or (Cost = BadReal) then
              Total := BadReal
            else
              Total := Quantity*Cost;

            {update the Total field for this row}
            DrawField((Pred(Row)*4)+idTotal);
          end;
      end;
    end;
end;
{$F-}

function InitScrollingEntryScreen : Word;
  {-Initialize the scrolling entry screen}
const
  WinOptions = wClear+wUserContents+wAllMouseEvents+wNoCoversBuffer;
var
  Row : Word;
begin
  with SES do begin
    if not InitCustom(14, 16, 66, 21, EsColors, WinOptions) then begin
      InitScrollingEntryScreen := InitStatus;
      Exit;
    end;

    {stop at the bottom of the entry screen, but allow exiting at the top}
    SetWrapMode(ExitAtTop);

    {install post-edit routine to handle the calculated field}
    SetPostEditProc(PostEdit);

    esFieldOptionsOn(efClearFirstChar);
    for Row := 1 to MaxEntries do
      with UE[Row] do begin
        {idQuantity:}
          esFieldOptionsOn(efRightJustify);
          esSecFieldOptionsOn(sefSuppressZero);
          AddWordField(
            LeftPad(Long2Str(Row), 2), Row, 2,
            '999', Row, 6,
            9, 0, 65535, Quantity);
          esFieldOptionsOff(efRightJustify);
          esSecFieldOptionsOff(sefSuppressZero);

        {idCost:}
          esFieldOptionsOn(efRightJustify);
          AddRealField(
            '', Row, 11,
            '$999.99', Row, 11,
            10, -1.5E+38,  1.5E+38, 0, Cost);
          esFieldOptionsOff(efRightJustify);

        {idDescription:}
          AddStringField(
            '', Row, 20,
            'XXXXXXXXXXXXXXXXXXXX', Row, 20, 20,
            11, Description);

        {idTotal:}
          esFieldOptionsOn(efRightJustify+efProtected);
          AddRealField(
            '', Row, 42,
            '$999,999.99', Row, 42,
            12, -1.5E+38,  1.5E+38, 0, Total);
          esFieldOptionsOff(efRightJustify+efProtected);
      end;

    {allocate the virtual screen}
    AllocateScreen;

    InitScrollingEntryScreen := RawError;
  end;
end;

function InitEntryScreen : Word;
  {-Initialize main entry screen}
const
  Frame1 = '┌└┐┘──││';
  WinOptions = wBordered+wClear+wUserContents+wAllMouseEvents;
begin
  with ES, EsColors do begin
    if not InitCustom(14, 6, 66, 21, EsColors, WinOptions) then begin
      InitEntryScreen := InitStatus;
      Exit;
    end;

    {make room for the menu up at the top}
    with wFrame do
      AdjustFrameCoords(frXL, frYL-2, frXH, frYH);

    {add the menu as a regular child window, not a field}
    AddChild(@MM);

    wFrame.SetFrameType(Frame1);
    wFrame.AddShadow(shBR, shSeeThru);
    wFrame.AddHeader(' Customer Data ', heTC);

  {$IFDEF UseHotSpots}
    {add a hot spot at the top left corner}
    wFrame.AddCustomHeader('[',   frTL,  1, 0, FrameColor, FrameMono);
    wFrame.AddCustomHeader('■', frTL,  2, 0, FrameColor, FrameMono);
    wFrame.AddCustomHeader(']',   frTL,  3, 0, FrameColor, FrameMono);
    wFrame.AddHotRegion(frTL, hsRegion0, 2, 0, 1, 1);   {Close}
  {$ENDIF}

    {separate the menu from the main entry screen}
    wFrame.AddSpanHeader('├', '─', '┤', 02, frTT);

    {separate the child entry screen from the parent}
    wFrame.AddSpanHeader('├', '─', '┤', 11, frTT);

    {label the columns of the scrollable entry screen}
    AddTextFieldCustom(
      'Qty    Cost   Description                 Total', 10, 6,
      HeaderColor, HeaderMono);

    {don't wrap at edges of the entry screen}
    SetWrapMode(StopAtEdges);

    esFieldOptionsOn(efClearFirstChar);

  {idAcctNo:}
    AddStringField(
      'Acct #', 1, 4,
      '999-99-9999-9', 1, 12, 13,
      1, UR.AcctNo);

  {idName:}
    AddStringField(
      'Name', 2, 6,
      CharStr('x', 30), 2, 12, 30,
      2, UR.Name);

  {idCompany:}
    AddStringField(
      'Company', 3, 3,
      CharStr('x', 35), 3, 12, 35,
      3, UR.Company);

  {idAddress:}
    AddStringField(
      'Address', 4, 3,
      CharStr('x', 35), 4, 12, 35,
      4, UR.Address);

  {idCity:}
    AddStringField(
      'City', 5, 6,
      CharStr('x', 25), 5, 12, 25,
      5, UR.City);

  {idState:}
    AddStringField(
      'State', 6, 5,
      'xxxxxxxxxxxxxxx', 6, 12, 15,
      6, UR.State);

  {idZipCode:}
    AddStringField(
      'Zip code', 7, 2,
      '99999-9999', 7, 12, 10,
      7, UR.ZipCode);

  {idPhone:}
    AddStringField(
      'Phone', 8, 5,
      '[phone]', 8, 12, 14,
      8, UR.Phone);

  {idEntries:}
    AddWindowField(
      '', 11, 1,
      11, 1,
      9, SES);

    InitEntryScreen := RawError;
  end;
end;

procedure InvokeMenu;
  {-Invoke the menu}
var
  SaveChild : WindowPtr;
  ID, Cmd : Word;
begin
  {save the active child window}
  SaveChild := ES.ActiveChild;

  {activate the menu}
  ES.SetActiveChild(MP);

  {get a choice from the menu, which is now the active child}
  ES.Process;

  Cmd := ES.GetLastCommand;
  case Cmd of
    ccSelect :
      Quit := (MP^.MenuChoice = miQuit14);
    {$IFDEF UseMouse}
    ccMouseDown,
    ccMouseSel :
      begin
        {get absolute mouse coordinates}
        XAbs := MouseKeyWordX+MouseXLo;
        YAbs := MouseKeyWordY+MouseYLo;

        {evaluate the position of the mouse when it was clicked}
        ES.EvaluatePos(XAbs, YAbs);
        BarPos := ES.PosResults(FramePos, HotCode);

        {was it clicked on the hot spot?}
        if HotCode = hsRegion0 then
          Quit := True
        else
          ES.SetNextField(ES.EvaluateCommand(Cmd));
      end;
    {$ENDIF}
  end;

  if not Quit then begin
    {erase the menu}
    MP^.EraseAllSubMenus(False, True);

    {restore the active child}
    ES.SetActiveChild(SaveChild);
  end;
end;

{$IFDEF TestStream}

procedure RegisterTypes(var S : IdStream);
  {-Register data types and pointers}
begin
  {register entry screen}
  S.RegisterHier(ScrollingEntryScreenStream);

  {register field types}
  S.RegisterHier(RealFieldStream);
  S.RegisterHier(StringFieldStream);
  S.RegisterHier(WordFieldStream);
  S.RegisterHier(WindowFieldStream);

  {register user records}
  S.RegisterPointer(1000, @UR);
  S.RegisterPointer(1001, @UE);

  {register user-written routines}
  S.RegisterPointer(1002, @PostEdit);

  {register the menu system}
  S.RegisterHier(MenuStream);
end;

{$ENDIF}

begin
  {initialize user records}
  FillChar(UR, SizeOf(UR), 0);
  FillChar(UE, SizeOf(UE), 0);
  for I := 1 to MaxEntries do
    with UE[I] do begin
      Cost := BadReal;
      Total := BadReal;
    end;

  {initialize menu}
  Status := InitMenu(MM);
  if Status <> 0 then begin
    WriteLn('MM init error: ', Status);
    Halt(1);
  end;

  {initialize scrolling entry screen}
  Status := InitScrollingEntryScreen;
  if Status <> 0 then begin
    WriteLn('SES init error: ', Status);
    Halt(1);
  end;

  {initialize main entry screen}
  Status := InitEntryScreen;
  if Status <> 0 then begin
    WriteLn('ES init error: ', Status);
    Halt(1);
  end;

{$IFDEF TestStream}

  {set user record for both entry screens}
  ES.SetUserRecord(UR, SizeOf(UR));
  SES.SetUserRecord(UE, SizeOf(UE));

  {create stream file}
  S.Init('WFIELD4.STM', SCreate, 4096);

  {register types and store the entry screen}
  RegisterTypes(S);
  S.Put(ES);
  Status := S.GetStatus;
  if Status <> 0 then begin
    WriteLn('Store error: ', Status);
    Halt(2);
  end;
  S.Done;

  {dispose of the parent *and* its children}
  ES.Done;

  {reopen stream file}
  S.Init('WFIELD4.STM', SOpen, 4096);

  {register types and load the entry screen}
  RegisterTypes(S);
  S.Get(ES);
  Status := S.GetStatus;
  if Status <> 0 then begin
    WriteLn('Load error: ', Status);
    Halt(3);
  end;
  S.Done;

  {get index for child window}
  MP := MenuPtr(ES.ChildPtr(cwMenu));
{$ELSE}
  MP := @MM;
{$ENDIF}

  {clear the screen}
  TextChar := #178;
  TextAttr := 7;
  ClrScr;

  {F10 activates menu}
  EntryCommands.AddCommand(ccUser0, 1, $4400, 0);

  {F10 deactivates menu}
  MenuCommands.AddCommand(ccQuit, 1, $4400, 0);

  {$IFDEF UseMouse}
  if MouseInstalled then
    with EsColors do begin
      {activate mouse cursor}
      SoftMouseCursor($0000, (ColorMono(MouseColor, MouseMono) shl 8)+
                             Byte(MouseChar));
      ShowMouse;

      {enable mouse support}
      EntryCommands.cpOptionsOn(cpEnableMouse);
      MenuCommands.cpOptionsOn(cpEnableMouse);
    end;
  {$ENDIF}

  {test entry screen}
  Quit := False;
  repeat
    ES.Process;
    case ES.GetLastCommand of
      ccUser0 :
        InvokeMenu;
      {$IFDEF UseMouse}
      ccMouseDown,
      ccMouseSel :
        begin
          {get absolute mouse coordinates}
          XAbs := MouseKeyWordX+MouseXLo;
          YAbs := MouseKeyWordY+MouseYLo;

          {evaluate the position of the mouse when it was clicked}
          ES.EvaluatePos(XAbs, YAbs);
          BarPos := ES.PosResults(FramePos, HotCode);

          {was it clicked on one of the menu choices?}
          if (FramePos = frInsideFrame) and MP^.SelectItemByPos(XAbs, YAbs) then
            InvokeMenu
          else
            {was it clicked on the hot spot?}
            Quit := (HotCode = hsRegion0);
        end;
      {$ENDIF}
      else Quit := True;
    end;
  until Quit;

  {erase entry screen}
  ES.Erase;

  {$IFDEF UseMouse}
  HideMouse;
  {$ENDIF}

  {show exit command}
  ClrScr;
  WriteLn('Exit command = ', ES.GetLastCommand);

  {dispose of the parent *and* its children}
  ES.Done;
end.