memocomponentunit.pas

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

end;

procedure TMemoComponent.UpdateDrawBmp;
begin
	if Bitmapped then begin
		if not Assigned (DrawBmp) then
			DrawBmp := TBitmap.Create;
		if (DrawBmp.Width <> ClientWidth) or (DrawBmp.Height <> ClientHeight) then begin
			DrawBmp.Width := ClientWidth;
			DrawBmp.Height := ClientHeight;
			DrawBorder (Rect (0, 0, LeftMargin, ClientHeight), Rect (0, 0, ClientWidth, TopMargin), DrawBmp.Canvas);
		end;
	end else
		if Assigned (DrawBmp) then begin
			DrawBmp.Free;
			DrawBmp := nil;
		end;
end;

procedure TMemoComponent.UpdateFontSize;
const
	WidthMeasureChar = 'M';
	HeightMeasureChar = 'Q';
procedure TryStyle(Style: TFontStyle);
begin
	Canvas.Font.Style := Canvas.Font.Style + [Style];
	if FontWidth <> Canvas.TextWidth (WidthMeasureChar) then
		Include (FForbiddenFontStyles, Style);
	Canvas.Font.Assign (Font);
end;
begin
	FForbiddenFontStyles := [];
	if HandleAllocated and Assigned (Parent) then begin
		Canvas.Font.Assign (Font);
		FontWidth := Canvas.TextWidth (WidthMeasureChar);
		FontHeight := Canvas.TextHeight (HeightMeasureChar);
		TryStyle (fsBold);
		TryStyle (fsItalic);
		ReCreateCaret;
		UpdatePageSize;
	end;
end;

procedure TMemoComponent.UpdatePageSize;
var
	ScrollInfo: TScrollInfo;
begin
	if HandleAllocated and Assigned (Parent) then begin
		VisibleRange.DoChanging;
		UpdateDrawBmp;
		if FontHeight <= 0 then
			FontHeight := 13;
		if FontWidth <= 0 then
			FontWidth := 8;
		if HandleAllocated and Assigned (Parent) then begin
			PageHeight := (ClientHeight - TopMargin) div FontHeight;
			PageWidth := (ClientWidth - LeftMargin) div FontWidth;
		end else begin
			PageHeight := 1;
			PageWidth := 1;
		end;
		if PageHeight < 1 then
			PageHeight := 1;
		if PageWidth < 1 then
			PageWidth := 1;
		VisibleRange.Update;
		if HandleAllocated then begin
			with ScrollInfo do begin
				cbSize := SizeOf (ScrollInfo);
				fMask := sif_All or sif_DisableNoScroll;
				nMin := 1;
				nMax := LineCount;
				nPos := VisibleRange.TopRow;
				nPage := PageHeight;
			end;
			SetScrollInfo (Handle, sb_Vert, ScrollInfo, True);
			with ScrollInfo do begin
				nMin := 1;
				nMax := LongestLineLength;
				nPos := VisibleRange.LeftCol;
				nPage := PageWidth;
			end;
			SetScrollInfo (Handle, sb_Horz, ScrollInfo, True);
		end;
		VisibleRange.DoChange;
	end;
end;

procedure TMemoComponent.WMClear(var Message: TWMClear);
begin
	inherited;
	Selection.Clear;
end;

procedure TMemoComponent.WMCopy(var Message: TWMCopy);
begin
	inherited;
	if Selection.RLength > 0 then
		Clipboard.AsText := Selection.Text;
end;

procedure TMemoComponent.WMCut(var Message: TWMCut);
begin
	inherited;
	if Selection.RLength > 0 then begin
		Clipboard.AsText := Selection.Text;
		Selection.Clear;
	end;
end;

procedure TMemoComponent.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
	Message.Result := 1;
end;

procedure TMemoComponent.WMGetText(var Message: TWMGetText);
begin
	StrPLCopy (Message.Text, Text, Message.TextMax);
	Message.Result := StrLen (Message.Text);
end;

procedure TMemoComponent.WMGetTextLength(var Message: TWMGetTextLength);
begin
	Message.Result := TextLength;
