Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/OPSPRD.ZIP/OPSPREAD.PAS

Pascal/Delphi Source File | 1992-10-19 | 18.4 KB | 596 lines

{$R-,S-,I-,V-,B-,F+,O+,A-}

{Conditional defines that may affect this unit}
{$I OPDEFINE.INC}

{*********************************************************}
{*                   OPSPREAD.PAS 1.20                   *}
{*        Copyright (c) TurboPower Software 1992.        *}
{*                 All rights reserved.                  *}
{*********************************************************}

unit OpSpread;
  {-Spreadsheet-like pick lists}

interface

uses
  OpInline,
  OpString,
  OpConst, {!!.20}
  OpRoot,
  OpCrt,
  {$IFDEF UseMouse}
  OpMouse,
  {$ENDIF}
  OpCmd,
  OpFrame,
  OpWindow,
  {$IFDEF UseDrag}
  OpDrag,
  {$ENDIF}
  OpPick;

const
  {---- Orientation code for a SpreadList ----}
  pkSpread          = 4;

  {---- Stream codes for a SpreadList ----}
  otSpreadList      = 998;
  veSpreadList      = 0;
  ptPickSpread      = 998;

type
  SpreadListPtr = ^SpreadList;
  SpreadList =
    object(PickList)
      slRows : Word;
      slCols : Word;

      constructor Init(X1, Y1, X2, Y2 : Byte;
                       ItemWidth : Byte;
                       NumRows : Word;
                       NumCols : Word;
                       StringProc : pkStringProc;
                       CommandHandler : pkGenlProc);
        {-Initialize a spreadsheet list}
      constructor InitCustom(X1, Y1, X2, Y2 : Byte;
                             var Colors : ColorSet;
                             Options : LongInt;
                             ItemWidth : Byte;
                             NumRows : Word;
                             NumCols : Word;
                             StringProc : pkStringProc;
                             CommandHandler : pkGenlProc);
        {-Initialize a spreadsheet list with custom window options}
      constructor InitAbstract(X1, Y1, X2, Y2 : Byte;
                               var Colors : ColorSet;
                               Options : LongInt;
                               ItemWidth : Byte;
                               NumRows : Word;
                               NumCols : Word;
                               CommandHandler : pkGenlProc);
         {-Constructor to be called by derived types that override
           the ItemString method}
      constructor InitDeluxe(X1, Y1, X2, Y2 : Byte;
                             var Colors : ColorSet;
                             Options : LongInt;
                             ItemWidth : Byte;
                             NumRows : Word;
                             NumCols : Word;
                             StringProc : pkStringProc;
                             CommandHandler : pkGenlProc;
                             PickOptions : Word);
        {-Initialize a spread list with custom window and pick options}
      constructor InitAbstractDeluxe(X1, Y1, X2, Y2 : Byte;
                                     var Colors : ColorSet;
                                     Options : LongInt;
                                     ItemWidth : Byte;
                                     NumRows : Word;
                                     NumCols : Word;
                                     CommandHandler : pkGenlProc;
                                     PickOptions : Word);
         {-Constructor to be called by derived types that override the
           ItemString method, with custom pick options}

      function GetItemRow(Item : Word) : Word;
        {-Return the absolute row position of the item}
      function GetItemCol(Item : Word) : Word;
        {-Return the absolute column position of the item}
      function GetItemNum(Row, Col : Word) : Word;
        {-Return the item number corresponding to Row and Col}
      procedure TopLeftRowCol(var Row, Col : Word);
        {-Return the Row and Col of the top left item}

      {-These routines generate an error in a SpreadList}
      procedure ChangeNumItems(NumItems : Word);
        {-Change the number of items to display}
      procedure ChangeOrientation(Orientation : pkGenlProc);
        {-Change the orientation}

    {$IFDEF UseStreams}
      constructor Load(var S : IdStream);
        {-Load a spread list from a stream}
      procedure Store(var S : IdStream);
        {-Store a spread list in a stream}
    {$ENDIF}

      {++++ for internal use ++++}
      {.Z+}
      procedure pkInitPickSize1; virtual;
      function pkProcessCursorCommand(var Cmd : Word) : Boolean; virtual;
      {.Z-}
    end;

