www.pudn.com > tp60src.zip > CONTROLS.PAS

unit Controls; 
 
{$O+,F+,S-,X+} 
 
interface 
 
uses Objects, Drivers, Views, Dialogs, TVars; 
 
const 
 
  lfTop  = 0; 
  lfLeft = $100; 
 
  cmDeleteWindow = 1070; 
 
  CDoubleTest = #7#8; 
 
type 
 
  PIntField = ^TIntField; 
  TIntField = object(TInputLine) 
    Min, Max: Longint; 
    constructor Init(var Bounds: TRect; AMaxLen: Integer; 
      AMin, AMax: Longint); 
    constructor Load(var S: TStream); 
    function DataSize: Word; virtual; 
    procedure GetData(var Rec); virtual; 
    procedure SetData(var Rec); virtual; 
    procedure Store(var S: TStream); 
    function Valid(Command: Word): Boolean; virtual; 
  end; 
 
  PCenterText = ^TCenterText; 
  TCenterText = object(TStaticText) 
    function DataSize: Word; virtual; 
    procedure SetData(var Rec); virtual; 
  end; 
 
  PDoubleTest = ^TDoubleTest; 
  TDoubleTest = object(TStaticText) 
    Hilite: Boolean; 
    function GetPalette: PPalette; virtual; 
    procedure HandleEvent(var Event: TEvent); virtual; 
    procedure Draw; virtual; 
  end; 
 
  PWindowListViewer = ^TWindowListViewer; 
  TWindowListViewer = object(TListViewer) 
    function DataSize: Word; virtual; 
    procedure GetData(var Rec); virtual; 
    function GetText(Item: Integer; MaxLen: Integer): string; virtual; 
    procedure HandleEvent(var Event: TEvent); virtual; 
    procedure SetData(var Rec); virtual; 
    function WindowCount: Integer; 
    function WindowNum(I: Integer): PWindow; 
  end; 
 
  PEditLine = ^TEditLine; 
  TEditLine = object(TInputLine) 
    CanExpand: Boolean; 
    procedure HandleEvent(var Event: TEvent); virtual; 
    procedure SetData(var Rec); virtual; 
    function LegalCharSet: PCharSet; virtual; 
  end; 
 
  PAddressField = ^TAddressField; 
  TAddressField = object(TInputLine) 
    function DataSize: Word; virtual; 
    procedure GetData(var Rec); virtual; 
    procedure SetData(var Rec); virtual; 
    function Valid(Command: Word): Boolean; virtual; 
    function Value(var P: Pointer): Boolean; 
  end; 
 
  PCtrlPLine = ^TCtrlPLine; 
  TCtrlPLine = object(TEditLine) 
    procedure HandleEvent(var Event: TEvent); virtual; 
  end; 
 
const 
 
  RIntField: TStreamRec = ( 
    ObjType: 2001; 
    VmtLink: Ofs(TypeOf(TIntField)^); 
    Load:    @TIntField.Load; 
    Store:   @TIntField.Store 
  ); 
  RCenterText: TStreamRec = ( 
    ObjType: 2002; 
    VmtLink: Ofs(TypeOf(TCenterText)^); 
    Load:    @TCenterText.Load; 
    Store:   @TCenterText.Store 
  ); 
  RDoubleTest: TStreamRec = ( 
    ObjType: 2003; 
    VmtLink: Ofs(TypeOf(TDoubleTest)^); 
    Load:    @TDoubleTest.Load; 
    Store:   @TDoubleTest.Store 
  ); 
  RWindowListViewer: TStreamRec = ( 
    ObjType: 2004; 
    VmtLink: Ofs(TypeOf(TWindowListViewer)^); 
    Load:    @TWindowListViewer.Load; 
    Store:   @TWindowListViewer.Store 
  ); 
  REditLine: TStreamRec = ( 
    ObjType: 2005; 
    VmtLink: Ofs(TypeOf(TEditLine)^); 
    Load:    @TEditLine.Load; 
    Store:   @TEditLine.Store 
  ); 
  RAddressField: TStreamRec = ( 
    ObjType: 2006; 
    VmtLink: Ofs(TypeOf(TAddressField)^); 
    Load:    @TAddressField.Load; 
    Store:   @TAddressField.Store 
  ); 
  RCtrlPLine: TStreamRec = ( 
    ObjType: 2007; 
    VmtLink: Ofs(TypeOf(TCtrlPLine)^); 
    Load:    @TCtrlPLine.Load; 
    Store:   @TCtrlPLine.Store 
  ); 
 
function NewButton(AX, AY, AW: Integer;ATitle: TTitleStr; ACommand: Word; 
  AFlags: Byte; AHelpCtx: Word): PButton; 
