memocomponentunit.pas

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

				DontNotify := False;
				Change;
				SelectionChange;
			end;
			DontNotify := False;
		end;
		CancelDragging;
	end;
	FDblClicked := False;
	if Assigned (DragOrigRange) then begin
		DragOrigRange.Free;
		DragOrigRange := nil;
	end;
end;

procedure TMemoComponent.Paint;
begin
	inherited;
	if not DrawingSuspended then begin
		Selection.HideCaret;
		if Bitmapped then begin
			UpdateDrawBmp;
			Canvas.Draw (0, 0, DrawBmp)
		end else begin
			DrawBorder (Rect (0, 0, LeftMargin, ClientHeight), Rect (0, 0, ClientWidth, TopMargin), Canvas);
			VisibleRange.DrawRange;
		end;
		Selection.ShowCaret;
	end;
end;

procedure TMemoComponent.PasteFromClipboard;
begin
	Perform (wm_Paste, 0, 0);
end;

procedure TMemoComponent.ReCreateCaret;
begin
	if FHasFocus and HandleAllocated then begin
		FreeCaret;
		CreateCaret (Handle, 0, 2, FontHeight - 2);
		FCaretCreated := True;
		with Selection do begin
			UpdateCaretPos;
			ShowCaret;
		end;
	end;
end;

procedure TMemoComponent.Redo;
begin
	Perform (em_Undo, 1, 0);
end;

procedure TMemoComponent.RemoveTrSp;
var
	I: Integer;
begin
	DontNotify := True;
	try
		Selection.DoChanging;
		try
			for I := 1 to LineCount do
				RemoveTrSpFromLine (I);
		finally
			Selection.DoChange;
		end;
	finally
		DontNotify := False;
	end;
	Self.Change;
end;

procedure TMemoComponent.RemoveTrSpFromLine(LineIdx: Integer);
var
	I,
	LastChar: Integer;
	S: string;
