memocomponentunit.pas

这是一个有关文本编辑器的源程序,支持彩色语法,你可以任意修改,修改后发给我一份

implementation

uses
	ClipBrd;

const
	MaxScrollTolerance = 2;
	ScrollOffset = 10;

procedure Register;
begin
	RegisterComponents('Edit Controls', [TMemoComponent]);
end;

{ TMemoComponentStrings Definition }

type
	TMemoComponentStrings = class(TStrings)
	private
		Memo: TMemoComponent;
	protected
		function Get(LineIndex: Integer): string; override;
		function GetCount: Integer; override;
		function GetTextStr: string; override;
		procedure Put(LineIndex: Integer; const S: string); override;
		procedure SetTextStr(const Value: string); override;
	public
		procedure Clear; override;
		procedure Delete(LineIndex: Integer); override;
		procedure Insert(LineIndex: Integer; const S: string); override;
	end;

{ Helper Functions }

function TextCell(CellRow, CellCol: Integer): TTextCell;
begin
	with Result do begin
		Row := CellRow;
		Col := CellCol;
	end;
end;

{ TMemoComponent }

procedure TMemoComponent.CancelDragging;
begin
	if FSelecting or FDragging then begin
		if HandleAllocated then
			KillTimer (Handle, 1);
		FSelecting := False;
		FDragging := False;
		Screen.Cursor := crDefault;
	end;
end;

procedure TMemoComponent.CellFromScrCol(var Cell: TTextCell);
var
	I,
	Col,
	Count: Integer;
