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

Pascal/Delphi Source File | 1990-04-04 | 8.4 KB | 305 lines

{$V-}

(*

   WFIELD2
   -------
   This program is an example of a directory list (DirList) embedded within a
   data entry screen. The effect is somewhat like that of a "dialog box."
   Points worth noting:

     1) The pre-edit routine prevents the directory list from being activated
        when there are no files to be selected. That can't happen in this
        program, because the diShowDrives option is used, but it could happen
        if diShowDrives were not in use.

     2) The post-edit routine manages the interaction between the two fields
        that make up the entry screen. When a file is selected with the
        DirList, it loads the filename into the variable associated with the
        string field. If the user presses <Enter> (ccSelect) on the string
        field, it checks to see if the string entered is a real or potential
        filename. If so, it tells the entry screen to exit. If not, it checks
        to see if the user modified the field; if he did, the mask for the
        DirList is set to match what was entered.

     3) By deactivating the efAllowEscape option before calling AddWindowField,
        we tell OPENTRY to treat the ccQuit command (<Esc>) as equivalent
        to ccNextField when it is issued within the DirList.

     4) By activating the sefSwitchCommands option before calling
        AddWindowField, we tell OPENTRY to make the DirList use the same
        CommandProcessor as the EntryScreen. This allows commands such as
        ccTab, which normally have no meaning in a DirList, to produce the
        same effects that they have when issued within the EntryScreen itself.

     5) Notice how the wAltFrame option lets us "highlight" the DirList when
        it becomes active: the active frame has special headers; the inactive
        frame does not.

     6) The wNoCoversBuffer option is used for the DirList field to limit
        memory usage.

*)

program WFIELD2;

{$I OPDEFINE.INC}

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

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

{Color set used by entry screen}
const
  EsColors : ColorSet = (
    TextColor       : $1E;      TextMono        : $0F;
    CtrlColor       : $1E;      CtrlMono        : $0F;
    FrameColor      : $1F;      FrameMono       : $0F;
    HeaderColor     : $3F;      HeaderMono      : $70;
    ShadowColor     : $0B;      ShadowMono      : $0F;
    HighlightColor  : $4F;      HighlightMono   : $70;
    PromptColor     : $1B;      PromptMono      : $07;
    SelPromptColor  : $1F;      SelPromptMono   : $0F;
    ProPromptColor  : $1B;      ProPromptMono   : $07;
    FieldColor      : $1E;      FieldMono       : $0F;
    SelFieldColor   : $3E;      SelFieldMono    : $70;
    ProFieldColor   : $17;      ProFieldMono    : $07;
    ScrollBarColor  : $1B;      ScrollBarMono   : $07;
    SliderColor     : $1B;      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    : $3E;      SelItemMono     : $70;
    ProItemColor    : $17;      ProItemMono     : $07;
    HighItemColor   : $1F;      HighItemMono    : $0F;
    AltItemColor    : $1F;      AltItemMono     : $0F;
    AltSelItemColor : $3F;      AltSelItemMono  : $70;
    FlexAHelpColor  : $1F;      FlexAHelpMono   : $0F;
    FlexBHelpColor  : $1F;      FlexBHelpMono   : $0F;
    FlexCHelpColor  : $1B;      FlexCHelpMono   : $70;
    UnselXrefColor  : $1E;      UnselXrefMono   : $08;
    SelXrefColor    : $3F;      SelXrefMono     : $70;
    MouseColor      : $4F;      MouseMono       : $70
  );

{Entry field constants}
const
  idPathMask             = 0;
  idDirWin               = 1;

type
  UserRecord =
    record
      PathMask             : string[64];
    end;
var
  ES      : EntryScreen;
  UR      : UserRecord;
  Status  : Word;
  DL      : DirList;
  AllDone : Boolean;

{$F+}
procedure PreEdit(ESP : EntryScreenPtr);
  {-Called just before a field is edited}
begin
  with ESP^ do
    if GetCurrentID = idDirWin then
      if DL.GetMatchingFileCount = 0 then
        SetNextField(idPathMask);