function OkButton(AX, AY: Integer): PButton; 
function CnlButton(AX, AY: Integer): PButton; 
function HelpButton(AX, AY: Integer; AHelpCtx: Word): PButton; 
function StandardLabel(AText: string; ALink: PView; AFlags: Word): PLabel; 
function StandardHistory(ALink: PInputLine; AHistoryId: Word): PHistory; 
function SetHelp(P: PView; AHelpCtx: Word): PView; 
function WindowListDialog: PDialog; 
 
implementation 
 
uses App, Utils, StrNames, Context; 
 
constructor TIntField.Init(var Bounds: TRect; AMaxLen: Integer; 
  AMin, AMax: Longint); 
begin 
  TInputLine.Init(Bounds, AMaxLen); 
  Min := AMin; 
  Max := AMax; 
end; 
 
constructor TIntField.Load(var S: TStream); 
begin 
  TInputLine.Load(S); 
  S.Read(Min, SizeOf(Min) + SizeOf(Max)); 
end; 
 
function TIntField.DataSize: Word; 
begin 
  DataSize := SizeOf(Longint); 
end; 
 
procedure TIntField.GetData(var Rec); 
var 
  Code: Integer; 
begin 
  Val(Data^, Longint(Rec), Code); 
end; 
 
procedure TIntField.SetData(var Rec); 
begin 
  Str(Longint(Rec), Data^); 
  DrawView; 
end; 
 
procedure TIntField.Store(var S: TStream); 
begin 
  TInputLine.Store(S); 
  S.Write(Min, SizeOf(Min) + SizeOf(Max)); 
end; 
 
function TIntField.Valid(Command: Word): Boolean; 
var 
  Code: Integer; 
  Value: Longint; 
  L: array[0..5] of Longint; 
begin 
  Valid := True; 
  if (Command <> cmCancel) and (Command <> cmValid) then 
  begin 
    Val(Data^, Value, Code); 
    if (Code <> 0) or (Value < Min) or (Value > Max) then 
    begin 
      L[0] := Min; 
      L[1] := Max; 
      MessageBox(sValueNotInRange, @L, mfError + mfOkButton); 
      SelectAll(True); 
      Select; 
      Valid := False; 
    end; 
  end; 
end; 
 
function TCenterText.DataSize: Word; 
begin 
  DataSize := SizeOf(string); 
end; 
 
procedure TCenterText.SetData(var Rec); 
var 
  R: string absolute Rec; 
  S: string; 
  I: Integer; 
begin 
  if Length(R) < Size.X then 
  begin 
    I := (Size.X - Length(R)) shr 1; 
    FillChar(S[1], I, ' '); 
    S[0] := Chr(I); 
    S := S + R; 
  end else 
  begin 
    S := R; 
    S[0] := Chr(Size.X) 
  end; 
  DisposeStr(Text); 
  Text := NewStr(S); 
  DrawView; 
end; 
 
function TDoubleTest.GetPalette: PPalette; 
const 
  P: string[Length(CDoubleTest)] = CDoubleTest; 
begin 
  GetPalette := @P; 
end; 
 
procedure TDoubleTest.HandleEvent(var Event: TEvent); 
begin 
  TStaticText.HandleEvent(Event); 
  if Event.What = evMouseDown then 
  begin 
    if Event.Double then 
    begin 
      Hilite := not Hilite; 
      DrawView; 
    end; 
    ClearEvent(Event); 
  end; 
end; 
 
procedure TDoubleTest.Draw; 
var 
  B: TDrawBuffer; 
  Color: Byte; 
begin 
  if Hilite then 
    Color := GetColor(2) 
  else 
    Color := GetColor(1); 
  MoveChar(B, ' ', Color, Size.X); 
  MoveStr(B, Text^, Color); 
  WriteLine(0, 0, Size.X, 1, B); 
end; 
 
function TWindowListViewer.WindowCount: Integer; 
var 
  I: Integer; 
 
procedure DoWindowCount(P: PView); far; 
begin 
  if (P^.State and sfVisible <> 0) and (P^.Options and ofSelectable <> 0) then 
    Inc(I); 
end; 
 
begin 
  I := 0; 
  Desktop^.ForEach(@DoWindowCount); 
  WindowCount := I; 
end; 
 
function TWindowListViewer.DataSize: Word; 
begin 
  DataSize := SizeOf(PWindow); 
end; 
 
procedure TWindowListViewer.GetData(var Rec); 
 
function DoGetData(P: PView): Boolean; far; 
begin 
  DoGetData := False; 
  if (P^.State and sfVisible <> 0) and (P^.Options and ofSelectable <> 0) then 
    if Focused = 0 then 
      DoGetData := True 
    else 
      Dec(Focused); 
end; 
 