{$IFDEF UseStreams}
  {---- Stream registration ----}
  procedure SpreadListStream(SPtr : IdStreamPtr);
    {-Register all types needed for streams containing spread lists}
{$ENDIF}

  {.Z+}
  {---- Orientation routine used for spread lists ----}
  procedure PickSpread(P : PickListPtr);
    {-Orientation initialization for spreadsheet-like picklists}
  {.Z-}

  {====================================================================}

implementation

function GetSpread(First, Row, Col : Word; P : PickListPtr) : Word;
  {-Get item number given <First, Row, Col>}
begin
  with SpreadListPtr(P)^ do
    GetSpread := First+(Col-1)+(Row-1)*slCols;
end;

procedure SetSpread(Choice, First : Word; P : PickListPtr);
  {-Set valid <pkFirst, pkRow, pkCol> given Choice and First}
var
  FirstRow : Word;
  FirstCol : Word;
begin
  with SpreadListPtr(P)^ do begin
    pkChoice := Choice;
    pkFirst := First;
    pkCommonValidation;

    {Force pkFirst into a valid range}
    FirstRow := GetItemRow(pkFirst);
    if FirstRow+pkHeight-1 > pkItemRows then begin
      dec(pkFirst, (FirstRow+pkHeight-1-pkItemRows)*slCols);
      FirstRow := GetItemRow(pkFirst);
    end;
    FirstCol := GetItemCol(pkFirst);
    if FirstCol+pkCols-1 > slCols then begin
      dec(pkFirst, FirstCol+pkCols-1-slCols);
      FirstCol := GetItemCol(pkFirst);
    end;

    {Assure pkFirst is in a range to make pkChoice visible}
    {And compute row and column}
    pkRow := GetItemRow(pkChoice)-FirstRow+1;
    if pkRow > pkHeight then begin
      inc(pkFirst, (pkRow-pkHeight)*slCols);
      pkRow := pkHeight;
    end;
    pkCol := GetItemCol(pkChoice)-FirstCol+1;
    if pkCol > pkCols then begin
      inc(pkFirst, pkCol-pkCols);
      pkCol := pkCols;
    end;
  end;
end;

procedure ReinitSpread(P : PickListPtr);
  {-Reinitialize some fields based on width, height and orientation}
var
  MaxRow : Word;
  MaxCol : Word;
begin
  with SpreadListPtr(P)^ do begin
    {pkMaxFirst controls how much scrolling, if any, is possible}
    pkMaxFirst := (pkItemRows-pkHeight)*slCols+(slCols-pkCols+1);

    {Amount to change pkFirst by when scrolling (not used)}
    pkScroll := 1;

    {$IFDEF UseScrollBars}
    {Set up for scroll bars}
    ChangeAllScrollBars(1, slCols, 1, pkItemRows);
    {$ENDIF}
  end;
end;

{$IFDEF UseScrollBars}
procedure UpdScrollSpread(P : PickListPtr);
  {-Update scroll bars}
begin
  with SpreadListPtr(P)^ do
    DrawAllSliders(GetItemCol(pkFirst)+pkCol-1, GetItemRow(pkFirst)+pkRow-1);
end;

procedure SetScrollSpread(FramePos : FramePosType;
                          MPosX, MPosY : Byte;
                          UserVal : LongInt; P : PickListPtr);
  {-Set pick position based on slider position}
var
  FirstRow : Word;
  FirstCol : Word;
