{ Undo処理に関して： Undo処理は独立した処理とみなしてよい。 UndoCount・TUndoMode・TRichUndoMemory・を定義して 以下の処理を実現すればそれだけでUndo機能がつく。 private FUndoFarPoint: Integer; FUndoRecentPoint: Integer; FUndoNowPoint: Integer; FUndoNowMode: TUndoMode; FUndoMemory: array[0..UndoCount] of TRichUndoMemory; FInsert: Boolean; FCreate: Boolean; procedure AppMessage(var Msg: TMsg; var Handled: Boolean); procedure LoadUndoMemory(UndoPoint: Integer); function GetSelTopIndex: Integer; procedure SetSelTopIndex(const Value: Integer); protected procedure KeyDown(var Key: Word; Shift: TShiftState); override; procedure KeyUp(var Key: Word; Shift: TShiftState); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure SaveUndoMemory(mode: TUndoMode); procedure Undo; procedure Redo; function CanUndo: Boolean; function CanRedo: Boolean; procedure SetSelName(Value: String); procedure SetSelColor(Value: TColor); procedure SetSelSize(Value: Integer); procedure SetSelStyle(Value: TFontStyles); procedure SetParaAlignment(Value: TAlignment); procedure SetParaFirstIndent(Value: Longint); procedure SetParaLeftIndent(Value: Longint); procedure SetParaRightIndent(Value: Longint); procedure SetParaNumbering(Value: TNumberingStyle); property Insert: Boolean read FInsert; property SelTopIndex: Integer read GetSelTopIndex write SetSelTopIndex; Undo機能だけ持つVCL継承をしてもよいが、 今回は単体でその他の重要な機能も実装する。 } unit RichEditVx; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ComCtrls, RichEdit, Registry, Clipbrd{, HenkanJ}; const UndoCount=15; type TTextChange=(tcZenToHank,tcHankToZen,tcKanaToZen,tcUpper,tcLower); TUndoMode = (umUndo,umSelect,umReturn,umMouseSelect,umDelete,umKey,umPaste, umChange,umContinueChange,umIME); //▽ TUndoMode = (umUndo,umSelect,umReturn,umOleDragDrop,umDelete,umKey,umPaste, //▽ umChange,umContinueChange,umIME); //umUndoを先頭にするのは0クリアされるから //umContinueChangeは連続保存する必要の無い場合使う //例えばParagraph移動とかはこれを指定 TRichUndoMemory = class private FStream: TMemoryStream; FTopIndex: Integer; FSelStart: Integer; FSelLength: Integer; FText: string; protected public constructor Create; destructor Destroy; override; property uStream: TMemoryStream read FStream write FStream; property uTopIndex: Integer read FTopIndex write FTopIndex; property uSelStart: Integer read FSelStart write FSelStart; property uSelLength: Integer read FSelLength write FSelLength; property uText: string read FText write FText; published end; { TProtectChangeEvent = procedure(Sender: TObject;var Msg: UINT; wparam:WPARAM;lparam:LPARAM; chrg:TCharRange; Res: Boolean)of object; } TRichEditVx = class(TCustomRichEdit) private FVertical: Boolean; FSelectionBar: Boolean; FOnWrapChange: TNotifyEvent; FOnVerticalChange: TNotifyEvent; FRegKey: string; {Undo関係} FUndoFarPoint: Integer; FUndoRecentPoint: Integer; FUndoNowPoint: Integer; FUndoNowMode: TUndoMode; FUndoMemory: array[0..UndoCount] of TRichUndoMemory; FInsert: Boolean; {property} procedure SetVertical(Value: Boolean); procedure SetSelectionBar(Value: Boolean); procedure SetWordWrap(const Value: Boolean); procedure SetSelTopIndex(const Value: Integer); function GetWordWrap: Boolean; function GetSelectionBar: Boolean; function GetVertical: Boolean; function GetSelLineIndex: Integer; function GetSelNextLineIndex: Integer; function GetSelX: Integer; function GetSelY: Integer; function GetSelTopIndex: Integer; function GetSelTextWideCount: Integer; function GetSelTextCount: Integer; function GetSelTextDelCRLF: string; {その他} procedure SetImeColor; procedure AppMessage(var Msg: TMsg; var Handled: Boolean); function DeleteCRLF(Value: string): string; procedure LoadUndoMemory(UndoPoint: Integer); function CRLFPreSearch(Pre: boolean): Integer; function CRLFNextSearch(Pre: boolean): Integer; //Indentで使用している、パラグラフ選択にも使用出来る予定 protected {override} procedure CreateWnd; override; procedure CreateParams(var Params: TCreateParams); override; procedure KeyDown(var Key: Word; Shift: TShiftState); override; procedure KeyUp(var Key: Word; Shift: TShiftState); override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; // function DoProtected(pen: PENProtected;var lResult: LRESULT): Boolean; dynamic; {event} procedure WrapChange; virtual; procedure VerticalChange; virtual; public {override} constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Clear; override;//全面的にここで新規作成処理を行う予定 {registry} procedure SaveProperty; procedure LoadProperty; procedure SetLine(Value: Integer); procedure LineSelect; procedure LineDelete; {Clipboard etc} procedure ClearSelection; procedure CopyToClipboard; procedure CutToClipboard; procedure PasteFromClipboard; function CanPaste: Boolean; procedure SelectAll; //検索系 function FindBackText(const SearchStr: string; StartPos, SearchLength: Integer; Options: TSearchTypes): Integer; function ReplaceTextAll(const SearchStr, ReplaceStr: String; StartPos, SearchLength: Integer; Options: TSearchTypes): Integer; {indent} procedure Indent(IndentStr: string); procedure UnIndent; //Undo系 procedure SaveUndoMemory(mode: TUndoMode); //とりあえずテキスト変更動作前に呼び出そう procedure UndoMemoryClear; procedure Undo; procedure Redo; function CanUndo: Boolean; function CanRedo: Boolean; {SelAttribute.Paragraph} procedure SetSelName(Value: String); procedure SetSelColor(Value: TColor); procedure SetSelSize(Value: Integer); procedure SetSelStyle(Value: TFontStyles); procedure SetParaAlignment(Value: TAlignment); procedure SetParaFirstIndent(Value: Longint); procedure SetParaLeftIndent(Value: Longint); procedure SetParaRightIndent(Value: Longint); procedure SetParaNumbering(Value: TNumberingStyle); property Insert: Boolean read FInsert; {ToHankaku etc} procedure SelTextChange(Value: TTextChange); published property SelX: Integer read GetSelX; property SelY: Integer read GetSelY; property SelLineIndex: Integer read GetSelLineIndex; property SelNextLineIndex: Integer read GetSelNextLineIndex; property SelTopIndex: Integer read GetSelTopIndex write SetSelTopIndex; property SelTextCount: Integer read GetSelTextCount; property SelTextWideCount: Integer read GetSelTextWideCount; property SelTextDelCRLF: string read GetSelTextDelCRLF; property UseRegKey:string read FRegKey write FRegKey; property OnVerticalChange: TNotifyEvent read FOnVerticalChange write FOnVerticalChange; property OnWrapChange: TNotifyEvent read FOnWrapChange write FOnWrapChange; property SelectionBar: Boolean read GetSelectionBar write SetSelectionBar default false; property Vertical: Boolean read GetVertical write SetVertical default False; property WordWrap: Boolean read GetWordWrap write SetWordWrap default True; property Align; property Alignment; property Anchors; property BiDiMode; property BorderStyle; property BorderWidth; property Color; property Ctl3D; property DragCursor; property DragKind; property DragMode; property Enabled; property Font; property HideSelection; // property HideScrollBars; property ImeMode; property ImeName; property Constraints; property Lines; property MaxLength; property ParentBiDiMode; property ParentColor; property ParentCtl3D; property ParentFont; property ParentShowHint; property PlainText; property PopupMenu; property ReadOnly; // property ScrollBars; property ShowHint; property TabOrder; property TabStop default True; property Visible; property WantTabs; property WantReturns; property OnChange; property OnDragDrop; property OnDragOver; property OnEndDock; property OnEndDrag; property OnEnter; property OnExit; property OnKeyDown; property OnKeyPress; property OnKeyUp; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnMouseWheel; property OnMouseWheelDown; property OnMouseWheelUp; property OnProtectChange; property OnResizeRequest; property OnSaveClipboard; property OnSelectionChange; property OnStartDock; property OnStartDrag; end; procedure Register; function BackAnsiPos(subStr,S: String): Integer; implementation uses StringUnit, StringConvertUnit; procedure Register; begin RegisterComponents('Samples', [TRichEditVx]); end; { TRichUndoMemory } constructor TRichUndoMemory.Create; begin inherited Create; FStream := TMemoryStream.Create; end; destructor TRichUndoMemory.Destroy; begin FStream.Free; inherited Destroy; end; { クラスには属さない } function BackAnsiPos(subStr,S: String): Integer; var SerchStr: String; BackPosIndex: Integer; begin if AnsiPos(subStr,S)=0 then begin Result := 0; Exit; end; SerchStr := S; while AnsiPos(subStr,SerchStr)<>0 do begin BackPosIndex := AnsiPos(subStr,SerchStr); Delete(SerchStr,1,BackPosIndex); end; Result := length(S)-Length(SerchStr); end; { TRichEditVx } { Windows,RichTextコントロールには強力なバグが多数ある。 そのバグをすべて隠蔽する事は出来そうに無い（RichEditですらあきらめているのだろう） そこでバグを隠蔽するために無理矢理なコーディングをしているが仕方ない バグ隠蔽の為の処理として常にHideScrollBars:=false、ScrollBars:=ssBothにした。 SelectionBarとの相性が悪い為だ そのかわりVertical,SelectionBar,WordWrapはいい感じにしあがっている Vertical:=trueにするとWordWrapは自動でtrueになる。 設計時は今一つ不具合っぽいが実行時には綺麗に動作する。 Vertical,SelectionBar,WordWrapを設定すると Visible:=falseでもtrueになってしまうので気を付けること。 } constructor TRichEditVx.Create(AOwner: TComponent); var i: Integer; begin inherited Create(AOwner); inherited HideScrollBars := false; inherited ScrollBars := ssBoth; if not(csDesigning in ComponentState) then begin Application.OnMessage := AppMessage; for i:=0 to UndoCount-1 do begin if FUndoMemory[i]=nil then FUndoMemory[i] := TRichUndoMemory.Create; end; end; FUndoNowMode := umSelect; // ClipClassProcCreate;//▽ end; destructor TRichEditVx.Destroy; var i: Integer; begin for i:=0 to UndoCount-1 do FUndoMemory[i].Free; // if not(csDesigning in ComponentState) then Application.OnMessage := nil; inherited Destroy; end; procedure TRichEditVx.CreateParams(var Params: TCreateParams); begin inherited CreateParams(Params); if FVertical then // Params.Style := Params.Style or ES_VERTICAL; {↑WinXPではRichEditの縦書き機能が不具合を 起こすので使わない} if FSelectionBar then Params.Style := Params.Style or ES_SELECTIONBAR; FInsert := true; end; procedure TRichEditVx.CreateWnd; begin inherited CreateWnd; SetImeColor; end; function TRichEditVx.GetWordWrap: Boolean; begin Result := inherited WordWrap; end; //------------------------------------------- procedure TRichEditVx.SetImeColor;{(TextColor0,BackColor0,TextColor1,BackColor1, TextColor2,BackColor2,TextColor3,BackColor3: TColor);} var CompColors: array[0..3] of TCompColor; begin with CompColors[0] do begin crText := clBlue; crBackground := clWhite; dwEffects := CFE_SHADOW;//0;//CFE_UNDERLINE; end; with CompColors[1] do begin crText := clWhite; crBackground := clNavy; dwEffects := 0;//CFE_SHADOW; end; with CompColors[2] do begin crText := clSilver; crBackground := clWhite; dwEffects := CFE_UNDERLINE; end; with CompColors[3] do begin crText := clBlack; crBackground := clAqua; dwEffects := CFE_UNDERLINE; end; SendMessage(Handle,EM_SETIMECOLOR,0,lparam(@CompColors)); end; //------------------------------ procedure TRichEditVx.SetWordWrap(const Value: Boolean); var SelStartBuff, SelLengthBuff, TopIndexBuff: Integer; begin if inherited WordWrap<>Value then begin SelStartBuff := SelStart; SelLengthBuff := SelLength; TopIndexBuff := SelTopIndex; if FVertical then begin inherited WordWrap := true end else begin inherited WordWrap := Value; SelectionBar := not SelectionBar; //無理矢理SelectionBarを再度設定 SelectionBar := not SelectionBar; end; SelStart := SelStartBuff; SelLength := SelLengthBuff; SelTopIndex := TopIndexBuff; WrapChange; end; end; procedure TRichEditVx.WrapChange; begin if Assigned(FOnWrapChange) then FOnWrapChange(Self); end; //------------------------------------------- function TRichEditVx.GetSelectionBar: Boolean; begin // Result := FSelectionBar; end; procedure TRichEditVx.SetSelectionBar(Value: Boolean); begin if csDesigning in ComponentState then if FSelectionBar<>Value then //セレクション設計時 begin FSelectionBar := Value; if FSelectionBar then SendMessage(Handle, EM_SETOPTIONS,ECOOP_OR,ECO_SELECTIONBAR) else SendMessage(Handle, EM_SETOPTIONS,ECOOP_AND,not ECO_SELECTIONBAR ); if FVertical then SendMessage(Handle, EM_SETOPTIONS, ECOOP_OR, ECO_VERTICAL) else SendMessage(Handle, EM_SETOPTIONS, ECOOP_AND, not ECO_VERTICAL); RecreateWnd; end else else if FSelectionBar<>Value then begin //セレクション実行時 FSelectionBar := Value; Self.Visible := false; if FSelectionBar then SendMessage(Handle, EM_SETOPTIONS,ECOOP_OR,ECO_SELECTIONBAR) else SendMessage(Handle, EM_SETOPTIONS,ECOOP_AND,not ECO_SELECTIONBAR ); Self.Visible := true; Invalidate; SetImeColor {(ImeTColor[0],ImeBGColor[0],ImeTColor[1],ImeBGColor[1], ImeTColor[2],ImeBGColor[2],ImeTColor[3],ImeBGColor[3]);} end; end; //------------------------------------------- function TRichEditVx.GetVertical: Boolean; begin// if (ECO_VERTICAL and SendMessage(Handle,EM_GETOPTIONS,0,0))<>0 then FVertical := true else FVertical := false; Result := FVertical; end; procedure TRichEditVx.SetVertical(Value: Boolean); var // VisibleBuff: Boolean; ECO: Integer; begin if csDesigning in ComponentState then if FVertical <> Value then begin //縦設計時 FVertical := Value; if FVertical then begin WordWrap := true; SendMessage(Handle, EM_SETOPTIONS, ECOOP_OR, ECO_VERTICAL); end else SendMessage(Handle, EM_SETOPTIONS, ECOOP_AND, not ECO_VERTICAL); if FSelectionBar then //VerticalとSeleccionBarのバグ対策 Self.Perform(EM_SETOPTIONS,ECOOP_OR,ECO_SELECTIONBAR) else Self.Perform(EM_SETOPTIONS,ECOOP_AND,not ECO_SELECTIONBAR ); RecreateWnd; end else else //縦実行時 if FVertical <> Value then begin FVertical := Value; // VisibleBuff := Self.Visible; Self.Visible := false; ECO := SendMessage(Handle,EM_GETOPTIONS,0,0); if FVertical then begin SendMessage(Handle,EM_SETOPTIONS, ECOOP_SET,ECO or ECO_VERTICAL); WordWrap := true; inherited HideScrollBars := true; //Verticalで縦スクロールバーが inherited HideScrollBars := false; //勝手に消えてしまうバグを修正してる if FSelectionBar then SendMessage(Handle,EM_SETOPTIONS,ECOOP_OR,ECO_SELECTIONBAR) else SendMessage(Handle,EM_SETOPTIONS,ECOOP_AND,not ECO_SELECTIONBAR ); end else SendMessage(Handle,EM_SETOPTIONS, ECOOP_SET,ECO and (not ECO_VERTICAL)); Self.Visible := true;//VisibleBuff; Invalidate; SetImeColor; {(ImeTColor[0],ImeBGColor[0],ImeTColor[1],ImeBGColor[1], ImeTColor[2],ImeBGColor[2],ImeTColor[3],ImeBGColor[3]);} VerticalChange; //イベント発生 end; end; procedure TRichEditVx.VerticalChange; begin if Assigned(FOnVerticalChange) then FOnVerticalChange(Self); end; //------------------------------------------- //------------------------------ procedure TRichEditVx.LoadProperty; var // RegIniFile: TRegIniFile; begin if FRegKey<>'' then begin RegIniFile := TRegIniFile.Create(FRegKey); with RegIniFile do try finally RegIniFile.Free; end; end; end; procedure TRichEditVx.SaveProperty; var // RegIniFile: TRegIniFile; begin if FRegKey<>'' then begin RegIniFile := TRegIniFile.Create(FRegKey); with RegIniFile do try finally RegIniFile.Free; end; end; end; //------------------------------ //------------------------------Selxxx関係の処理 function TRichEditVx.GetSelLineIndex: Integer;//キャレット位置の行頭のIndex begin Result := Perform(EM_LINEINDEX,GetSelY,0); end; function TRichEditVx.GetSelNextLineIndex: Integer;//キャレット位置の次の行のIndex begin Result := Perform(EM_LINEINDEX,GetSelY+1,0); end; function TRichEditVx.GetSelX: Integer;//キャレットの横位置・最小は０ begin Result := SelStart - GetSelLineIndex; end; function TRichEditVx.GetSelY: Integer;//キャレットの行番号・最小は０ begin Result := Perform(EM_LINEFROMCHAR,SelStart,0); end; procedure TRichEditVx.SetLine(Value: Integer);//指定行番号の行頭に移動 begin SelStart := Perform(EM_LINEINDEX,Value,0); end; function TRichEditVx.GetSelTopIndex: Integer;//画面表示されている一番上のIndex begin Result := Perform(EM_GETFIRSTVISIBLELINE, 0, 0); end; procedure TRichEditVx.SetSelTopIndex(const Value: Integer); var LineCount: Integer; begin LineCount := Value - GetSelTopIndex; //差を求めてスクロール Perform(EM_LINESCROLL,0,LineCount); end; //------------------------------ function TRichEditVx.DeleteCRLF(Value: string): string;//CRLFを削除しています。 begin while pos(#13,Value)<>0 do Delete(Value,pos(#13,Value),1); while pos(#10,Value)<>0 do Delete(Value,pos(#10,Value),1); Result := Value; end; function TRichEditVx.GetSelTextCount: Integer;//CRLFを削除して半角文字数を出します begin Result := Length(DeleteCRLF(SelText)); end; function TRichEditVx.GetSelTextWideCount: Integer;//全角文字も1文字として文字数 begin Result := Length(WideString(DeleteCRLF(SelText))); end; function TRichEditVx.GetSelTextDelCRLF: string; begin Result := DeleteCRLF(SelText); end; //------------------------------ procedure TRichEditVx.LineDelete;//キャレットのある行を削除します begin //Changeを発生させるべきかな？（Undoの関係） LineSelect; SaveUndoMemory(umChange);//少し変えてみました ClearSelection; {umDeleteでは連続保存しないので、umChangeにしてみた} end; procedure TRichEditVx.LineSelect;//キャレットのある行を選択します begin//SelectChangeを発生させるべきかな？（Undoの関係） SelStart := GetSelLineIndex; SelLength := GetSelNextLineIndex - GetSelLineIndex; end; //------------------------------ //------------------------------ //UndoRedo処理 procedure TRichEditVx.AppMessage(var Msg: TMsg; var Handled: Boolean); begin if Msg.hwnd<>Self.Handle then exit; if Msg.message= WM_IME_STARTCOMPOSITION then SaveUndoMemory(umIME); Handled := false; { if Msg.message= WM_IME_ENDCOMPOSITION then //終わった時 if Msg.message= wm_ime_startcomposition then//Startする時 if Msg.message= WM_IME_COMPOSITION then //IMEでキーを打つたび } end; procedure TRichEditVx.KeyDown(var Key: Word; Shift: TShiftState); begin case Key of VK_HOME,VK_END, VK_LEFT,VK_RIGHT,VK_UP,VK_DOWN,VK_PRIOR,VK_NEXT: begin SaveUndoMemory(umSelect); end; VK_INSERT: begin FInsert := not FInsert; end; VK_F3,VK_F4:; VK_BACK,VK_DELETE: begin SaveUndoMemory(umDelete); end; VK_RETURN: begin SaveUndoMemory(umReturn); end; VK_TAB, Word('A')..Word('Z'): //キーとCtrlが同時に押されていないのなら if not((GetAsyncKeyState(VK_CONTROL) and $8000)<>0) then SaveUndoMemory(umKey); VK_CONTROL: ; VK_SHIFT: ; VK_PROCESSKEY: begin end; else SaveUndoMemory(umKey); //◆これが良いだろう。 end; //上の場合と処理は別として case Key of {これらのショートカットキーが押されていたらデータは送らない} Word('X'), Word('C'), Word('V'), Word('Z'), Word('A'): begin if (GetAsyncKeyState(VK_CONTROL) and $8000) <> 0 then begin Key := 0; end; end; end; {妙なデフォルトショートカットの防御だ} inherited KeyDown(Key,Shift); end; procedure TRichEditVx.KeyUp(var Key: Word; Shift: TShiftState); begin inherited KeyUp(Key,Shift); end; procedure TRichEditVx.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin //▽ SaveUndoMemory(umMouseSelect); inherited; end; procedure TRichEditVx.UndoMemoryClear; begin with FUndoMemory[0] do begin uStream.Clear; Lines.SaveToStream(uStream); uSelStart := SelStart; uSelLength := SelLength; uTopIndex := SelTopIndex; uText := Text; end; FUndoNowPoint := 0; FUndoFarPoint := 0; FUndoRecentPoint := 0; FUndoNowMode := umSelect; end; //あらゆる所から呼ばれる、TUndoModeを参照 procedure TRichEditVx.SaveUndoMemory(mode: TUndoMode); function SaveCheck(mode: TUndoMode): Boolean; //umMouseSelectはOLEDragDropの可能性があるのでumSelectと同じにはしない begin Result := true; //ContinueChange連続変化するとSaveしているときりない case mode of umSelect,umDelete,umKey,umContinueChange,umUndo,umReturn: //連続で指定されてもSaveしないもの //▽umMouseSelectは連続セーブもありです(OLEDDがあるから) begin if FUndoNowMode=mode then Result := false; end; end; end; function SaveCheck2(mode: TUndoMode): Boolean; begin //テキストが変化していないのにセーブする事の禁止 if FUndoNowMode = umUndo then begin Result := false; exit; //Now=umUndoなら重複セーブになるのでfalse //テキストが変化しないので後から引っかかるけどここでハジイテおく end; if (mode=umChange)or(mode=umContinueChange) then begin Result := true; exit; end; if FUndoMemory[FUndoNowPoint].uText = Self.Text then begin Result := false; exit; end; Result := true; end; procedure SaveMemory; begin Inc(FUndoNowPoint); if FUndoNowPoint>UndoCount-1 then FUndoNowPoint := 0; with FUndoMemory[FUndoNowPoint] do begin uStream.Clear; Lines.SaveToStream(uStream); uSelStart := SelStart; uSelLength := SelLength; uTopIndex := SelTopIndex; uText := Text; end; FUndoRecentPoint := FUndoNowPoint; if FUndoFarPoint=FUndoRecentPoint then begin Inc(FUndoFarPoint); if FUndoFarPoint>UndoCount-1 then FUndoFarPoint := 0; end; //普通に動作すればNowPoint+1、Recent=Now、 //Farは重なっているなら一つ増加させる end; begin if (SaveCheck(mode)) then begin if (SaveCheck2(mode)) then begin SaveMemory; { if Color=clwhite then Color := clSilver else Color := clWhite; } end; end; FUndoNowMode := mode; //必ずここを通過して状態がNowModeに代入される end; procedure TRichEditVx.LoadUndoMemory(UndoPoint: Integer); var SelChangeeventBuff, ChangeEventBuff: TNotifyEvent; begin //Undo,Redoメソッドからのみ呼ばれる SelChangeEventBuff := OnSelectionChange; ChangeEventBuff := OnChange; OnSelectionChange := nil; OnChange := nil;{イベントを発生しないようにする} with FUndoMemory[UndoPoint] do begin uStream.Position := 0; Lines.BeginUpdate; Lines.LoadFromStream(uStream); SelTopIndex := uTopIndex; SelStart := uSelStart; SelLength := uSelLength; Lines.EndUpdate; end; OnSelectionChange := SelChangeEventBuff; OnChange := ChangeEventBuff;{イベントの復帰} Change;{Changeイベントを発生させておく} end; function TRichEditVx.CanUndo: Boolean; begin Result := true; if (FUndoNowPoint)=(FUndoFarPoint) then if FUndoMemory[FUndoNowPoint].uText = Self.Text then begin Result := false; end; { ここのアルゴリズムは大変苦労した。 よく思い浮かべて見ると良い 結局 NowとFarが同じポイントを指していて 更にNowのセーブポイントのテキストと現在のテキストの変化が無い場合 CanUndo=falseになる。 それだけだ。 NowとFarが同じになる場合はスタート時と連続Undo時のみだが それらの条件を調べる必要は無い } end; function TRichEditVx.CanRedo: Boolean; begin if (FUndoNowPoint)=(FUndoRecentPoint) then Result := false else Result := true; { こちらもCanUndoと同様であり NowとRecentが同じ所を指している場合だけ CanRedo=falseとすればよい 他には条件を考えない 考えると、いろいろバグが出てくる。 Simple is Best } end; procedure TRichEditVx.Undo; begin if CanUndo then begin if FUndoNowMode=umUndo then begin dec(FUndoNowPoint); if FUndoNowPoint<0 then FUndoNowPoint := UndoCount-1; LoadUndoMemory(FUndoNowPoint); end else begin SaveUndoMemory(umUndo); Dec(FUndoNowPoint); if FUndoNowPoint<0 then FUndoNowPoint := UndoCount-1; LoadUndoMemory(FUndoNowPoint); end; //連続Undoの場合はSaveUndoMemoryは必要無いので行わない //他の状態からumUndoならSaveUndoしておく //NowPointがひとつ減る end; end; procedure TRichEditVx.Redo; begin if CanRedo then begin Inc(FUndoNowPoint); if FUndoNowPoint>UndoCount-1 then FUndoNowPoint := 0; LoadUndoMemory(FUndoNowPoint); FUndoNowMode := umUndo; end; //NowPointがひとつ増える end; //------------------------------ {SelAttributesとParagraphのアクセスメソッド} procedure TRichEditVx.SetSelColor(Value: TColor); begin if (SelAttributes.Color=Value) and (caColor in SelAttributes.ConsistentAttributes) then exit; SaveUndoMemory(umChange); SelAttributes.Color := Value; end; procedure TRichEditVx.SetSelName(Value: String); begin if (SelAttributes.Name=Value) and (caFace in SelAttributes.ConsistentAttributes) then exit; //変更する必要の無い場合は変更しない。 SaveUndoMemory(umChange); SelAttributes.Name := Value; end; procedure TRichEditVx.SetSelSize(Value: Integer); begin if (SelAttributes.Size=Value) and (caSize in SelAttributes.ConsistentAttributes) then exit; SaveUndoMemory(umChange); SelAttributes.Size := Value; end; procedure TRichEditVx.SetSelStyle(Value: TFontStyles); begin SaveUndoMemory(umChange); SelAttributes.Style := Value; end; procedure TRichEditVx.SetParaAlignment(Value: TAlignment); begin if Paragraph.Alignment<>Value then begin SaveUndoMemory(umChange); Paragraph.Alignment := Value; end; end; procedure TRichEditVx.SetParaFirstIndent(Value: Integer); begin if Paragraph.FirstIndent<>Value then begin SaveUndoMemory(umContinueChange); Paragraph.FirstIndent := Value; end; end; procedure TRichEditVx.SetParaLeftIndent(Value: Integer); begin if Paragraph.LeftIndent<>Value then begin SaveUndoMemory(umContinueChange); Paragraph.LeftIndent := Value; end; end; procedure TRichEditVx.SetParaRightIndent(Value: Integer); begin if Paragraph.RightIndent<>Value then begin SaveUndoMemory(umContinueChange); Paragraph.RightIndent := Value; end; end; procedure TRichEditVx.SetParaNumbering(Value: TNumberingStyle); begin if Paragraph.Numbering<>Value then begin SaveUndoMemory(umChange); Paragraph.Numbering := Value; end; end; //------------------------------ procedure TRichEditVx.Clear; begin inherited; end; procedure TRichEditVx.ClearSelection; begin SaveUndoMemory(umDelete); inherited ; end; procedure TRichEditVx.CopyToClipboard; begin inherited ; end; procedure TRichEditVx.CutToClipboard; begin SaveUndoMemory(umDelete); inherited ; end; procedure TRichEditVx.PasteFromClipboard; begin SaveUndoMemory(umPaste); inherited ; end; procedure TRichEditVx.SelectAll; begin inherited ;// end; //ごめんなさい、FindBackText、バグバグ＆超低速なので使用禁止です。 function TRichEditVx.FindBackText(const SearchStr: string; StartPos, SearchLength: Integer; Options: TSearchTypes): Integer; {StartPosからSearchLengthの長さの範囲を後方から検索する} var StartPosBuff: Integer; LengthBuff: Integer; begin if FindText(SearchStr,StartPos,SearchLength,Options)=-1 then begin Result := -1; exit; end; StartPosBuff := StartPos;LengthBuff := SearchLength; while FindText(SearchStr,StartPosBuff,LengthBuff,Options)<>-1 do begin StartPosBuff := FindText(SearchStr,StartPosBuff,LengthBuff,Options) + 1; LengthBuff := StartPos + SearchLength - StartPosBuff; if LengthBuff<0 then begin ShowMessage('ここに入る事はないです'); Break; end; end; Result := StartPosBuff- 1; end; {文字列を指定範囲にて置き換える、戻り値は置き換えた数} function TRichEditVx.ReplaceTextAll(const SearchStr, ReplaceStr: String; StartPos, SearchLength: Integer; Options: TSearchTypes): Integer; {SelStartの位置を修正しています} var StartPosBuff, LengthBuff, SelStartBuff, SelLengthBuff, TopIndexBuff: Integer; SelChangeEventBuff, ChangeEventBuff: TNotifyEvent; begin Result := 0; if FindText(SearchStr, StartPos, SearchLength, Options) = -1 then exit; SelChangeEventBuff := OnSelectionChange; ChangeEventBuff := OnChange; OnSelectionChange := nil; OnChange := nil;{イベントを発生しないようにする} Lines.BeginUpdate; SaveUndoMemory(umChange); TopIndexBuff := SelTopIndex; SelStartBuff := SelStart; SelLengthBuff := SelLength; //------------------------------ StartPosBuff := StartPos ; LengthBuff := SearchLength; while FindText(SearchStr, StartPosBuff, LengthBuff, Options) <> -1 do begin SelStart := FindText(SearchStr,StartPosBuff,LengthBuff,Options) ; SelLength := Length(SearchStr); SelText := ReplaceStr; Inc(Result); StartPosBuff := SelStart + SelLength; LengthBuff := (StartPos + SearchLength) - StartPosBuff + ( (Length(ReplaceStr) - Length(SearchStr))* Result ); //検索長さは「最初の検索終了位置-今から検索する位置+置き換えによって増加した文字数」で計算 if LengthBuff < 0 then begin ShowMessage('ここに入る事はないです'); Break; end; end;//while //------------------------------ SelTopIndex := TopIndexBuff; SelStart := SelStartBuff; SelLength := SelLengthBuff; OnSelectionChange := SelChangeEventBuff; OnChange := ChangeEventBuff;{イベントの復帰} Change;{Changeイベントを発生させておく} Lines.EndUpdate; end; function TRichEditVx.CRLFNextSearch(Pre: boolean): Integer; begin Result := FindText(#13#10,SelStart,length(Text)-SelStart,[]); if Result=-1 then Result := Length(Text) else begin if Pre then else Result := Result + 2; end; end; function TRichEditVx.CRLFPreSearch(Pre: boolean): Integer; //現在のSelStartから前の方向にCRLFを探す begin {FindTextBackは動作が遅くて使用不可 Result := FindBackText(#13#10,0,SelStart,[]); if Result=-1 then Result := 0 else begin if Pre then else Result := Result+2; end; } Result := BackAnsiPos(string(#13#10),String(copy(Text,1,SelStart))); if Result=0 then else begin if Pre then Result := Result -1 else Result := Result +1; end; end; procedure TRichEditVx.Indent(IndentStr: string); var SelChangeEventBuff,ChangeEventBuff: TNotifyEvent; SelStartBuff,SelLengthBuff,IndentCount: Integer; procedure IndentRun; begin SelText := IndentStr; Inc(IndentCount,length(IndentStr)); SelStart := CRLFNextSearch(false); end; begin SelChangeEventBuff := OnSelectionChange; ChangeEventBuff := OnChange; OnSelectionChange := nil; OnChange := nil; Lines.BeginUpdate; SaveUndoMemory(umContinueChange); SelStartBuff := SelStart; SelLengthBuff := SelLength; //------------------------------ IndentCount := 0; SelStart := CRLFPreSearch(false); IndentRun; while (SelStartBuff+SelLengthBuff+IndentCount-3)>SelStart do //?わからん while SelStartBuff+SelLengthBuff>SelStart do IndentRun; //------------------------------ SelStart := SelStartBuff+ Length(IndentStr); SelLength := SelLengthBuff+ IndentCount- Length(IndentStr); Lines.EndUpdate; OnSelectionChange := SelChangeEventBuff; OnChange := ChangeEventBuff; Change; end; procedure TRichEditVx.UnIndent; var SelChangeEventBuff,ChangeEventBuff: TNotifyEvent; SelStartBuff,SelLengthBuff, FirstUnIndentLength,UnIndentLength: Integer; TextBuff: string; procedure UnIndentRun; begin SelLength := SelLength+1; if SelLength=0 then SelLength := SelLength+2; SelText := ''; // Perform(WM_KEYDOWN,VK_DELETE,1); // Perform(WM_KEYUP,VK_DELETE,1); end; begin SelChangeEventBuff := OnSelectionChange; ChangeEventBuff := OnChange; OnSelectionChange := nil; OnChange := nil; SaveUndoMemory(umContinueChange); SelStartBuff := SelStart; SelLengthBuff := SelLength; //------------------------------ TextBuff := Text; SelStart := CRLFPreSearch(false); UnIndentRun; FirstUnIndentLength := length(TextBuff) - Length(Text); UnIndentLength := FirstUnIndentLength; SelStart := CRLFNextSearch(false); while (SelStartBuff+SelLengthBuff-UnIndentLength-3)>SelStart do begin if Lines[GetSelY]<>'' then begin UnIndentRun; UnIndentLength := Length(TextBuff)- Length(Text); end;//その行にちゃんと文字があるなら削除する SelStart := CRLFNextSearch(false); end; UnIndentLength := Length(TextBuff)- Length(Text); SelStart := SelStartBuff; if GetSelX<>0 then SelStart := SelStart - FirstUnIndentLength; //↑SelStartが行頭にあったらそのまま、 //行頭以外なら引かれた分ひきかえす SelLength := SelLengthBuff- UnIndentLength+FirstUnIndentLength; //------------------------------ OnSelectionChange := SelChangeEventBuff; OnChange := ChangeEventBuff; Change; end; function TRichEditVx.CanPaste: Boolean; begin if Clipboard.HasFormat(CF_TEXT) then Result:= true else Result:= false; end; procedure TRichEditVx.SelTextChange(Value: TTextChange); begin //SelLength=0ならfalse SaveUndoMemory(umChange); case Value of // tcZenToHank: SelText := ZenToHank(SelText); // tcHankToZen: SelText := HankToZen(SelText); // tcKanaToZen: SelText := KanaToZen(SelText); // tcUpper : SelText := AnsiUpperCase(SelText); // tcLower : SelText := AnsiLowerCase(SelText); tcZenToHank: SelText := ZenkakuToHankaku(SelText); tcHankToZen: SelText := HankakuToZenkaku(SelText); tcKanaToZen: SelText := ConvertHanKataToZenKata(SelText); tcUpper : SelText := UpperCase(SelText); tcLower : SelText := LowerCase(SelText); end end; end.