begin 
  PView(Rec) := Desktop^.FirstThat(@DoGetData); 
end; 
 
function TWindowListViewer.WindowNum(I: Integer): PWindow; 
 
function DoWindowNum(P: PView): Boolean; far; 
begin 
  DoWindowNum := False; 
  if (P^.State and sfVisible <> 0) and (P^.Options and ofSelectable <> 0) and 
    (P <> PView(Owner)) then 
    if I = 0 then 
      DoWindowNum := True 
    else 
      Dec(I); 
end; 
 
begin 
  WindowNum := PWindow(Desktop^.FirstThat(@DoWindowNum)); 
end; 
 
function TWindowListViewer.GetText(Item: Integer; MaxLen: Integer): string; 
var 
  P: PWindow; 
begin 
  P := WindowNum(Item); 
  if P <> nil then 
    GetText := P^.GetTitle(MaxLen) 
  else 
    GetText := ''; 
end; 
 
procedure TWindowListViewer.HandleEvent(var Event: TEvent); 
var 
  P: PWindow; 
begin 
  if (Event.What = evMouseDown) and Event.Double then 
  begin 
    Event.What := evCommand; 
    Event.Command := cmOK; 
    PutEvent(Event); 
    ClearEvent(Event); 
  end; 
  if PDialog(Owner)^.Phase = phFocused then 
    TListViewer.HandleEvent(Event); 
  if ((Event.What = evCommand) and (Event.Command = cmDeleteWindow)) or 
    ((Event.What = evKeyDown) and (Event.keycode = kbDel)) then 
  begin 
    P := WindowNum(Focused); 
    if (P <> nil) and (Message(P, evCommand, cmClose, nil) <> nil) then 
    begin 
      SetRange(WindowCount); 
      DrawView; 
    end; 
    ClearEvent(Event); 
  end; 
end; 
 
procedure TWindowListViewer.SetData(var Rec); 
begin 
  SetRange(WindowCount); 
  if Range > 1 then FocusItem(1); 
end; 
 
function WindowListDialog: PDialog; 
var 
  R: TRect; 
  Dialog: PDialog; 
  Control: PView; 
begin 
  R.Assign(15, 3, 67, 18); 
  Dialog := New(PDialog, Init(R, 'Window List')); 
  with Dialog^ do 
  begin 
    Options := Options or ofCentered; 
    R.Assign(39, 3, 40, 13); 
    Control := New(PScrollBar, Init(R)); 
    Insert(Control); 
    R.Assign(3, 3, 39, 13); 
    Control := SetHelp(New(PWindowListViewer, 
      Init(R, 1, nil, PScrollBar(Control))), hcWindowListViewer); 
    Control^.Options := Control^.Options or ofPostProcess; 
    Insert(Control); 
    Insert(StandardLabel('~W~indows', Control, lfTop)); 
    Insert(OkButton(40, 3)); 
    Insert(NewButton(40, 6, 10, '~D~elete', cmDeleteWindow, bfNormal, 
      hcDeleteWindowButton)); 
    Insert(CnlButton(40, 9)); 
    Insert(HelpButton(40, 12, hcWindowListDialog)); 
    SelectNext(False); 
  end; 
  WindowListDialog := Dialog; 
end; 
 
procedure TEditLine.SetData(var Rec); 
var 
  R: string absolute Rec; 
begin 
  if Data^ = '' then 
    if R = '' then 
      Data ^:= GetEditWord(MaxLen, LegalCharSet) 
    else Data^ := R; 
  CanExpand := True; 
end; 
 
procedure TEditLine.HandleEvent(var Event: TEvent); 
var 
  I: Integer; 
  C: Char; 
begin 
  I := Length(Data^); 
  C := Event.CharCode; 
  if CanExpand and (Event.What = evKeyDown) then 
    case CtrlToArrow(Event.KeyCode) of 
      kbRight: 
        if Length(Data^) = CurPos then 
        begin 
          Event.CharCode := GetEditChar(CurPos + 1); 
          Inc(I); 
        end; 
    end; 
  TInputLine.HandleEvent(Event); 
  Event.CharCode := C; 
  CanExpand := CanExpand and (Length(Data^) = I); 
end; 
 
function TEditLine.LegalCharSet: PCharSet; 
begin 
  LegalCharSet := @WordChars; 
end; 
 
function TAddressField.DataSize: Word; 
begin 
  DataSize := SizeOf(Pointer); 
end; 
 
function TAddressField.Value(var P: Pointer): Boolean; 
var 
  I, Code1, Code2: Integer; 
