更改包含已写入文本的区域的背景
Change the background of an area containing already written text
(Delphi DX 10.3)
我有一个很大的空白（白色）canvas（在 Tpanel 的后代上），我在其中绘制了一些文本（使用 Textout()，假设文本始终为黑色）和图形（线条、矩形，没有那么复杂的东西）。
画完后，我需要改变一些特定区域的白色背景的颜色，从白色变成另一种颜色。
我想要达到的效果 很像带有彩色单元格的 excel sheet。在附加示例中，所有列都创建为空白（白色），如“value”和“difference”，然后是黄色（price) 和红色 (result) 列已被着色。
如果我可以在 写入文本之前 填写区域，我会使用 SetBkMode(TRANSPARENT) 并获得最佳结果。不幸的是，我需要在 之后 填写文本和图形。
我想到的第一个解决方案是逐像素替换（使用 Pixels[] 函数），但速度非常慢且图形效果不尽如人意。
所以我的问题是：如何为包含已写入文本的区域的背景着色？
这里是一个最小可重现示例。
按钮 1 执行像素替换，非常慢并且图形结果不令人满意。
按钮 2 在写入文本后使用 SetBkMode(TRANSPARENT) 填充区域。完美的结果，但我做不到
program BK_mode;
uses
Vcl.Forms,
main in 'main.pas' {Form1};
{$R *.res}
begin
Application.Initialize;
Application.MainFormOnTaskbar := True;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
////////////////////////////////////
unit main;
interface
uses Windows, Forms, SysUtils, Vcl.StdCtrls, UiTypes, System.Classes, Vcl.Controls, Vcl.ExtCtrls, Graphics, Dialogs;
type
TForm1 = class(TForm)
btn_01: TButton;
btn_02: TButton;
procedure btn_02Click(Sender: TObject);
procedure btn_01Click(Sender: TObject);
private
procedure write_text(canvas: TCanvas;x, y : integer;i_fontsize : smallint;const str_text: String;style : TFontStyles;bo_transparent : boolean);
procedure switch_color(canvas : TCanvas;color_source, color_target : TColor);
procedure prepare_example(bo_transparent : boolean);
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
const
BASE_COLOR = clWhite;
ALTERNATIVE_COLOR = clRed;
procedure TForm1.write_text(canvas: TCanvas;x, y : integer;i_fontsize : smallint;const str_text: String;style : TFontStyles;bo_transparent : boolean);
begin
var lo_old_BK_color : TColor := canvas.Brush.Color;
var lo_old_BK_mode := GetBKMode(canvas.Handle);
if bo_transparent then SetBKMode(canvas.Handle, TRANSPARENT)
else begin
SetBKMode(canvas.Handle, OPAQUE);
canvas.Brush.Color := BASE_COLOR
end;
canvas.Font.Color := clBlack;canvas.Font.Size := i_fontsize;canvas.Font.Style := style;
TextOut(canvas.Handle, x, y, PChar(str_text), Length(str_text));
if NOT bo_transparent then canvas.Brush.Color := lo_old_BK_color;
SetBKMode(canvas.Handle, lo_old_BK_mode)
end;
procedure TForm1.switch_color(canvas : TCanvas;color_source, color_target : TColor);
begin
for var x := 0 to clientWidth-1 do
for var y := 0 to clientHeight - 1 do
if (canvas.Pixels[x, y] = color_source) then canvas.Pixels[x, y] := color_target
end;
procedure TForm1.prepare_example(bo_transparent : boolean);
begin
if bo_transparent then Color := ALTERNATIVE_COLOR else Color := BASE_COLOR;
invalidate;
application.MessageBox('Click me', 'Test');
canvas.Rectangle(10, 10, 200, 100);
canvas.MoveTo(10, 110);canvas.LineTo(200, 140);
canvas.MoveTo(10, 140);canvas.LineTo(200, 110);
write_text(canvas, 30, 30, 14, 'This is a text!', [], bo_transparent);
write_text(canvas, 30, 60, 11, 'This is another text!', [fsBold, fsItalic], bo_transparent)
end;
procedure TForm1.btn_01Click(Sender: TObject);
begin
prepare_example(FALSE);
switch_color(canvas, BASE_COLOR, ALTERNATIVE_COLOR)
end;
procedure TForm1.btn_02Click(Sender: TObject);
begin
prepare_example(TRUE)
end;
end.
/////////////////////////////////////////// ////////////
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 283
ClientWidth = 208
Color = clWhite
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
DesignSize = (
208
283)
PixelsPerInch = 96
TextHeight = 13
object btn_01: TButton
Left = 17
Top = 161
Width = 178
Height = 51
Anchors = [akLeft, akRight, akBottom]
Caption = '1. write text and fill area'
Font.Charset = ANSI_CHARSET
Font.Color = clWindowText
Font.Height = -16
Font.Name = 'Arial'
Font.Style = [fsBold]
ParentFont = False
TabOrder = 0
WordWrap = True
OnClick = btn_01Click
end
object btn_02: TButton
Left = 17
Top = 220
Width = 178
Height = 51
Anchors = [akLeft, akRight, akBottom]
Caption = '2. fill area then write text'
Font.Charset = ANSI_CHARSET
Font.Color = clWindowText
Font.Height = -16
Font.Name = 'Arial'
Font.Style = [fsBold]
ParentFont = False
TabOrder = 1
WordWrap = True
OnClick = btn_02Click
end
end
你所要求的是这种方式根本无法实现。您需要重绘整个 Canvas，在绘制背景之前在顶部绘制线条+文本。绘制完成后，您需要重新绘制以重做所有内容。不要在 Paint 事件之外的 Canvas 上绘制。
您的示例借鉴了 TForm.Canvas，因此请使用 TForm.OnPaint 事件。对于 TPanel 后代，改写虚拟 Paint() 方法。无论哪种方式，保留一些具有所需设置的变量，在绘制时使用这些变量，并在更新变量后调用 Invalidate() 并触发重绘。
例如：
unit main;
interface
uses Windows, Forms, SysUtils, Vcl.StdCtrls, UiTypes, System.Classes, Vcl.Controls, Vcl.ExtCtrls, Graphics, Dialogs;
type
TForm1 = class(TForm)
btn_01: TButton;
btn_02: TButton;
procedure btn_02Click(Sender: TObject);
procedure btn_01Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
private
FDrawTransparent : Boolean;
FDrawColor : TColor;
procedure write_text(ACanvas: TCanvas; x, y : integer; i_fontsize : smallint; const str_text: String; style : TFontStyles; bo_transparent : boolean);
procedure prepare_example(bo_transparent : boolean; color_target : TColor);
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
const
BASE_COLOR = clWhite;
ALTERNATIVE_COLOR = clRed;
procedure TForm1.FormCreate(Sender: TObject);
begin
FDrawTransparent := False;
FDrawColor := BASE_COLOR;
end;
procedure TForm1.FormPaint(Sender: TObject);
begin
Canvas.Brush.Color := Self.Color;
Canvas.Rectangle(10, 10, 200, 100);
Canvas.MoveTo(10, 110);
Canvas.LineTo(200, 140);
Canvas.MoveTo(10, 140);
Canvas.LineTo(200, 110);
write_text(Canvas, 30, 30, 14, 'This is a text!', [], FDrawTransparent);
write_text(Canvas, 30, 60, 11, 'This is another text!', [fsBold, fsItalic], FDrawTransparent);
end;
procedure TForm1.write_text(ACanvas: TCanvas; x, y : integer; i_fontsize : smallint; const str_text: String;style : TFontStyles; bo_transparent : boolean);
begin
var lo_old_BK_color := ACanvas.Brush.Color;
var lo_old_BK_mode := GetBKMode(ACanvas.Handle);
if bo_transparent then
SetBKMode(ACanvas.Handle, TRANSPARENT)
else begin
SetBKMode(ACanvas.Handle, OPAQUE);
ACanvas.Brush.Color := FDrawColor;
end;
ACanvas.Font.Color := clBlack;
ACanvas.Font.Size := i_fontsize;
ACanvas.Font.Style := style;
TextOut(ACanvas.Handle, x, y, PChar(str_text), Length(str_text));
if NOT bo_transparent then ACanvas.Brush.Color := lo_old_BK_color;
SetBKMode(ACanvas.Handle, lo_old_BK_mode);
end;
procedure TForm1.prepare_example(bo_transparent : boolean; color_target: TColor);
begin
FDrawTransparent := bo_transparent;
FDrawColor := color_target;
if bo_transparent then Color := ALTERNATIVE_COLOR else Color := BASE_COLOR;
Invalidate;
Application.MessageBox('Click me', 'Test');
end;
procedure TForm1.btn_01Click(Sender: TObject);
begin
prepare_example(False, ALTERNATIVE_COLOR);
end;
procedure TForm1.btn_02Click(Sender: TObject);
begin
prepare_example(True, BASE_COLOR);
end;
end.
(Delphi DX 10.3)
我有一个很大的空白（白色）canvas（在 Tpanel 的后代上），我在其中绘制了一些文本（使用 Textout()，假设文本始终为黑色）和图形（线条、矩形，没有那么复杂的东西）。
画完后，我需要改变一些特定区域的白色背景的颜色，从白色变成另一种颜色。
我想要达到的效果 很像带有彩色单元格的 excel sheet。在附加示例中，所有列都创建为空白（白色），如“value”和“difference”，然后是黄色（price) 和红色 (result) 列已被着色。
如果我可以在 写入文本之前 填写区域，我会使用 SetBkMode(TRANSPARENT) 并获得最佳结果。不幸的是，我需要在 之后 填写文本和图形。 我想到的第一个解决方案是逐像素替换（使用 Pixels[] 函数），但速度非常慢且图形效果不尽如人意。
所以我的问题是：如何为包含已写入文本的区域的背景着色？
这里是一个最小可重现示例。
按钮 1 执行像素替换，非常慢并且图形结果不令人满意。
按钮 2 在写入文本后使用 SetBkMode(TRANSPARENT) 填充区域。完美的结果，但我做不到
program BK_mode;
uses
Vcl.Forms,
main in 'main.pas' {Form1};
{$R *.res}
begin
Application.Initialize;
Application.MainFormOnTaskbar := True;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
////////////////////////////////////
unit main;
interface
uses Windows, Forms, SysUtils, Vcl.StdCtrls, UiTypes, System.Classes, Vcl.Controls, Vcl.ExtCtrls, Graphics, Dialogs;
type
TForm1 = class(TForm)
btn_01: TButton;
btn_02: TButton;
procedure btn_02Click(Sender: TObject);
procedure btn_01Click(Sender: TObject);
private
procedure write_text(canvas: TCanvas;x, y : integer;i_fontsize : smallint;const str_text: String;style : TFontStyles;bo_transparent : boolean);
procedure switch_color(canvas : TCanvas;color_source, color_target : TColor);
procedure prepare_example(bo_transparent : boolean);
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
const
BASE_COLOR = clWhite;
ALTERNATIVE_COLOR = clRed;
procedure TForm1.write_text(canvas: TCanvas;x, y : integer;i_fontsize : smallint;const str_text: String;style : TFontStyles;bo_transparent : boolean);
begin
var lo_old_BK_color : TColor := canvas.Brush.Color;
var lo_old_BK_mode := GetBKMode(canvas.Handle);
if bo_transparent then SetBKMode(canvas.Handle, TRANSPARENT)
else begin
SetBKMode(canvas.Handle, OPAQUE);
canvas.Brush.Color := BASE_COLOR
end;
canvas.Font.Color := clBlack;canvas.Font.Size := i_fontsize;canvas.Font.Style := style;
TextOut(canvas.Handle, x, y, PChar(str_text), Length(str_text));
if NOT bo_transparent then canvas.Brush.Color := lo_old_BK_color;
SetBKMode(canvas.Handle, lo_old_BK_mode)
end;
procedure TForm1.switch_color(canvas : TCanvas;color_source, color_target : TColor);
begin
for var x := 0 to clientWidth-1 do
for var y := 0 to clientHeight - 1 do
if (canvas.Pixels[x, y] = color_source) then canvas.Pixels[x, y] := color_target
end;
procedure TForm1.prepare_example(bo_transparent : boolean);
begin
if bo_transparent then Color := ALTERNATIVE_COLOR else Color := BASE_COLOR;
invalidate;
application.MessageBox('Click me', 'Test');
canvas.Rectangle(10, 10, 200, 100);
canvas.MoveTo(10, 110);canvas.LineTo(200, 140);
canvas.MoveTo(10, 140);canvas.LineTo(200, 110);
write_text(canvas, 30, 30, 14, 'This is a text!', [], bo_transparent);
write_text(canvas, 30, 60, 11, 'This is another text!', [fsBold, fsItalic], bo_transparent)
end;
procedure TForm1.btn_01Click(Sender: TObject);
begin
prepare_example(FALSE);
switch_color(canvas, BASE_COLOR, ALTERNATIVE_COLOR)
end;
procedure TForm1.btn_02Click(Sender: TObject);
begin
prepare_example(TRUE)
end;
end.
/////////////////////////////////////////// ////////////
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 283
ClientWidth = 208
Color = clWhite
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
DesignSize = (
208
283)
PixelsPerInch = 96
TextHeight = 13
object btn_01: TButton
Left = 17
Top = 161
Width = 178
Height = 51
Anchors = [akLeft, akRight, akBottom]
Caption = '1. write text and fill area'
Font.Charset = ANSI_CHARSET
Font.Color = clWindowText
Font.Height = -16
Font.Name = 'Arial'
Font.Style = [fsBold]
ParentFont = False
TabOrder = 0
WordWrap = True
OnClick = btn_01Click
end
object btn_02: TButton
Left = 17
Top = 220
Width = 178
Height = 51
Anchors = [akLeft, akRight, akBottom]
Caption = '2. fill area then write text'
Font.Charset = ANSI_CHARSET
Font.Color = clWindowText
Font.Height = -16
Font.Name = 'Arial'
Font.Style = [fsBold]
ParentFont = False
TabOrder = 1
WordWrap = True
OnClick = btn_02Click
end
end
你所要求的是这种方式根本无法实现。您需要重绘整个 Canvas，在绘制背景之前在顶部绘制线条+文本。绘制完成后，您需要重新绘制以重做所有内容。不要在 Paint 事件之外的 Canvas 上绘制。
您的示例借鉴了 TForm.Canvas，因此请使用 TForm.OnPaint 事件。对于 TPanel 后代，改写虚拟 Paint() 方法。无论哪种方式，保留一些具有所需设置的变量，在绘制时使用这些变量，并在更新变量后调用 Invalidate() 并触发重绘。
例如：
unit main;
interface
uses Windows, Forms, SysUtils, Vcl.StdCtrls, UiTypes, System.Classes, Vcl.Controls, Vcl.ExtCtrls, Graphics, Dialogs;
type
TForm1 = class(TForm)
btn_01: TButton;
btn_02: TButton;
procedure btn_02Click(Sender: TObject);
procedure btn_01Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
private
FDrawTransparent : Boolean;
FDrawColor : TColor;
procedure write_text(ACanvas: TCanvas; x, y : integer; i_fontsize : smallint; const str_text: String; style : TFontStyles; bo_transparent : boolean);
procedure prepare_example(bo_transparent : boolean; color_target : TColor);
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
const
BASE_COLOR = clWhite;
ALTERNATIVE_COLOR = clRed;
procedure TForm1.FormCreate(Sender: TObject);
begin
FDrawTransparent := False;
FDrawColor := BASE_COLOR;
end;
procedure TForm1.FormPaint(Sender: TObject);
begin
Canvas.Brush.Color := Self.Color;
Canvas.Rectangle(10, 10, 200, 100);
Canvas.MoveTo(10, 110);
Canvas.LineTo(200, 140);
Canvas.MoveTo(10, 140);
Canvas.LineTo(200, 110);
write_text(Canvas, 30, 30, 14, 'This is a text!', [], FDrawTransparent);
write_text(Canvas, 30, 60, 11, 'This is another text!', [fsBold, fsItalic], FDrawTransparent);
end;
procedure TForm1.write_text(ACanvas: TCanvas; x, y : integer; i_fontsize : smallint; const str_text: String;style : TFontStyles; bo_transparent : boolean);
begin
var lo_old_BK_color := ACanvas.Brush.Color;
var lo_old_BK_mode := GetBKMode(ACanvas.Handle);
if bo_transparent then
SetBKMode(ACanvas.Handle, TRANSPARENT)
else begin
SetBKMode(ACanvas.Handle, OPAQUE);
ACanvas.Brush.Color := FDrawColor;
end;
ACanvas.Font.Color := clBlack;
ACanvas.Font.Size := i_fontsize;
ACanvas.Font.Style := style;
TextOut(ACanvas.Handle, x, y, PChar(str_text), Length(str_text));
if NOT bo_transparent then ACanvas.Brush.Color := lo_old_BK_color;
SetBKMode(ACanvas.Handle, lo_old_BK_mode);
end;
procedure TForm1.prepare_example(bo_transparent : boolean; color_target: TColor);
begin
FDrawTransparent := bo_transparent;
FDrawColor := color_target;
if bo_transparent then Color := ALTERNATIVE_COLOR else Color := BASE_COLOR;
Invalidate;
Application.MessageBox('Click me', 'Test');
end;
procedure TForm1.btn_01Click(Sender: TObject);
begin
prepare_example(False, ALTERNATIVE_COLOR);
end;
procedure TForm1.btn_02Click(Sender: TObject);
begin
prepare_example(True, BASE_COLOR);
end;
end.