begin
  with SpreadListPtr(P)^ do begin
    case FramePos of
      frLL, frRR :   {Vertical scroll bar}
        begin
          UserVal := TweakSlider(FramePos, MPosY, UserVal, 1);
          FirstRow := GetItemRow(pkFirst);
          if UserVal < FirstRow then begin
            dec(pkFirst, (FirstRow-UserVal)*slCols);
            FirstRow := UserVal;
          end else if UserVal > FirstRow+pkHeight-1 then begin
            inc(pkFirst, (UserVal-FirstRow-pkHeight+1)*slCols);
            inc(FirstRow, UserVal-FirstRow-pkHeight+1);
          end;
          pkRow := UserVal-FirstRow+1;
        end;
    else {Horizontal scroll bar}
      UserVal := TweakSlider(FramePos, MPosX, UserVal, 1);
      FirstCol := GetItemCol(pkFirst);
      if UserVal < FirstCol then begin
        dec(pkFirst, FirstCol-UserVal);
        FirstCol := UserVal;
      end else if UserVal > FirstCol+pkCols-1 then begin
        inc(pkFirst, UserVal-FirstCol-pkCols+1);
        FirstCol := UserVal-pkCols+1;
      end;
      pkCol := UserVal-FirstCol+1;
    end;

    pkChoice := pkGetCurrent(pkFirst, pkRow, pkCol, P);
  end;
end;
{$ENDIF}

function ScrolledSpread(pChoice, pFirst : Word; pRow, pCol : Byte;
                        P : PickListPtr) : Boolean;
  {-Perform a one-element optimized scroll if possible}
begin
  with SpreadListPtr(P)^ do begin
    ScrolledSpread := True;
    if pFirst+slCols = pkFirst then
      pkScrollDown(pChoice, pRow, pCol)
    else if pkFirst+slCols = pFirst then
      pkScrollUp(pChoice, pRow, pCol)
    else if pFirst+1 = pkFirst then
      pkScrollRight(pChoice, pRow, pCol)
    else if pkFirst+1 = pFirst then
      pkScrollLeft(pChoice, pRow, pCol)
    else
      ScrolledSpread := False;
  end;
end;

procedure PickSpread(P : PickListPtr);
  {-Orientation initialization for spreadsheet-like picklists}
begin
  with SpreadListPtr(P)^ do begin
    pkOrient := pkSpread;
    pkGetCurrent := GetSpread;
    pkSetCurrent := SetSpread;
    pkReinit := ReinitSpread;
    {$IFDEF UseScrollBars}
    pkUpdScrBar := UpdScrollSpread;
    pkSetScroll := SetScrollSpread;
    {$ENDIF}
    pkScrolled := ScrolledSpread;
  end;
end;

function SpreadList.GetItemRow(Item : Word) : Word;
begin
  GetItemRow := (Item+slCols-1) div slCols;
end;

function SpreadList.GetItemCol(Item : Word) : Word;
begin
  GetItemCol := ((Item-1) mod slCols)+1;
end;

function SpreadList.GetItemNum(Row, Col : Word) : Word;
begin
  GetItemNum := (Row-1)*slCols+Col;
end;

procedure SpreadList.TopLeftRowCol(var Row, Col : Word);
begin
  Row := GetItemRow(pkFirst);
  Col := GetItemCol(pkFirst);
end;

procedure SpreadList.pkInitPickSize1; {virtual;}
var
  Wid : Byte;
begin
  if pkReqdWidth > pkWidth then
    {Clip width as required by window size}
    pkItemWidth := pkWidth
  else
    pkItemWidth := pkReqdWidth;

  {Compute number of columns of items, and number of items in each column}
  if pkDividers then
    Wid := pkWidth+1
  else
    Wid := pkWidth;
  pkCols := Wid div pkItemWidth;
  pkItemRows := slRows;

  {Limit rows as appropriate}
  if pkItemRows < 1 then
    pkItemRows := 1;
  if pkHeight > pkMaxRows then
    pkHeight := pkMaxRows;
  if pkHeight > pkItemRows then
    pkHeight := pkItemRows;
end;

function SpreadList.pkProcessCursorCommand(var Cmd : Word) : Boolean; {virtual;}
var
  Row : Word;
  Bot : Word;
  Col : Word;