begin 
  Value := False; 
  I := Pos(':', Data^); 
  if I <> 0 then 
  begin 
    Val('$' + Copy(Data^, 1, I - 1), PtrRec(P).Seg, Code1); 
    Val('$' + Copy(Data^, I + 1, 255), PtrRec(P).Ofs, Code2); 
    if Code1 + Code2 = 0 then 
      Value := True; 
  end; 
end; 
 
procedure TAddressField.GetData(var Rec); 
begin 
  Value(Pointer(Rec)); 
end; 
 
procedure TAddressField.SetData(var Rec); 
var 
  L: array[0..1] of Longint; 
begin 
  L[0] := PtrRec(Rec).Seg; 
  L[1] := PtrRec(Rec).Ofs; 
  FormatStr(Data^, '%04x:%04x', L); 
end; 
 
function TAddressField.Valid(Command: Word): Boolean; 
var 
  P: Pointer; 
begin 
  Valid := True; 
  if (Command <> cmCancel) and (Command <> cmValid) and not Value(P) then 
  begin 
    MessageBox(sInvalidAddress, nil, mfError + mfOkButton); 
    SelectAll(True); 
    Valid := False; 
  end; 
end; 
 
procedure TCtrlPLine.HandleEvent(var Event: TEvent); 
 
procedure DeleteSelect; 
begin 
  if SelStart <> SelEnd then 
  begin 
    Delete(Data^, SelStart + 1, SelEnd - SelStart); 
    CurPos := SelStart; 
  end; 
end; 
 
var 
  I: Integer; 
begin 
  TEditLine.HandleEvent(Event); 
  if (Event.What = evKeyDown) and (Event.CharCode = ^P) and 
    (Length(Data^) < MaxLen) then 
  begin 
    KeyEvent(Event); 
    if State and sfCursorIns <> 0 then 
      Delete(Data^, CurPos + 1, 1) 
    else 
      DeleteSelect; 
    if FirstPos > CurPos then 
      FirstPos := CurPos; 
    Inc(CurPos); 
    Insert(Event.CharCode, Data^, CurPos); 
    SelStart := 0; 
    SelEnd := 0; 
    if FirstPos > CurPos then 
      FirstPos := CurPos; 
    I := CurPos - Size.X + 2; 
    if FirstPos < I then 
      FirstPos := I; 
    ClearEvent(Event); 
    DrawView; 
  end; 
end; 
 
function NewButton(AX, AY, AW: Integer; ATitle: TTitleStr; ACommand: Word; 
  AFlags: Byte; AHelpCtx: Word): PButton; 
var 
  R: TRect; 
begin 
  R.Assign(AX, AY, AX + AW, AY + 2); 
  NewButton := PButton(SetHelp(New(PButton, 
    Init(R, ATitle, ACommand, AFlags)), AHelpCtx)); 
end; 
 
function OkButton(AX, AY: Integer): PButton; 
begin 
  OkButton := NewButton(AX, AY, 10, 'O~K~', cmOK, bfDefault, hcOKButton); 
end; 
 
function CnlButton(AX, AY: Integer): PButton; 
begin 
  CnlButton := NewButton(AX, AY, 10, 'Cancel', cmCancel, bfNormal, hcCnlButton); 
end; 
 
function HelpButton(AX, AY: Integer; AHelpCtx: Word): PButton; 
begin 
  HelpButton := NewButton(AX, AY, 10, 'Help', cmHelp, bfNormal, AHelpCtx); 
end; 
 
function StandardLabel(AText: string; ALink: PView; AFlags: Word): PLabel; 
var 
  R: TRect; 
begin 
  ALink^.GetBounds(R); 
  if AFlags and lfLeft <> 0 then 
  begin 
    if Lo(AFlags) = 0 then 
    begin 
      R.B.X := R.A.X - 1; 
      Dec(R.A.X, CStrLen(AText) + 2); 
    end else 
    begin 
      R.A.X := Lo(AFlags); 
      R.B.X := R.A.X + CStrLen(AText) + 1; 
    end; 
  end else 
  begin 
    Dec(R.A.X); 
    Dec(R.A.Y); 
    R.B.X := R.A.X + CStrLen(AText) + 1; 
    R.B.Y := R.A.Y + 1; 
  end; 
  R.B.Y := R.A.Y + 1; 
  StandardLabel := New(PLabel, Init(R, AText, ALink)); 
end; 
 
function StandardHistory(ALink: PInputLine; AHistoryId: Word): PHistory; 
var 
  R: TRect; 
begin 
  ALink^.GetBounds(R); 
  R.A.X := R.B.X; 
  Inc(R.B.X, 3); 
  StandardHistory := New(PHistory, Init(R, ALink, AHistoryId)); 
end; 
 
function SetHelp(P: PView; AHelpCtx: Word): PView; 
begin 
  P^.HelpCtx := AHelpCtx; 
  SetHelp := P; 
end; 
 
end.