begin
	if Cell.Row < 1 then
		Cell.Row := 1;
	if Cell.Row > LineCount then
		Cell.Row := LineCount;
	if TabSize <> 1 then begin
		Count := 0;
		I := CellToCharIdx (TextCell (Cell.Row, 1));
		Col := Cell.Col;
		Cell.Col := 1;
		while Count < Col do begin
			if (I <= TextLength) and (Text [I] = #9) then
				Count := (Count div TabSize + 1) * TabSize
			else
				Inc (Count);
			if Count < Col then begin
				Inc (I);
				Inc (Cell.Col);
			end;
		end;
	end;
	if Cell.Col < 1 then
		Cell.Col := 1;
	if Cell.Col > LineLength [Cell.Row] + 1 then
		Cell.Col := LineLength [Cell.Row] + 1;
end;

function TMemoComponent.CellFromScrColToScrCol(var Cell: TTextCell):
	Integer;
var
	I,
	Col,
	Count: Integer;
begin
	if Cell.Row < 1 then
		Cell.Row := 1;
	if Cell.Row > LineCount then
		Cell.Row := LineCount;
	if TabSize = 1 then
		Result := Cell.Col
	else begin
		Result := 1;
		Count := 0;
		I := CellToCharIdx (TextCell (Cell.Row, 1));
		Col := Cell.Col;
		Cell.Col := 1;
		while Count < Col do begin
			Result := Count + 1;
			if (I <= TextLength) and (Text [I] = #9) then
				Count := (Count div TabSize + 1) * TabSize
			else
				Inc (Count);
			if Count < Col then begin
				Inc (I);
				Inc (Cell.Col);
			end;
		end;
	end;
	if Cell.Col < 1 then
		Cell.Col := 1;
	if Cell.Col > LineLength [Cell.Row] + 1 then
		Cell.Col := LineLength [Cell.Row] + 1;
end;

function TMemoComponent.CellToCharIdx(Cell: TTextCell): Integer;
begin
	with Cell do
		if Row <= 0 then
			Result := Col
		else if Row > LineCount then
			Result := TextLength + 2 + Col
		else
			Result := FLineStarts.Items [Row - 1] + Col - 1;
end;

function TMemoComponent.CellToScrCol(Cell: TTextCell): Integer;
var
	I,
	Idx: Integer;
begin
	if TabSize = 1 then
		Result := Cell.Col
	else begin
		Result := 0;
		Idx := CellToCharIdx (TextCell (Cell.Row, 1));
		for I := Idx to Idx + Cell.Col - 2 do begin
			if (I > 0) and (I <= TextLength) and (Text [I] = #9) then
				Result := (Result div TabSize + 1) * TabSize
			else
				Inc (Result);
		end;
		Inc (Result);
	end;
end;

procedure TMemoComponent.Change;
begin
	if not DontNotify then begin
		inherited Changed;
		if Assigned (FOnChange) then
			FOnChange (Self);
		if Assigned (FOnChangePrivate) then
			FOnChangePrivate (Self);
	end;
end;

procedure TMemoComponent.ChangeIndent(Change: Integer);
var
	I,
	RS,
	RE,
	L,
	CurPos: Integer;
begin
	if Change <> 0 then begin
		DontNotify := True;
		try
			VisibleRange.DoChanging;
			try
				MakeUndoOperation (CreateUndoBeginEndBlock);
				RS := Selection.StartRowCol.Row;
				RE := Selection.EndRowCol.Row;
				if RE < RS then
					RE := RS;
				for I := RS to RE do begin
					CurPos := CellToCharIdx (TextCell (I, 1));
					if Change > 0 then begin
						while (CurPos <= TextLength) and (Text [CurPos] in [#9, #21]) do
							Inc (CurPos);
						L := Change;
						with TMCRange.Create (nil) do begin
							Editor := Self;
							RStart := CurPos;
							RLength := 0;
							Text := StringOfChar (#9, L);
							if (Selection.RLength > 0) and (Selection.RStart = REnd + 1) then
								Selection.RStart := RStart;
							Free;
						end;
					end else begin
						L := 0;
						while (CurPos <= TextLength) and (Text [CurPos] in [#9, #21]) do begin
							Inc (CurPos);
							Inc (L);
						end;
						if L > -Change then
							L := -Change;
						with TMCRange.Create (nil) do begin
							Editor := Self;
							RStart := CurPos - L;
							REnd := CurPos - 1;
							Text := '';
							Free;
						end;
					end;
				end;
				MakeUndoOperation (CreateUndoBeginEndBlock);
			finally
				VisibleRange.DoDiscardChanges;
			end;
			Selection.HideCaret;
			try
				VisibleRange.DrawRange;
				Selection.UpdateCaretPos;
			finally
				Selection.ShowCaret;
			end;
		finally
			DontNotify := False;
		end;
		Self.Change;
		SelectionChange;
	end;
end;

function TMemoComponent.CharIdxToCell(CharIdx: Integer): TTextCell;
var
	LineIdx: Integer;
begin
	with FLineStarts do begin
		if TextLength > 0 then
			LineIdx := Count * CharIdx div TextLength - 1
		else
			LineIdx := 0;
		if LineIdx < 0 then
			LineIdx := 0;
		if LineIdx >= Count then
			LineIdx := Count - 1;
		while (LineIdx < Count - 1) and (Items [LineIdx] < CharIdx) do
			Inc (LineIdx);
		while (LineIdx > 0) and (Items [LineIdx] > CharIdx) do
			Dec (LineIdx);
		with Result do begin
			Row := LineIdx + 1;
			Col := CharIdx - Items [LineIdx] + 1;
		end;
	end;
end;

procedure TMemoComponent.Clear;
begin
	Text := '';
end;

procedure TMemoComponent.ClearRedo;
begin
	while CanRedo do
		GetLastRedo;
end;

procedure TMemoComponent.ClearSelection;
begin
	Perform (wm_Clear, 0, 0);
end;

procedure TMemoComponent.ClearUndo;
begin
	while CanRedo do
		GetLastRedo;
	while CanUndo do
		GetLastUndo;
	Change;
end;

procedure TMemoComponent.CMFontChanged(var Message: TMessage);
begin
	inherited;
	UpdateFontSize;
	VisibleRange.Update;
	VisibleRange.DrawRange;
end;

procedure TMemoComponent.CMMouseWheel(var Message: TCMMouseWheel);
var
	Msg: TWMScroll;
	I: Integer;
begin
	with Msg do begin
		Msg := wm_VScroll;
		if Message.WheelDelta >= 0 then
			ScrollCode := sb_LineUp
		else
			ScrollCode := sb_LineDown;
	end;
	for I := 1 to 3 do
		WMVScroll (Msg);
	Message.Result := 1;
end;

procedure TMemoComponent.CMWantSpecialKey(var Message: TCMWantSpecialKey);
begin
	inherited;
	if not (csDesigning in ComponentState) then
		if Message.CharCode in [vk_Left, vk_Right, vk_Up, vk_Down, vk_Prior, vk_Next, vk_Home, vk_End, vk_Tab, vk_Clear, vk_Delete, vk_Insert] then
			Message.Result := 1;
end;

procedure TMemoComponent.CopyToClipboard;
begin
	Perform (wm_Copy, 0, 0);
end;

constructor TMemoComponent.Create(AOwner: TComponent);
begin
	inherited;
	FBitmapped := False;
	FText := '';
	FLineStarts := TIntegerList.Create;
	FLineStarts.Add (1);
	FLines := TMemoComponentStrings.Create;
	TMemoComponentStrings(FLines).Memo := Self;
	FTrackedRanges := TMCRanges.Create (Self);
	FWholeText := TWholeTextRange.Create (nil);
	FWholeText.Editor := Self;
	FVisibleRange := TVisibleRange.Create (TrackedRanges);
	FSelection := TSelectionRange.Create (TrackedRanges);
	with FSelection do begin
		FRStart := 1;
		FREnd := 0;
	end;
	FTabSize := 2;
	FScrollBars := ssBoth;
	FBorderStyle := bsSingle;
	FLeftMargin := 2;
	FTopMargin := 0;
	FAllowUndo := True;
	ControlStyle := ControlStyle + [csOpaque] - [csNoStdEvents];
	DoubleBuffered := False;
	Constraints.MinWidth := 64;
	Constraints.MinHeight := 64;
	TabStop := True;
	ParentColor := False;
	Color := clWindow;
	Font.Name := 'Courier New';
	Font.Size := 10;
	Width := 129;
	Height := 129;
end;

procedure TMemoComponent.CreateParams(var Params: TCreateParams);
const
	ScrollBar: array [TScrollStyle] of DWORD = (0, WS_HSCROLL, WS_VSCROLL,
		WS_HSCROLL or WS_VSCROLL);
begin
	inherited;
	with Params do begin
		Style := Style or ScrollBar [FScrollBars];
		if NewStyleControls and Ctl3D and (FBorderStyle = bsSingle) then begin
			Style := Style and not WS_BORDER;
			ExStyle := ExStyle or WS_EX_CLIENTEDGE;
		end;
	end;
end;

function TMemoComponent.CreateSplitRanges(Range: TCustomRange): TFormattedRangeArray;
var
	RS,
	RE: Integer;
begin
	RS := Range.RStart;
	if (not Selection.Hidden) and (Selection.RLength > 0) then begin
		RE := Selection.RStart - 1;
		if RE > Range.REnd then
			RE := Range.REnd;
		if RE >= RS then begin
			SetLength (Result, Length (Result) + 1);
			Result [High (Result)] := TNormalFormattedRange.Create (nil);
			with Result [High (Result)] do begin
				FreeWhenDone := True;
				Editor := Self;
				RStart := RS;
				REnd := RE;
			end;
		end;
		RS := Selection.RStart;
		if RS < Range.RStart then
			RS := Range.RStart;
		RE := Selection.REnd;
		if RE > Range.REnd then
			RE := Range.REnd;
		if RE >= RS then begin
			SetLength (Result, Length (Result) + 1);
			Result [High (Result)] := TFormattedRange.Create (nil);
			with Result [High (Result)] do begin
				FreeWhenDone := True;
				Editor := Self;
				RStart := RS;
				REnd := RE;
				Color := clHighlight;
				Font.Assign (Self.Font);
				Font.Color := clHighlightText;
			end;
		end;
		RS := Selection.REnd + 1;
		if RS < Range.RStart then
			RS := Range.RStart;
	end;
	RE := Range.REnd;
	if RE >= RS then begin
		SetLength (Result, Length (Result) + 1);
		Result [High (Result)] := TNormalFormattedRange.Create (nil);
		with Result [High (Result)] do begin
			FreeWhenDone := True;
			Editor := Self;
			RStart := RS;
			REnd := RE;
		end;
	end;
end;

function TMemoComponent.CreateUndoBeginEndBlock: PUndoOperation;
begin
	New (Result);
	with Result^ do begin
		RStart := -1;
		REnd := -1;
		NewText := '';
	end;
end;

procedure TMemoComponent.CreateWnd;
begin
	inherited;
	UpdateFontSize;
	if HandleAllocated and not (csDesigning in ComponentState) then
		SetClassLong (Handle, gcl_HCursor, LoadCursor (0, idc_IBeam));
end;

procedure TMemoComponent.CutToClipboard;
begin
	Perform (wm_Cut, 0, 0);
end;

procedure TMemoComponent.DblClick;
var
	WS,
	WE: Integer;
begin
	inherited;
	FDblClicked := True;
	WS := Selection.RStart;
	while (WS > 1) and (Text [WS - 1] in ['A'..'Z', 'a'..'z', '0'..'9', '_', '$', '#']) do
		Dec (WS);
	WE := Selection.REnd;
	while (WE < TextLength) and (Text [WE + 1] in ['A'..'Z', 'a'..'z', '0'..'9', '_', '$', '#']) do
		Inc (WE);
	Selection.RStart := WS;
	Selection.REnd := WE;
end;