end;

procedure TMemoComponent.WMHScroll(var Message: TWMHScroll);
var
	ScrollPos: Integer;
	OldPos: Integer;
begin
	VisibleRange.DoChanging;
	inherited;
	OldPos := VisibleRange.LeftCol;
	ScrollPos := OldPos;
	with Message do begin
		if ScrollCode in [sb_ThumbTrack, sb_ThumbPosition] then
			ScrollPos := Pos
		else begin
			case ScrollCode of
				sb_Top: ScrollPos := 1;
				sb_Bottom: ScrollPos := LongestLineLength - PageWidth + 1;
				sb_LineLeft: ScrollPos := OldPos - 1;
				sb_LineRight: ScrollPos := OldPos + 1;
				sb_PageLeft: ScrollPos := OldPos - PageWidth;
				sb_PageRight: ScrollPos := OldPos + PageWidth;
			end;
		end;
		Result := 0;
	end;
	if ScrollPos > LongestLineLength - PageWidth + 1 then
		ScrollPos := LongestLineLength - PageWidth + 1;
	if ScrollPos < 1 then
		ScrollPos := 1;
	if ScrollPos <> OldPos then begin
		SetScrollPos (Handle, sb_Horz, ScrollPos, True);
		VisibleRange.FLeftCol := ScrollPos;
		VisibleRange.DoChange;
		Update;
	end else
		VisibleRange.DoDiscardChanges;
end;

procedure TMemoComponent.WMKeyDown(var Message: TWMKeyDown);
var
	NewPos: Integer;
	Cell: TTextCell;
	SavScrCol: Integer;
	InWord: Boolean;
	Shift: TShiftState;
	P: TPoint;