begin
  pkProcessCursorCommand := False;
  case Cmd of
    ccNone :                   {Nothing}
      Exit;

    ccUp :                     {Up}
      if pkRow > 1 then
        Dec(pkRow)
      else begin
        Row := GetItemRow(pkFirst);
        if FlagIsSet(pkFlags, pkExitAtEdges) and (Row = 1) then begin
          Cmd := ccExitAtTop;
          pkProcessCursorCommand := True;
        end else if (Row > 1) then
          dec(pkFirst, slCols);
      end;

    ccDown :                   {Down}
      if pkRow < pkHeight then
        Inc(pkRow)
      else begin
        Row := GetItemRow(pkFirst);
        if FlagIsSet(pkFlags, pkExitAtEdges) and (Row = pkItemRows-pkHeight+1) then begin
          Cmd := ccExitAtBot;
          pkProcessCursorCommand := True;
        end else if (Row < pkItemRows-pkHeight+1) then
          inc(pkFirst, slCols);
      end;

    ccLeft :                   {Left}
      if pkCol > 1 then
        Dec(pkCol)
      else begin
        Col := GetItemCol(pkFirst);
        if FlagIsSet(pkFlags, pkExitAtEdges) and (Col = 1) then begin
          Cmd := ccExitLeft;
          pkProcessCursorCommand := True;
        end else if Col > 1 then
          dec(pkFirst);
      end;

    ccRight :                  {Right}
      if pkCol < pkCols then
        Inc(pkCol)
      else begin
        Col := GetItemCol(pkFirst);
        if FlagIsSet(pkFlags, pkExitAtEdges) and (Col = slCols-pkCols+1) then begin
          Cmd := ccExitRight;
          pkProcessCursorCommand := True;
        end else if Col < slCols-pkCols+1 then
          inc(pkFirst);
      end;

    ccPageUp :                 {PgUp}
      begin
        Row := GetItemRow(pkFirst);
        if Row > pkHeight then
          dec(pkFirst, slCols*pkHeight)
        else if Row = 1 then
          pkRow := 1
        else
          dec(pkFirst, slCols*(Row-1));
      end;

    ccPageDn :                 {PgDn}
      begin
        Row := GetItemRow(pkFirst);
        Bot := Row+pkHeight-1;
        if Bot+pkHeight <= pkItemRows then
          inc(pkFirst, slCols*pkHeight)
        else if Bot = pkItemRows then
          pkRow := pkHeight
        else
          inc(pkFirst, slCols*(pkItemRows-Bot));
      end;

    ccHome :                   {Left of row}
      begin
        pkFirst := pkFirst-((pkFirst-1) mod slCols);
        pkCol := 1;
      end;

    ccEnd :                    {Right of row}
      begin
        pkFirst := pkFirst-((pkFirst-1) mod slCols)+slCols-pkCols;
        pkCol := pkCols;
      end;

    ccTopOfFile :              {Top of sheet}
      begin
        pkFirst := pkFirst mod slCols;
        pkRow := 1;
      end;

    ccEndOfFile :              {End of sheet}
      begin
        pkFirst := (pkFirst mod slCols)+slCols*(pkItemRows-pkHeight);
        pkRow := pkHeight;
      end;

  end;
  pkChoice := pkGetCurrent(pkFirst, pkRow, pkCol, @Self);
end;

constructor SpreadList.Init(X1, Y1, X2, Y2 : Byte;
                            ItemWidth : Byte;
                            NumRows : Word;
                            NumCols : Word;
                            StringProc : pkStringProc;
                            CommandHandler : pkGenlProc);
begin
  if not SpreadList.InitDeluxe(X1, Y1, X2, Y2,
                               DefaultColorSet,
                               DefWindowOptions,
                               ItemWidth, NumRows, NumCols,
                               StringProc, CommandHandler,
                               DefPickOptions) then
    Fail;
end;

