memocomponentunit.pas

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

destructor TMemoComponent.Destroy;
begin
	DontNotify := True;
	ClearUndo;
	FSelection.Free;
	FVisibleRange.Free;
	FLines.Free;
	FTrackedRanges.Free;
	FWholeText.Free;
	FLineStarts.Free;
	if Assigned (DrawBmp) then begin
		DrawBmp.Free;
		DrawBmp := nil;
	end;
	inherited;
end;

procedure TMemoComponent.DrawBorder(LeftRect, TopRect: TRect;
  Canvas: TCanvas);
begin
	Canvas.Brush.Color := Color;
	Canvas.FillRect (LeftRect);
	Canvas.FillRect (TopRect);
end;

procedure TMemoComponent.DrawTextLine(Range: TCustomRange; Left, Top: Integer; NextTabStop: Integer);
var
	I,
	SP,
	X,
	Y,
	TextFlags: Integer;
	R: TRect;
	Ranges: TFormattedRangeArray;
	S: string;
	Cnv: TCanvas;
begin
	if HandleAllocated and ((Range.RLength > 0) or (Range.REnd >= TextLength)) then begin
		if Bitmapped then begin
			Cnv := DrawBmp.Canvas;
			TextFlags := eto_Opaque or eto_Clipped;
		end else begin
			Cnv := Canvas;
			TextFlags := eto_Opaque or eto_Clipped;
		end;
		SetLength (Ranges, 0);
		Ranges := CreateSplitRanges (Range);
		R := Rect (Left, Top, Left, Top + FontHeight);
		for I := Low (Ranges) to High (Ranges) do
			with Ranges [I] do begin
				CleanUpFont;
				if RLength > 0 then begin
					Cnv.Brush.Color := Color;
					Cnv.Font.Assign (Font);
					if Self.Text [REnd] = #10 then
						S := Copy (Self.Text, RStart, RLength - 2)
					else if Self.Text [REnd] = #13 then
						S := Copy (Self.Text, RStart, RLength - 1)
					else
						S := Copy (Self.Text, RStart, RLength);
					SP := 1;
					while SP <= Length (S) do begin
						if S [SP] = #9 then begin
							System.Delete (S, SP, 1);
							System.Insert (StringOfChar (' ', NextTabStop), S, SP);
							Inc (SP, NextTabStop);
							NextTabStop := TabSize;
						end else begin
							Inc (SP);
							Dec (NextTabStop);
							if NextTabStop <= 0 then
								Inc (NextTabStop, TabSize);
						end;
					end;
					if (REnd <= TextLength) and (Self.Text [REnd] in [#10, #13]) then begin
						R.Right := ClientWidth;
					end else
						R.Right := R.Left + FontWidth * Length (S);
					X := R.Left;
					Y := R.Top;
					if (fsItalic in Font.Style) and (Pos ('Courier', Font.Name) > 0) then
						Dec (Y);
					if R.Left < LeftMargin then
						R.Left := LeftMargin;
					if R.Right > R.Left then begin
						{$IFDEF DRAWDEBUG}
							Cnv.FillRect (R);
							Sleep (100);
						{$ENDIF}
						ExtTextOut (Cnv.Handle, X, Y, TextFlags, @R, PChar (S), Length (S), nil);
					end;
					R.Left := R.Right;
				end;
				if FreeWhenDone then
					Free;
			end;
		if Range.REnd >= TextLength then begin
			if R.Left < LeftMargin then
				R.Left := LeftMargin;
			R.Right := ClientWidth;
			Cnv.Brush.Color := Color;
			Cnv.FillRect (R);
		end;
	end;
end;

procedure TMemoComponent.EMCanUndo(var Message: TMessage);
begin
	if Message.WParam = 1 then
		Message.Result := Integer (Assigned (FRedoStack))
	else
		Message.Result := Integer (Assigned (FUndoStack));
end;

procedure TMemoComponent.EMUndo(var Message: TMessage);
var
	Op: TUndoOperation;
	NewOp: PUndoOperation;
	Repeating: Boolean;
	CurSel: TMCRange;
begin
	if Perform (em_CanUndo, Message.WParam, 0) <> 0 then
		with Message do begin
			FInUndo := True;
			Repeating := False;
			CurSel := nil;
			repeat
				if WParam = 1 then
					Op := GetLastRedo
				else
					Op := GetLastUndo;
				if IsUndoBeginEndBlock (@Op) then begin
					Repeating := not Repeating;
					if Repeating then begin
						DontNotify := True;
						VisibleRange.DoChanging;
					end else begin
						VisibleRange.DoDiscardChanges;
						Selection.HideCaret;
						VisibleRange.DrawRange;
						if Assigned (CurSel) then
							Selection.Assign (CurSel);
						Selection.UpdateCaretPos;
						Selection.ShowCaret;
						DontNotify := False;
						Self.Change;
						SelectionChange;
						Selection.ScrollInView (4);
					end;
					if WParam = 1 then
						MakeUndoOperation (CreateUndoBeginEndBlock)
					else
						MakeRedoOperation (CreateUndoBeginEndBlock);
				end else begin
					with TMCRange.Create (nil) do begin
						Editor := Self;
						New (NewOp);
						RStart := Op.RStart;
						REnd := Op.REnd;
						NewOp.NewText := Text;
						Text := Op.NewText;
						NewOp.RStart := RStart;
						NewOp.REnd := REnd;
						if WParam = 1 then
							MakeUndoOperation (NewOp)
						else
							MakeRedoOperation (NewOp);
						if Repeating then begin
							if Assigned (CurSel) then begin
								if REnd + 1 > CurSel.RStart then
									CurSel.RStart := REnd + 1;
							end else begin
								CurSel := TMCRange.Create (TrackedRanges);
								CurSel.RStart := REnd + 1;
							end;
						end else begin
							AssignTo (Selection);
							Selection.ScrollInView (4);
						end;
						Free;
					end;
				end;
			until not Repeating;
			if Assigned (CurSel) then
				CurSel.Free;
			FInUndo := False;
			Change;
		end;
end;

procedure TMemoComponent.FreeCaret;
begin
	if FCaretCreated then begin
		Selection.HideCaret;
		DestroyCaret;
		FCaretCreated := False;
	end;
end;

function TMemoComponent.GetCanRedo: Boolean;
begin
	Result := Perform (em_CanUndo, 1, 0) <> 0;
end;

function TMemoComponent.GetCanUndo: Boolean;
begin
	Result := Perform (em_CanUndo, 0, 0) <> 0;
end;

function TMemoComponent.GetLastRedo: TUndoOperation;
begin
	if Assigned (FRedoStack) then begin
		Result := FRedoStack^;
		Dispose (FRedoStack);
		FRedoStack := Result.NextItem;
	end;
end;

function TMemoComponent.GetLastUndo: TUndoOperation;
begin
	if Assigned (FUndoStack) then begin
		Result := FUndoStack^;
		Dispose (FUndoStack);
		FUndoStack := Result.NextItem;
	end;
end;

function TMemoComponent.GetLineCount: Integer;
begin
	Result := FLineStarts.Count;
end;

function TMemoComponent.GetLineLength(LineIndex: Integer): Integer;
begin
	Result := CellToCharIdx (TextCell (LineIndex + 1, 0)) - CellToCharIdx (TextCell (LineIndex, 0)) - 2;
end;

function TMemoComponent.GetSelLength: Integer;
begin
	Result := Selection.RLength;
end;

function TMemoComponent.GetSelStart: Integer;
begin
	Result := Selection.RStart - 1;
end;

function TMemoComponent.GetVisualLineLength(LineIndex: Integer): Integer;
begin
	Result := CellToScrCol (TextCell (LineIndex, GetLineLength (LineIndex) + 1)) - 1;
end;

function TMemoComponent.IsUndoBeginEndBlock(Op: PUndoOperation): Boolean;
begin
	Result := Op.RStart = -1;
end;

procedure TMemoComponent.KeyPress(var Key: Char);
begin
	inherited;
	if (Key >= #32) or (Key = #13) then
		if not ReadOnly then
			with Selection do begin
				if Key = #13 then
					Text := #13#10
				else
					Text := Key;
				ScrollInView (4);
			end;
end;

procedure TMemoComponent.MakeRedoOperation(Op: PUndoOperation);
begin
	if Assigned (Op) then begin
		Op.NextItem := FRedoStack;
		FRedoStack := Op;
	end;
end;

procedure TMemoComponent.MakeUndoOperation(Op: PUndoOperation);
begin
	if Assigned (Op) then begin
		Op.NextItem := FUndoStack;
		FUndoStack := Op;
	end;
end;

procedure TMemoComponent.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
	Cell: TTextCell;
	NewPos: Integer;
begin
	inherited;
	if not FDblClicked then begin
		try
			SetFocus;
		except end;
		if (Button = mbLeft) or ((Button = mbRight) and (Selection.RLength <= 0)) then begin
			Cell := ScrPointToScrCell (Point (X, Y));
			Inc (Cell.Row, VisibleRange.TopRow - 1);
			Inc (Cell.Col, VisibleRange.LeftCol - 1);
			CellFromScrCol (Cell);
			NewPos := CellToCharIdx (Cell);
			with Selection do
				if ssShift in Shift then
					CursorPos := NewPos
				else begin
					if DragDropEditing and (RLength > 0) and (RStart <= NewPos) and (REnd >= NewPos - 1) and (not ReadOnly) then
						FStartDrag := True
					else
						NoSelAtPos (NewPos)
				end;
			if not (FSelecting or FStartDrag) then begin
				FSelecting := True;
				if HandleAllocated then
					SetTimer (Handle, 1, 50, nil);
			end;
		end;
	end;
end;

procedure TMemoComponent.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
	inherited;
	if FStartDrag and (not FDragging) then begin
		if not Assigned (DragOrigRange) then
			DragOrigRange := TMCRange.Create (TrackedRanges);
		with DragOrigRange do begin
			RStart := Selection.RStart;
			RLength := 0;
		end;
		FDragging := True;
		Screen.Cursor := crDrag;
		if HandleAllocated and (not FSelecting) then
			SetTimer (Handle, 1, 50, nil);
		FSelecting := False;
		DontNotify := True;
	end;
	FStartDrag := False;
	if FDragging and Assigned (DragOrigRange) then begin
		if ssCtrl in Shift then
			DragOrigRange.Text := Selection.Text
		else
			DragOrigRange.Text := '';
	end;
	MouseMoveInternal (X, Y);
end;

procedure TMemoComponent.MouseMoveInternal(X, Y: Integer);
var
	Cell: TTextCell;
	NewPos: Integer;
	SelText,
	MoveText: string;
	DRStart,
	DREnd: Integer;
begin
	if (FSelecting or FDragging) and (not FDblClicked) then begin
		Cell := ScrPointToScrCell (Point (X, Y));
		Inc (Cell.Row, VisibleRange.TopRow - 1);
		Inc (Cell.Col, VisibleRange.LeftCol - 1);
		CellFromScrCol (Cell);
		NewPos := CellToCharIdx (Cell);
		if FSelecting then
			Selection.CursorPos := NewPos
		else if FDragging then begin
			if Assigned (DragOrigRange) then begin
				DRStart := DragOrigRange.RStart;
				DREnd := DragOrigRange.REnd;
			end else begin
				DRStart := 0;
				DREnd := 0;
			end;
			if (NewPos <= DRStart) or (NewPos > DREnd) then begin
				with Selection do begin
					SelText := Text;
					if NewPos < RStart then begin
						if (RStart - NewPos >= Length (SelText)) or ((DRStart >= NewPos) and (DRStart <= RStart)) then begin
							Text := '';
							NoSelAtPos (NewPos);
							Text := SelText;
							RStart := NewPos;
							RLength := Length (SelText);
						end else
							with TMCRange.Create (nil) do try
								Editor := Self;
								RStart := NewPos;
								RLength := Selection.RStart - NewPos;
								MoveText := Text;
								Text := '';
								RStart := Selection.REnd + 1;
								RLength := 0;
								Text := MoveText;
								if Assigned (DragOrigRange) then
									with DragOrigRange do
										if (REnd < RStart) and (RStart = Selection.REnd + 1) then
											RStart := RStart + Length (MoveText);
							finally
								Free;
							end;
					end else if NewPos > REnd + 1 then begin
						if (NewPos - (REnd + 1) >= Length (SelText)) or ((DRStart >= REnd + 1) and (DRStart <= NewPos)) then begin
							Text := '';
							NoSelAtPos (NewPos - Length (SelText));
							Text := SelText;
							RStart := NewPos - Length (SelText);
							RLength := Length (SelText);
						end else
							with TMCRange.Create (nil) do try
								Editor := Self;
								RStart := Selection.REnd + 1;
								RLength := NewPos - (Selection.REnd + 1);
								MoveText := Text;
								Text := '';
								RStart := Selection.RStart;
								RLength := 0;
								Text := MoveText;
							finally
								Free;
							end;
					end;
				end;
			end;
		end;
	end;
end;

procedure TMemoComponent.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
	Cell: TTextCell;
	NewPos: Integer;
	Op: PUndoOperation;
begin
	inherited;
	if FStartDrag then begin
		FStartDrag := False;
		Cell := ScrPointToScrCell (Point (X, Y));
		Inc (Cell.Row, VisibleRange.TopRow - 1);
		Inc (Cell.Col, VisibleRange.LeftCol - 1);
		CellFromScrCol (Cell);
		NewPos := CellToCharIdx (Cell);
		Selection.NoSelAtPos (NewPos);
	end;
	if (Button in [mbLeft, mbRight]) and (FSelecting or FDragging) and (not FDblClicked) then begin
		if FDragging then begin
			if Assigned (DragOrigRange) then begin
				if ssCtrl in Shift then
					DragOrigRange.Text := Selection.Text
				else
					DragOrigRange.Text := '';
			end;
			if AllowUndo and ((Selection.RStart <> DragOrigRange.RStart) or (DragOrigRange.RLength > 0)) then begin
				ClearRedo;
				MakeUndoOperation (CreateUndoBeginEndBlock);
				if Assigned (DragOrigRange) and (DragOrigRange.RLength <= 0) then begin
					New (Op);
					Op.RStart := DragOrigRange.RStart;
					if Op.RStart > Selection.RStart then
						Dec (Op.RStart, Selection.RLength);
					Op.REnd := Op.RStart - 1;
					Op.NewText := Selection.Text;
					MakeUndoOperation (Op);
				end;
				New (Op);
				Op.RStart := Selection.RStart;
				Op.REnd := Selection.REnd;
				Op.NewText := '';
				MakeUndoOperation (Op);
				MakeUndoOperation (CreateUndoBeginEndBlock);