begin
	with TMCRange.Create (nil) do try
		Editor := Self;
		StartRowCol := TextCell (LineIdx, 1);
		EndRowCol := TextCell (LineIdx + 1, -2);
		S := Text;
		LastChar := 0;
		for I := Length (S) downto 1 do
			if not (S [I] in [' ', #9]) then begin
				LastChar := I;
				Break;
			end;
		if LastChar < Length (S) then begin
			RStart := RStart + LastChar;
			Clear;
		end;
	finally
		Free;
	end;
end;

procedure TMemoComponent.RemoveTrSpFromString(var Str: string; IncludeLastLine: Boolean);
var
	I,
	P,
	NextChar,
	CurLineStart: Integer;
begin
	CurLineStart := 1;
	repeat
		NextChar := Length (Str) + 1;
		for I := CurLineStart to Length (Str) + 1 do begin
			if ((I <= Length (Str)) and (Str [I] = #13)) or (IncludeLastLine and (I > Length (Str))) then begin
				NextChar := I + 1;
				for P := I - 1 downto CurLineStart do begin
					if Str [P] in [' ', #9] then
						Delete (Str, P, 1)
					else
						Break;
				end;
				Break;
			end;
		end;
		while (NextChar <= Length (Str)) and (Str [NextChar] in [#13, #10]) do
			Inc (NextChar);
		CurLineStart := NextChar;
	until NextChar > Length (Str);
end;

procedure TMemoComponent.ReplaceText(Range: TCustomRange; const NewText: string);
var
	RS,
	I,
	L,
	LI,
	EI,
	LC,
	P,
	BC,
	LnCh,
	RangeStart,
	RangeEnd,
	IStart,
	IEnd: Integer;
	S: string;
	BlUndo,
	PUN,
	ChangedTopRow: Boolean;
	Op: PUndoOperation;
begin
	PUN := False;
	LnCh := 0;
	RangeStart := Range.RStart;
	RangeEnd := Range.REnd;
	with Selection do begin
		DoChanging;
		FOldSel.Free;
		FOldSel := nil;
	end;
	RS := RangeStart;
	S := AdjustLineBreaks (NewText);
	if RemoveTrailingSpaces then
		RemoveTrSpFromString (S);
	L := Length (S);
	if AllowUndo and not (FInUndo or FDragging) then begin
		ClearRedo;
		BlUndo := False;
		Op := FUndoStack;
		if Assigned (Op) then begin
			if Range.RLength <= 0 then begin
				if (L > 0) and (Length (Op.NewText) <= 0) and (Op.REnd >= Op.RStart) then begin
					if Op.REnd + 1 = RS then begin
						Inc (Op.REnd, L);
						BlUndo := True;
					end;
				end;
			end else begin
				if (L <= 0) and (Length (Op.NewText) > 0) and (Op.REnd < Op.RStart) then begin
					if Op.RStart = RS then begin
						Op.NewText := Op.NewText + Range.Text;
						BlUndo := True;
					end else if Op.RStart = Range.REnd + 1 then begin
						Dec (Op.RStart, Range.RLength);
						Dec (Op.REnd, Range.RLength);
						Op.NewText := Range.Text + Op.NewText;
						BlUndo := True;
					end;
				end;
			end;
		end;
		if not BlUndo then begin
			New (Op);
			Op.RStart := RS;
			Op.REnd := RS + L - 1;
			Op.NewText := Range.Text;
			MakeUndoOperation (Op);
		end;
	end;
	LI := CharIdxToCell(Range.RStart).Row;
	EI := CharIdxToCell(Range.REnd+1).Row;
	LC := L - Range.RLength;
	if VisualLineLength [EI] >= FLongestLineLength then begin
		FLongestLineLength := 0;
		PUN := True;
	end;
	with FLineStarts do
		if (Range.RStart = 1) and (Range.REnd = TextLength) then begin
			LnCh := Count - 1;
			Clear;
			Add (1);
			FLongestLineLength := 0;
			PUN := True;
		end else
			for I := EI - 1 downto LI do begin
				if (not PUN) and (VisualLineLength [I + 1] >= FLongestLineLength) then begin
					FLongestLineLength := 0;
					PUN := True;
				end;
				Delete (I);
				Dec (LnCh);
			end;
	Delete (FText, RS, Range.RLength);
	Insert (S, FText, RS);
	FTextLength := Length (FText);
	BC := 0;
	for P := 1 to Length (S) - 1 do
		if S [P] = #13 then begin
			FLineStarts.Insert (LI + BC, Range.RStart + P + 1);
			Inc (LnCh);
			Inc (BC);
		end;
	with FLineStarts do begin
		for I := LI + BC to Count - 1 do
			Items [I] := Items [I] + LC;
		if FLongestLineLength <= 0 then begin
			IStart := 0;
			IEnd := Count - 1;
		end else begin
			IStart := LI - 1;
			IEnd := LI + BC;
		end;
		for I := IStart to IEnd do
			if (I >= 0) and (I < Count) then begin
				P := VisualLineLength [I + 1];
				if P > FLongestLineLength then begin
					FLongestLineLength := P;
					PUN := True;
				end;
			end;
	end;
	with TrackedRanges do
		for I := Count - 1 downto 0 do
			if (Items [I] <> Range) and (Items [I] <> VisibleRange) then
				Items[I].InternalDoMove (RangeStart, RangeEnd, LC);
	if Assigned (FOnReplaceText) then
		FOnReplaceText (Self, RS, LC);
	ChangedTopRow := False;
	if LnCh <> 0 then
		with VisibleRange do
			if LI < FTopRow then begin
				Inc (FTopRow, LnCh);
				ChangedTopRow := True;
			end;
	if Range is TSelectionRange then begin
		TSelectionRange(Range).NoSelAtPos (RS + L);
	end else
		Range.RLength := L;
	TextChangeNotification (RS, L - LC, L);
	if PUN or (LnCh <> 0) then
		UpdatePageSize;
	with TMCRange.Create (nil) do begin
		Editor := Self;
		if ChangedTopRow then
			RStart := VisibleRange.RStart
		else
			RStart := RS;
		if LnCh <> 0 then
			EndRowCol := VisibleRange.EndRowCol
		else
			EndRowCol := TextCell (EI + 1, 0);
		DrawRange;
		Free;
	end;
	TextChangeNotificationAfter;
	Selection.DoChange;
	Change;
end;

function TMemoComponent.ScrCellToScrPoint(Cell: TTextCell): TPoint;
begin
	with Cell do
		Result := Point ((Col - 1) * FontWidth + LeftMargin, (Row - 1) * FontHeight + TopMargin);
end;

procedure TMemoComponent.ScrollCaret;
begin
	Selection.ScrollInView (4);
end;

function TMemoComponent.ScrPointToScrCell(P: TPoint): TTextCell;
begin
	with P do
		Result := TextCell ((Y - TopMargin) div FontHeight + 1, (X - LeftMargin + FontWidth div 2) div FontWidth + 1);
end;

procedure TMemoComponent.SelectAll;
begin
	Selection.Assign (WholeText);
end;

procedure TMemoComponent.SelectionChange;
begin
	if not DontNotify then begin
		if Assigned (FOnSelectionChange) then
			FOnSelectionChange(Self);
	end;
end;

procedure TMemoComponent.SetAllowUndo(const Value: Boolean);
begin
	FAllowUndo := Value;
	if not FAllowUndo then
		ClearUndo;
end;

procedure TMemoComponent.SetAlwaysShowCaret(const Value: Boolean);
begin
	if FAlwaysShowCaret <> Value then begin
		FAlwaysShowCaret := Value;
		Selection.ShowCaret;
	end;
end;

procedure TMemoComponent.SetBitmapped(const Value: Boolean);
begin
	FBitmapped := Value;
	if (not Value) and Assigned (DrawBmp) then begin
		DrawBmp.Free;
		DrawBmp := nil;
	end;
end;

procedure TMemoComponent.SetBorderStyle(const Value: TBorderStyle);
begin
	if FBorderStyle <> Value then begin
		FBorderStyle := Value;
		RecreateWnd;
	end;
end;

procedure TMemoComponent.SetLeftMargin(const Value: Integer);
begin
	if FLeftMargin <> Value then begin
		FLeftMargin := Value;
		UpdatePageSize;
		VisibleRange.Update;
		VisibleRange.DrawRange;
		Selection.UpdateCaretPos;
	end;
end;

procedure TMemoComponent.SetLines(const Value: TStrings);
begin
	FLines.Assign (Value);
end;

procedure TMemoComponent.SetReadOnly(const Value: Boolean);
begin
	if FReadOnly <> Value then begin
		FReadOnly := Value;
		Selection.ShowCaret;
	end;
end;

procedure TMemoComponent.SetRemoveTrailingSpaces(const Value: Boolean);
begin
	if FRemoveTrailingSpaces <> Value then begin
		FRemoveTrailingSpaces := Value;
		if Value then
			RemoveTrSp;
	end;
end;

procedure TMemoComponent.SetScrollBars(const Value: TScrollStyle);
begin
	if FScrollBars <> Value then begin
		FScrollBars := Value;
		RecreateWnd;
	end;
end;

procedure TMemoComponent.SetSelLength(const Value: Integer);
begin
	Selection.RLength := Value;
end;

procedure TMemoComponent.SetSelStart(const Value: Integer);
begin
	Selection.NoSelAtPos (Value + 1);
end;

procedure TMemoComponent.SetTabSize(const Value: Integer);
var
	I: Integer;
begin
	if FTabSize <> Value then begin
		FTabSize := Value;
		if FTabSize < 1 then
			FTabSize := 1;
		Selection.DoChanging;
		FLongestLineLength := 0;
		for I := 0 to LineCount do
			if FLongestLineLength < VisualLineLength [I] then
				FLongestLineLength := VisualLineLength [I];
		UpdatePageSize;
		VisibleRange.Update;
		VisibleRange.DrawRange;
		Selection.UpdateCaretPos;
		Selection.DoChange;
	end;
end;

procedure TMemoComponent.SetText(const Value: TCaption);
begin
	WholeText.Text := Value;
end;

procedure TMemoComponent.SetTopMargin(const Value: Integer);
begin
	if FTopMargin <> Value then begin
		FTopMargin := Value;
		UpdatePageSize;
		VisibleRange.Update;
		VisibleRange.DrawRange;
		Selection.UpdateCaretPos;
	end;
end;

function TMemoComponent.TabSpacesAtPos(P: Integer): Integer;
var
	I: Integer;
	RS: TTextCell;
	Ps: Integer;
begin
	if TabSize <= 1 then
		Result := TabSize
	else begin
		RS := CharIdxToCell (P);
		RS.Col := 1;
		Ps := 0;
		for I := CellToCharIdx (RS) to P - 1 do begin
			if Text [I] = #9 then
				Ps := (Ps div TabSize + 1) * TabSize
			else
				Inc (Ps);
		end;
		Result := TabSize - Ps mod TabSize;
	end;
end;

procedure TMemoComponent.TextChangeNotification(StartPos, OldLength,
  NewLength: Integer);
begin
end;

procedure TMemoComponent.TextChangeNotificationAfter;
begin
end;

procedure TMemoComponent.Undo;
begin
	Perform (em_Undo, 0, 0);