constructor SpreadList.InitCustom(X1, Y1, X2, Y2 : Byte;
                                  var Colors : ColorSet;
                                  Options : LongInt;
                                  ItemWidth : Byte;
                                  NumRows : Word;
                                  NumCols : Word;
                                  StringProc : pkStringProc;
                                  CommandHandler : pkGenlProc);
begin
  if not SpreadList.InitDeluxe(X1, Y1, X2, Y2,
                               Colors,
                               Options,
                               ItemWidth, NumRows, NumCols,
                               StringProc, CommandHandler,
                               DefPickOptions) then
    Fail;
end;

constructor SpreadList.InitAbstract(X1, Y1, X2, Y2 : Byte;
                                    var Colors : ColorSet;
                                    Options : LongInt;
                                    ItemWidth : Byte;
                                    NumRows : Word;
                                    NumCols : Word;
                                    CommandHandler : pkGenlProc);
begin
 if not SpreadList.InitAbstractDeluxe(X1, Y1, X2, Y2,
                                      Colors, Options,
                                      ItemWidth, NumRows, NumCols,
                                      CommandHandler,
                                      DefPickOptions) then
    Fail;
end;

constructor SpreadList.InitDeluxe(X1, Y1, X2, Y2 : Byte;
                                  var Colors : ColorSet;
                                  Options : LongInt;
                                  ItemWidth : Byte;
                                  NumRows : Word;
                                  NumCols : Word;
                                  StringProc : pkStringProc;
                                  CommandHandler : pkGenlProc;
                                  PickOptions : Word);
var
  NumItems : LongInt;
begin
  {Validate the number of items}
  NumItems := LongInt(NumRows)*NumCols;
  if (NumItems = 0) or (NumItems > 65535) then begin
    InitStatus := epFatal+ecBadParam;
    Fail;
  end;

  {Save the rows and columns}
  slRows := NumRows;
  slCols := NumCols;

  {Initialize it}
  if not PickList.InitDeluxe(X1, Y1, X2, Y2, Colors, Options, ItemWidth,
                             NumItems, StringProc, PickSpread,
                             CommandHandler, PickOptions) then
    Fail;
end;

constructor SpreadList.InitAbstractDeluxe(X1, Y1, X2, Y2 : Byte;
                                          var Colors : ColorSet;
                                          Options : LongInt;
                                          ItemWidth : Byte;
                                          NumRows : Word;
                                          NumCols : Word;
                                          CommandHandler : pkGenlProc;
                                          PickOptions : Word);
begin
  if not SpreadList.InitDeluxe(X1, Y1, X2, Y2,
                               Colors, Options,
                               ItemWidth, NumRows, NumCols,
                               NoPickString,
                               CommandHandler, DefPickOptions) then
    Fail;
end;

procedure SpreadList.ChangeNumItems(NumItems : Word);
begin
  RunError(211);
end;

procedure SpreadList.ChangeOrientation(Orientation : pkGenlProc);
begin
  RunError(211);
end;

{$IFDEF UseStreams}
constructor SpreadList.Load(var S : IdStream);
begin
  if not PickList.Load(S) then
    Fail;
  S.Read(slRows, 2*SizeOf(Word));
  if S.PeekStatus <> 0 then begin
    Done;
    Fail;
  end;
end;

procedure SpreadList.Store(var S : IdStream);
begin
  {Store the underlying pick list}
  PickList.Store(S);
  if S.PeekStatus <> 0 then
    Exit;

  {Store what's unique to the spread list}
  S.Write(slRows, 2*SizeOf(Word));
end;

procedure SpreadListStream(SPtr : IdStreamPtr);
begin
  with SPtr^ do begin
    PickListStream(SPtr);
    RegisterType(otSpreadList, veSpreadList, TypeOf(SpreadList),
                 @SpreadList.Store, @SpreadList.Load);

    {Register the orientation routine, since there's only one}
    RegisterPointer(ptPickSpread, @PickSpread);
  end;
end;
{$ENDIF}


{$IFDEF InitAllUnits}
begin
{$ENDIF}
end.