begin
	inherited;
	Shift := KeyDataToShiftState (Message.KeyData);
	SavScrCol := -1;
	NewPos := Low (Integer);
	if ReadOnly then begin
		case Message.CharCode of
			vk_Left: Perform (wm_HScroll, sb_LineLeft, 0);
			vk_Right: Perform (wm_HScroll, sb_LineRight, 0);
			vk_Up: Perform (wm_VScroll, sb_LineUp, 0);
			vk_Down: Perform (wm_VScroll, sb_LineDown, 0);
			vk_Prior: Perform (wm_VScroll, sb_PageUp, 0);
			vk_Next: Perform (wm_VScroll, sb_PageDown, 0);
			vk_Home: begin
				if ssCtrl in Shift then
					Perform (wm_VScroll, sb_Top, 0);
				Perform (wm_HScroll, sb_Top, 0);
			end;
			vk_End: begin
				if ssCtrl in Shift then
					Perform (wm_VScroll, sb_Bottom, 0)
				else
					Perform (wm_HScroll, sb_Bottom, 0);
			end;
			vk_Insert:
				if Shift = [ssCtrl] then
					CopyToClipboard;
		end;
	end else begin
		with Selection do begin
			case Message.CharCode of
				vk_Clear: begin
					Clear;
					ScrollInView (4);
				end;
				vk_Delete: begin
					if Shift = [] then begin
						if RLength = 0 then begin
							DoChanging;
							RLength := 1;
							if (RLength = 1) and (Text [1] in [#10, #13]) then
								RLength := 2;
							DoDiscardChanges;
						end;
						Clear;
						ScrollInView (4);
					end else if Shift = [ssShift] then
						CutToClipboard;
				end;
				vk_Insert: begin
					if Shift = [ssShift] then
						PasteFromClipboard
					else if Shift = [ssCtrl] then
						CopyToClipboard;
				end;
				vk_Back:
					if (Shift = []) or (Shift = [ssShift]) then begin
						if RLength = 0 then begin
							DoChanging;
							RStart := RStart - 1;
							if (RLength = 1) and (Text [1] in [#10, #13]) then
								RStart := RStart - 1;
							DoDiscardChanges;
						end;
						Clear;
						ScrollInView (4);
					end else if Shift = [ssAlt] then
						Undo
					else if Shift = [ssAlt, ssShift] then
						Redo;
				vk_Tab:
					if Shift = [] then begin
						Text := #9;
						ScrollInView (4);
					end;
				vk_Left: begin
					if (not (ssShift in Shift)) and (RLength > 0) and (not AlwaysShowCaret) then
						REnd := RStart - 1
					else
						if (ssCtrl in Shift) then begin
							NewPos := CursorPos;
							InWord := (NewPos > 1) and (NewPos <= TextLength + 1) and (Self.Text [NewPos - 1] in ['A'..'Z', 'a'..'z', '0'..'9', '_']);
							while (NewPos > 1) and ((Self.Text [NewPos - 1] in ['A'..'Z', 'a'..'z', '0'..'9', '_']) = InWord) do begin
								if Self.Text [NewPos - 1] in [#10, #13] then
									Dec (NewPos, 2)
								else
									Dec (NewPos);
							end;
						end else begin
							if (CursorPos > 1) and (Self.Text [CursorPos - 1] in [#10, #13]) then
								NewPos := CursorPos - 2
							else
								NewPos := CursorPos - 1;
						end;
				end;
				vk_Right: begin
					if (not (ssShift in Shift)) and (RLength > 0) and (not AlwaysShowCaret) then
						RStart := REnd + 1
					else
						if (ssCtrl in Shift) then begin
							NewPos := CursorPos;
							InWord := (NewPos >= 1) and (NewPos <= TextLength) and (Self.Text [NewPos] in ['A'..'Z', 'a'..'z', '0'..'9', '_']);
							while (NewPos <= TextLength) and ((Self.Text [NewPos] in ['A'..'Z', 'a'..'z', '0'..'9', '_']) = InWord) do begin
								if Self.Text [NewPos] in [#10, #13] then
									Inc (NewPos, 2)
								else
									Inc (NewPos);
							end;
						end else begin
							if (CursorPos <= TextLength) and (Self.Text [CursorPos] in [#10, #13]) then
								NewPos := CursorPos + 2
							else
								NewPos := CursorPos + 1;
						end;
				end;
				vk_Up: begin
					if (not (ssShift in Shift)) and (RLength > 0) and (not AlwaysShowCaret) then
						REnd := RStart - 1
					else begin
						SavScrCol := ScrCol;
						Cell := CharIdxToCell (CursorPos);
						Dec (Cell.Row);
						Cell.Col := ScrColToCol (Cell.Row);
						NewPos := CellToCharIdx (Cell);
					end;
				end;
				vk_Down: begin
					if (not (ssShift in Shift)) and (RLength > 0) and (not AlwaysShowCaret) then
						RStart := REnd + 1
					else begin
						SavScrCol := ScrCol;
						Cell := CharIdxToCell (CursorPos);
						Inc (Cell.Row);
						Cell.Col := ScrColToCol (Cell.Row);
						NewPos := CellToCharIdx (Cell);
					end;
				end;
				vk_Prior: begin
					SavScrCol := ScrCol;
					Cell := CharIdxToCell (CursorPos);
					Dec (Cell.Row, PageHeight - 1);
					Cell.Col := ScrColToCol (Cell.Row);
					NewPos := CellToCharIdx (Cell);
				end;
				vk_Next: begin
					SavScrCol := ScrCol;
					Cell := CharIdxToCell (CursorPos);
					Inc (Cell.Row, PageHeight - 1);
					Cell.Col := ScrColToCol (Cell.Row);
					NewPos := CellToCharIdx (Cell);
				end;
				vk_Home: begin
					Cell := CharIdxToCell (CursorPos);
					if ssCtrl in Shift then
						Cell.Row := 1;
					Cell.Col := 1;
					NewPos := CellToCharIdx (Cell);
				end;
				vk_End: begin
					Cell := CharIdxToCell (CursorPos);
					if ssCtrl in Shift then
						Cell.Row := LineCount;
					Cell.Col := LineLength [Cell.Row] + 1;
					NewPos := CellToCharIdx (Cell);
				end;
				vk_Escape:
					if FDragging and Assigned (DragOrigRange) then begin
						DragOrigRange.Text := Selection.Text;
						Selection.Text := '';
						Selection.Assign (DragOrigRange);
						CancelDragging;
						DontNotify := False;
					end;
			end;
			if NewPos <> Low (Integer) then begin
				if ssShift in Shift then
					CursorPos := NewPos
				else
					NoSelAtPos (NewPos);
				ScrCol := SavScrCol;
				ScrollInView (0);
			end;
		end;
		if (UpCase (Char (Message.CharCode)) = 'Z') and (ssCtrl in Shift) then begin
			if ssShift in Shift then
				Redo
			else
				Undo;
		end;
		if FDragging and (Message.CharCode = vk_Control) then begin
			P := ScreenToClient (Mouse.CursorPos);
			MouseMove (Shift, P.X, P.Y);
		end;
	end;
	if Shift = [ssCtrl] then
		case UpCase (Char (Message.CharCode)) of
			'X': if not ReadOnly then CutToClipboard;
			'C': CopyToClipboard;
			'V': if not ReadOnly then PasteFromClipboard;
		end;
end;

procedure TMemoComponent.WMKeyUp(var Message: TWMKeyUp);
var
	Shift: TShiftState;
	P: TPoint;
begin
	if (not ReadOnly) and FDragging and (Message.CharCode = vk_Control) then begin
		Shift := KeyDataToShiftState (Message.KeyData);
		P := ScreenToClient (Mouse.CursorPos);
		MouseMove (Shift, P.X, P.Y);
	end;
end;

procedure TMemoComponent.WMKillFocus(var Message: TWMKillFocus);
begin
	inherited;
	FHasFocus := False;
	FreeCaret;
end;

procedure TMemoComponent.WMPaste(var Message: TWMPaste);
begin
	inherited;
	Selection.Text := Clipboard.AsText;
	Selection.ScrollInView (1);
end;

procedure TMemoComponent.WMSetFocus(var Message: TWMSetFocus);
begin
	inherited;
	FHasFocus := True;
	ReCreateCaret;
end;

procedure TMemoComponent.WMSetText(var Message: TWMSetText);
begin
	Text := StrPas (Message.Text);
	Message.Result := 1;
end;

procedure TMemoComponent.WMSize(var Message: TWMSize);
begin
	inherited;
	UpdatePageSize;
end;

procedure TMemoComponent.WMTimer(var Message: TWMTimer);
var
	P: TPoint;
	DLeft,
	DTop: Integer;
begin
	inherited;
	if (Message.TimerID = 1) and (FSelecting or FDragging) then begin
		P := ScreenToClient (Mouse.CursorPos);
		DLeft := 0;
		DTop := 0;
		if P.X < 0 then
			DLeft := -((-1 - P.X) div ScrollOffset + 1)
		else if P.X >= ClientWidth then
			DLeft := ((P.X - ClientWidth) div ScrollOffset + 1);
		if P.Y < 0 then
			DTop := -((-1 - P.Y) div ScrollOffset + 1)
		else if P.Y >= ClientHeight then
			DTop := ((P.Y - ClientHeight) div ScrollOffset + 1);
		if (DLeft <> 0) or (DTop <> 0) then begin
			with VisibleRange do begin
				if DLeft <> 0 then
					LeftCol := LeftCol + DLeft;
				if DTop <> 0 then
					TopRow := TopRow + DTop;
			end;
			MouseMoveInternal (P.X, P.Y);
		end;
	end;
end;

procedure TMemoComponent.WMVScroll(var Message: TWMVScroll);
var
	ScrollPos: Integer;
	OldPos: Integer;
begin
	VisibleRange.DoChanging;
	inherited;
	OldPos := GetScrollPos (Handle, sb_Vert);
	ScrollPos := OldPos;
	with Message do begin
		if ScrollCode in [sb_ThumbTrack, sb_ThumbPosition] then
			ScrollPos := Pos
		else begin
			case ScrollCode of
				sb_Top: ScrollPos := 1;
				sb_Bottom: ScrollPos := LineCount - PageHeight + 1;
				sb_LineUp: ScrollPos := OldPos - 1;
				sb_LineDown: ScrollPos