Undo.pas

   1 unit Undo;
   2
   3 interface
   4
   5 uses System.Contnrs, System.Classes, Vcl.StdCtrls;
   6
   7 type
   8   TUndoBase = class
   9   private
  10     FPos: integer;
  11     FMemo: TCustomMemo;
  12   public
  13     procedure Execute; virtual; abstract;
  14   end;
  15
  16   TUnInput = class(TUndoBase)
  17   private
  18     FData: Char;
  19   public
  20     procedure Execute; override;
  21   end;
  22
  23   TUnDelete = class(TUndoBase)
  24   private
  25     FStr: string;
  26     FTop: Boolean;
  27   public
  28     procedure Execute; override;
  29   end;
  30
  31   TUnPaste = class(TUndoBase)
  32   private
  33     FLen: integer;
  34   public
  35     procedure Execute; override;
  36   end;
  37
  38   TUndoClass = class(TComponent)
  39   private
  40     FStack: TObjectStack;
  41     FMemo: TCustomMemo;
  42     FCnt: integer;
  43     function GetCanUndo: Boolean;
  44     procedure Clear;
  45   public
  46     constructor Create(AOwner: TComponent); override;
  47     procedure Deleted(const str: string; pos: integer; top: Boolean);
  48     procedure Inputted(c: Char; pos: integer);
  49     procedure Pasted(const str: string; pos: integer);
  50     procedure Execute;
  51     destructor Destroy; override;
  52     procedure UpCount;
  53     procedure ResetCnt;
  54   published
  55     property Memo: TCustomMemo read FMemo write FMemo;
  56     property CanUndo: Boolean read GetCanUndo;
  57   end;
  58
  59 implementation
  60
  61 { TUndoClass }
  62
  63 procedure TUndoClass.Clear;
  64 var
  65   i: integer;
  66 begin
  67   for i := 0 to FStack.Count - 1 do
  68     FStack.Pop.Free;
  69 end;
  70
  71 constructor TUndoClass.Create(AOwner: TComponent);
  72 begin
  73   inherited;
  74   FStack := TObjectStack.Create;
  75 end;
  76
  77 procedure TUndoClass.Deleted(const str: string; pos: integer; top: Boolean);
  78 var
  79   obj: TUnDelete;
  80 begin
  81   obj := TUnDelete.Create;
  82   obj.FStr := str;
  83   obj.FPos := pos;
  84   obj.FTop := top;
  85   obj.FMemo := FMemo;
  86   FStack.Push(obj);
  87 end;
  88
  89 destructor TUndoClass.Destroy;
  90 begin
  91   Clear;
  92   FStack.Free;
  93   inherited;
  94 end;
  95
  96 procedure TUndoClass.Execute;
  97 var
  98   obj: TUndoBase;
  99 begin
 100   if FStack.Count > 0 then
 101   begin
 102     obj := FStack.Pop as TUndoBase;
 103     obj.Execute;
 104     obj.Free;
 105   end;
 106 end;
 107
 108 function TUndoClass.GetCanUndo: Boolean;
 109 begin
 110   result := FStack.Count > 0;
 111 end;
 112
 113 procedure TUndoClass.Inputted(c: Char; pos: integer);
 114 var
 115   data: TUnPaste;
 116 begin
 117   if (FCnt > 0) and (FStack.Count > 0) then
 118   begin
 119     data := FStack.Peek as TUnPaste;
 120     data.FLen := data.FLen + 1;
 121   end
 122   else
 123   begin
 124     data := TUnPaste.Create;
 125     data.FPos := pos;
 126     data.FLen := 1;
 127     data.FMemo := FMemo;
 128     FStack.Push(data);
 129   end;
 130 end;
 131
 132 procedure TUndoClass.Pasted(const str: string; pos: integer);
 133 var
 134   obj: TUnPaste;
 135 begin
 136   obj := TUnPaste.Create;
 137   obj.FPos := pos;
 138   obj.FLen := Length(str);
 139   obj.FMemo := FMemo;
 140   FStack.Push(obj);
 141 end;
 142
 143 procedure TUndoClass.ResetCnt;
 144 begin
 145   FCnt := 0;
 146 end;
 147
 148 procedure TUndoClass.UpCount;
 149 begin
 150   inc(FCnt);
 151   if FCnt > 5 then
 152     FCnt := 0;
 153 end;
 154
 155 { TUnDelete }
 156
 157 procedure TUnDelete.Execute;
 158 begin
 159   FMemo.SelStart := FPos;
 160   FMemo.SelText := FStr;
 161   FMemo.SelStart := FPos;
 162   if Length(FStr) > 1 then
 163     FMemo.SelLength := Length(FStr);
 164   if FTop = true then
 165   begin
 166     FMemo.SelLength := Length(FStr);
 167     FMemo.SelStart := FPos;
 168   end
 169   else
 170   begin
 171     FMemo.SelLength := Length(FStr);
 172     FMemo.SelStart := FPos + 1;
 173   end;
 174 end;
 175
 176 { TUnPaste }
 177
 178 procedure TUnPaste.Execute;
 179 begin
 180   FMemo.SelStart := FPos;
 181   FMemo.SelLength := FLen;
 182   FMemo.SelText := '';
 183 end;
 184
 185 { TUnInput }
 186
 187 procedure TUnInput.Execute;
 188 begin
 189   FMemo.SelStart := FPos;
 190   FMemo.SelText := '';
 191 end;
 192
 193 end.