end;

procedure PostEdit(ESP : EntryScreenPtr);
  {-Called just after a field has been edited}

  function AcceptFile(var S : string) : Boolean;
  begin
    S := FExpand(S);
    if (S[Length(S)] = '\') or IsDirectory(S) then begin
      S := AddBackSlash(S)+'*.*';
      AcceptFile := False;
    end
    else if ExistFile(S) then
      AcceptFile := True
    else
      AcceptFile := (S <> '') and (Pos('*', S) = 0) and (Pos('?', S) = 0);
  end;

begin
  with ESP^ do
    case GetCurrentID of
      idPathMask :
        if (GetLastCommand = ccSelect) and AcceptFile(UR.PathMask) then
          SetLastCommand(ccDone)
        else if CurrentFieldModified then begin
          DL.SetMask(FExpand(UR.PathMask), 0);
          DL.PreLoadDirList;
          Draw;
        end;
      idDirWin :
        if GetLastCommand = ccSelect then begin
          UR.PathMask := DL.GetSelectedPath;
          DrawField(idPathMask);
        end;
    end;
end;
{$F-}

function InitEntryScreen : Word;
  {-Initialize entry screen generated by MAKESCRN}
const
  WinOptions = wBordered+wClear+wUserContents;
begin
  with ES do begin
    if not InitCustom(20, 6, 57, 18, EsColors, WinOptions) then begin
      InitEntryScreen := InitStatus;
      Exit;
    end;

    wFrame.AddShadow(shBR, shOverWrite);

    SetWrapMode(WrapAtEdges);

    SetPreEditProc(PreEdit);
    SetPostEditProc(PostEdit);

    esFieldOptionsOn(efClearFirstChar);

  {idPathMask:}
    AddSimpleStringField(
      'File:', 1, 3,
      'X', 1, 9, 28, 64,
      1, UR.PathMask);

  {idDirWin}
    esFieldOptionsOff(efAllowEscape);
    esSecFieldOptionsOn(sefSwitchCommands);
    AddWindowField(
      '', 2, 3,
      2, 3,
      2, DL);

    InitEntryScreen := RawError;
  end;
end;

function InitDirList : Word;
  {-Initialize directory list}
const
  WinOptions = wBordered+wAltFrame+wClear+wUserContents+wNoCoversBuffer;
begin
  with DL do begin
    if not InitCustom(
      23, 8, 54, 17, EsColors, WinOptions,
      20000, PickSnaking, SingleFile) then begin
        InitDirList := InitStatus;
        Exit;
      end;

    AddMaskHeader(True, 1, Width, heTC);

    AddMoreHeader(' || ', heBR, #27, #26, '', 2, 3, 0);

    aFrame.SetFrameAttr($1B, $07);

    SetPadSize(1, 0);
    SetSortOrder(SortDirName);

    diOptionsOn(diShowDrives);
    SetMask('*.*', Directory);
    PreLoadDirList;

    InitDirList := RawError;
  end;
end;

begin
  ClrScr;

  DefWindowFrame := SglWindowFrame;

  {initialize user record}
  UR.PathMask := '*.*';

  {initialize directory list}
  Status := InitDirList;
  if Status <> 0 then begin
    WriteLn('Error initializing DirList: ', Status);
    Halt(1);
  end;

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

  {$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);
      PickCommands.cpOptionsOn(cpEnableMouse);
    end;
  {$ENDIF}

  AllDone := False;
  repeat
    ES.Process;
    case ES.GetLastCommand of
      ccDone :
        AllDone := True;
      ccError, ccQuit :
        begin
          AllDone := True;
          UR.PathMask := '';
        end;
    end;
  until AllDone;

  {$IFDEF UseMouse}
  HideMouse;
  {$ENDIF}

  ES.Erase;

  {show exit command and selection}
  ClrScr;
  WriteLn('Exit command = ', ES.GetLastCommand);
  if UR.PathMask <> '' then
    WriteLn('Selection    = ', UR.PathMask);

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