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   TUnRETURN = class(TUndoBase)
  39   public
  40     procedure Execute; override;
  41   end;
  42
  43   TUndoClass = class(TComponent)
  44   private
  45     FStack: TObjectStack;
  46     FMemo: TCustomMemo;
  47     FCnt: integer;
  48     function GetCanUndo: Boolean;
  49     procedure Clear;
  50     procedure SetMemo(const Value: TCustomMemo);
  51   public
  52     constructor Create(AOwner: TComponent); override;
  53     procedure Deleted(const str: string; pos: integer; top: Boolean);
  54     procedure Inputted(c: Char; pos: integer);
  55     procedure Returned(pos: integer);
  56     procedure Pasted(const str: string; pos: integer);
  57     procedure Execute;
  58     destructor Destroy; override;
  59     procedure UpCount;
  60     procedure ResetCnt;
  61   published
  62     property Memo: TCustomMemo read FMemo write SetMemo;
  63     property CanUndo: Boolean read GetCanUndo;
  64   end;
  65
  66 implementation
  67
  68 { TUndoClass }
  69
  70 procedure TUndoClass.Clear;
  71 var
  72   i: integer;
  73 begin
  74   for i := 0 to FStack.Count - 1 do
  75     FStack.Pop.Free;
  76 end;
  77
  78 constructor TUndoClass.Create(AOwner: TComponent);
  79 begin
  80   inherited;
  81   FStack := TObjectStack.Create;
  82 end;
  83
  84 procedure TUndoClass.Deleted(const str: string; pos: integer; top: Boolean);
  85 var
  86   obj: TUnDelete;
  87 begin
  88   obj := TUnDelete.Create;
  89   obj.FStr := str;
  90   obj.FPos := pos;
  91   obj.FTop := top;
  92   obj.FMemo := FMemo;
  93   FStack.Push(obj);
  94 end;
  95
  96 destructor TUndoClass.Destroy;
  97 begin
  98   Clear;
  99   FStack.Free;
 100   inherited;
 101 end;
 102
 103 procedure TUndoClass.Execute;
 104 var
 105   obj: TUndoBase;
 106 begin
 107   if FStack.Count > 0 then
 108   begin
 109     obj := FStack.Pop as TUndoBase;
 110     obj.Execute;
 111     obj.Free;
 112   end;
 113 end;
 114
 115 function TUndoClass.GetCanUndo: Boolean;
 116 begin
 117   result := FStack.Count > 0;
 118 end;
 119
 120 procedure TUndoClass.Inputted(c: Char; pos: integer);
 121 var
 122   data: TUnPaste;
 123 begin
 124   if (FCnt > 0) and (FStack.Count > 0) and (FStack.Peek is TUnPaste) then
 125   begin
 126     data := FStack.Peek as TUnPaste;
 127     data.FLen := data.FLen + 1;
 128   end
 129   else
 130   begin
 131     data := TUnPaste.Create;
 132     data.FPos := pos;
 133     data.FLen := 1;
 134     data.FMemo := FMemo;
 135     FStack.Push(data);
 136   end;
 137 end;
 138
 139 procedure TUndoClass.Pasted(const str: string; pos: integer);
 140 var
 141   obj: TUnPaste;
 142 begin
 143   obj := TUnPaste.Create;
 144   obj.FPos := pos;
 145   obj.FLen := Length(str);
 146   obj.FMemo := FMemo;
 147   FStack.Push(obj);
 148 end;
 149
 150 procedure TUndoClass.ResetCnt;
 151 begin
 152   FCnt := 0;
 153 end;
 154
 155 procedure TUndoClass.Returned(pos: integer);
 156 var
 157   obj: TUnRETURN;
 158 begin
 159   obj := TUnRETURN.Create;
 160   obj.FPos := pos;
 161   obj.FMemo := FMemo;
 162   FStack.Push(obj);
 163 end;
 164
 165 procedure TUndoClass.SetMemo(const Value: TCustomMemo);
 166 var
 167   obj: TUndoBase;
 168   i: integer;
 169   List: TList;
 170 begin
 171   FMemo := Value;
 172   List := TList.Create;
 173   for i := 1 to FStack.Count do
 174   begin
 175     obj := FStack.Pop as TUndoBase;
 176     obj.FMemo := Value;
 177     List.Add(obj);
 178   end;
 179   for i := List.Count - 1 downto 0 do
 180     FStack.Push(List[i]);
 181   List.Free;
 182 end;
 183
 184 procedure TUndoClass.UpCount;
 185 begin
 186   inc(FCnt);
 187   if FCnt > 5 then
 188     FCnt := 0;
 189 end;
 190
 191 { TUnDelete }
 192
 193 procedure TUnDelete.Execute;
 194 begin
 195   FMemo.SelStart := FPos;
 196   FMemo.SelText := FStr;
 197   FMemo.SelStart := FPos;
 198   if Length(FStr) > 1 then
 199     FMemo.SelLength := Length(FStr);
 200   if FTop = true then
 201   begin
 202     FMemo.SelLength := Length(FStr);
 203     FMemo.SelStart := FPos;
 204   end
 205   else
 206   begin
 207     FMemo.SelLength := Length(FStr);
 208     FMemo.SelStart := FPos + 1;
 209   end;
 210 end;
 211
 212 { TUnPaste }
 213
 214 procedure TUnPaste.Execute;
 215 begin
 216   if FMemo <> nil then
 217   begin
 218     FMemo.SelStart := FPos;
 219     FMemo.SelLength := FLen;
 220     FMemo.SelText := '';
 221   end;
 222 end;
 223
 224 { TUnInput }
 225
 226 procedure TUnInput.Execute;
 227 begin
 228   if FMemo <> nil then
 229   begin
 230     FMemo.SelStart := FPos;
 231     FMemo.SelText := '';
 232   end;
 233 end;
 234
 235 { TUnRETURN }
 236
 237 procedure TUnRETURN.Execute;
 238 var
 239   i: integer;
 240   s: string;
 241 begin
 242   if FMemo <> nil then
 243   begin
 244     FMemo.SelStart := FPos;
 245     i := FMemo.CaretPos.Y;
 246     FMemo.Lines[i] := FMemo.Lines[i] + FMemo.Lines[i + 1];
 247     FMemo.Lines.Delete(i + 1);
 248     FMemo.SelStart:=FPos;
 249   end;
 250 end;
 251
 252 end.