盒子论坛 v2.1

How to do your HAND SIGNATURE using CANVAS controls as target?

------ VCL sample, but it's the same in FMX with some changes -------

unit uView.FormMain;

interface

uses
  Winapi.Windows,
  Winapi.Messages,
  System.SysUtils,
  System.Variants,
  System.Classes,
  Vcl.Graphics,
  Vcl.Controls,
  Vcl.Forms,
  Vcl.Dialogs,
  Vcl.ExtCtrls,
  Vcl.StdCtrls;

type
  TPanel = class(Vcl.ExtCtrls.TPanel) // It's necessary use "full-name-space"!!!
  private
    procedure Paint; override; // overriding the "Paint" methods default on TPanel
  end;

  TViewFormMain = class(TForm)
    Img_Resulted: TImage;
    Pnl_Signature: TPanel;
    Btn_Bitmap_iT: TButton;
    Btn_Clear_Signature: TButton;
    Pnl_MyIMG: TPanel;
    Pnl_MySignature: TPanel;
    Pnl_MyButtons: TPanel;
    ChkBxUsePaintEvent: TCheckBox;
    procedure FormCreate(Sender: TObject);
    procedure Pnl_SignatureMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure Pnl_SignatureMouseLeave(Sender: TObject);
    procedure Pnl_SignatureMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure Pnl_SignatureMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
    procedure FormDestroy(Sender: TObject);
    procedure Btn_Bitmap_iTClick(Sender: TObject);
    procedure Btn_Clear_SignatureClick(Sender: TObject);
  private
    procedure Init_Positions(X, Y: Integer);
    procedure DrawMyLinesPlease(X, Y: Integer);
  public
    { Public declarations }
  end;

var
  ViewFormMain: TViewFormMain;

implementation

{$R *.dfm}

uses
  System.Generics.Collections;

type
  TMyHackTCustomControl = class(TCustomControl);

var
  MyFS: TFormatSettings;
  MyAlphaColorCanvas: TColor;
  MyBeforePos: TPoint;
  MyCurrentPos: TPoint;
  MyStartDraw: boolean;
  //
  MyUsePaintOrMyPaint: boolean;
  //
  MyCanvasToWork: TCanvas;
  MyPenWidth: byte = 4;
  MyPenColor: TColor = clYellow;
  MyPenStyle: TPenStyle = TPenStyle.psSolid;
  MyPenMode: TPenMode = TPenMode.pmCopy;

function MyFuncIIFtoBooleans(ACondition: boolean; AColorTrue: TColor; AColorFalse: TColor): TColor;
begin
  result := AColorFalse;
  //
  if ACondition then
    result := AColorTrue;
end;

{ TPanel }

procedure TPanel.Paint;
begin
  inherited;
  //
  ViewFormMain.DrawMyLinesPlease(MyCurrentPos.X, MyCurrentPos.Y);
end;

{ TViewFormMain }

procedure TViewFormMain.Init_Positions(X, Y: Integer);
begin
  MyBeforePos := TPoint.Create(X, Y);
  MyCurrentPos := TPoint.Create(X, Y);
end;

procedure TViewFormMain.FormCreate(Sender: TObject);
begin
  MyStartDraw := false;
  //
  MyCanvasToWork := TMyHackTCustomControl(Pnl_Signature).Canvas;
  //
  Init_Positions(Pnl_Signature.Left, Pnl_Signature.Top);
end;

procedure TViewFormMain.FormDestroy(Sender: TObject);
begin
  MyCanvasToWork := nil;
end;

procedure TViewFormMain.Pnl_SignatureMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  Init_Positions(X, Y);
  //
  MyCanvasToWork.MoveTo(X, Y); // update pen position...
  //
  MyStartDraw := true;
end;

procedure TViewFormMain.Pnl_SignatureMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  MyStartDraw := false;
end;

procedure TViewFormMain.Pnl_SignatureMouseLeave(Sender: TObject);
begin
  MyStartDraw := false;
end;

procedure TViewFormMain.Pnl_SignatureMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
  MyCurrentPos := TPoint.Create(X, Y);
  //
  if (MyBeforePos.X = MyCurrentPos.X) and (MyBeforePos.Y = MyCurrentPos.Y) then
    exit;
  //
  if MyStartDraw then
  begin
    if ChkBxUsePaintEvent.Checked then
      Pnl_Signature.Paint
    else
      DrawMyLinesPlease(MyCurrentPos.X, MyCurrentPos.Y);
  end;
end;

procedure TViewFormMain.DrawMyLinesPlease(X, Y: Integer);
begin
  if MyStartDraw then
  begin
    if MyCanvasToWork.TryLock then // try prevent others writes!
      try
        MyCanvasToWork.Pen.Color := MyFuncIIFtoBooleans(ChkBxUsePaintEvent.Checked, clYellow, clWhite);
        //
        MyCanvasToWork.Pen.Mode := MyPenMode;
        MyCanvasToWork.Pen.Style := MyPenStyle;
        MyCanvasToWork.Pen.Width := MyPenWidth;
        //
        MyCanvasToWork.LineTo(X, Y);
      finally
        MyCanvasToWork.Unlock;
      end;
    //
    MyBeforePos := MyCurrentPos;
  end;
end;

procedure TViewFormMain.Btn_Bitmap_iTClick(Sender: TObject);
var
  MyBmp: TBitmap;
begin
  //
  MyBmp := TBitmap.Create;
  try
    MyBmp.SetSize(Pnl_Signature.Width, Pnl_Signature.Height);
    //
    if BitBlt(MyBmp.Canvas.Handle, 0, 0, Pnl_Signature.Width, Pnl_Signature.Height, MyCanvasToWork.Handle, 0, 0, SRCCOPY) then
      Img_Resulted.Picture.Bitmap.Assign(MyBmp)
    else
      ShowMessage('Sorry, was not possible copy your signature to bitmap!');
  finally
    MyBmp.Free;
  end;
end;

procedure TViewFormMain.Btn_Clear_SignatureClick(Sender: TObject);
begin
  Pnl_Signature.Repaint;
end;

end.

此帖子包含附件:

大小:101.4K

----------------------------------------------
The higher the degree, the greater the respect given to the humblest!RAD 11.3

作者：

emailx45 (emailx45)	▲▲▲▲△	-
	普通会员

2023/10/19 23:12:11

1楼：

NOTE:
-- Im using a "DIDATIC TEXT", then you can change as you need!!!

-- If need store your "POINT(X,Y)" you can use any way: Array, List, TPath, StringList, etc...
----------------------------------------------
The higher the degree, the greater the respect given to the humblest!RAD 11.3

作者：

emailx45 (emailx45)	▲▲▲▲△	-
	普通会员

2023/10/19 23:22:44

2楼：

another sample ...

此帖子包含附件:

大小:262.7K

----------------------------------------------
The higher the degree, the greater the respect given to the humblest!RAD 11.3

作者：

emailx45 (emailx45)	▲▲▲▲△	-
	普通会员

2023/10/20 7:45:24

3楼：

Try this way:

------ FMX sample using ARRAY of TPointF and nothig more!

Pnl_Signature = TPanel ... but any other control works good

implementation

{$R *.fmx}

var
  MyBrush    : TStrokeBrush = nil;
  MyStartDraw: boolean      = false;
  MyPoints   : TArray<TPointF>;

procedure TForm1.FormCreate(Sender: TObject);
begin
  MyBrush          := TStrokeBrush.Create(TBrushKind.Solid, TAlphaColorRec.Blue);
  MyBrush.Thickness := 2.0;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  MyBrush.Free;
end;

procedure TForm1.Pnl_SignatureMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single);
begin
  if (Length(MyPoints) > 0) then
    MyPoints := MyPoints + [TPointF.Create(1000000, 1000000)]; // control-point between 2 or more "MouseDOWN" clicks...
  //
  // --------- start here...
  MyPoints := MyPoints + [TPointF.Create(X, Y)];
  //
  MyStartDraw := true;
end;

procedure TForm1.Pnl_SignatureMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single);
begin
  MyStartDraw := false;
end;

procedure TForm1.Pnl_SignatureMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Single);
begin
  if MyStartDraw then
  begin
    MyPoints := MyPoints + [TPointF.Create(X, Y)];
    //
    Pnl_Signature.Repaint;
  end;
end;

procedure TForm1.Pnl_SignaturePaint(Sender: TObject; Canvas: TCanvas; const ARect: TRectF);
begin
  for var i: integer := 1 to high(MyPoints) do
    if (MyPoints[i - 1].X <> 1000000) and (MyPoints[i].X <> 1000000) then
      Canvas.DrawLine(MyPoints[i - 1], MyPoints[i], 1, MyBrush);
end;

end.

此帖子包含附件:

大小:115.0K

----------------------------------------------
The higher the degree, the greater the respect given to the humblest!RAD 11.3

作者：

sxqwhxq (步惊云)	★☆☆☆☆	-
	普通会员

2023/10/21 8:41:44

4楼：

谢谢巴西大师，这个代码在windows10上没问题，我再试试在android看再跟您报告结果。
----------------------------------------------
-

作者：

sxqwhxq (步惊云)	★☆☆☆☆	-
	普通会员

2023/10/21 9:37:37

5楼：

大师您好，经测试，上述代码在android上运行很好，笔画精细光滑。
现在再加上清除笔画按钮，更完美了：
procedure TForm2.Button1Click(Sender: TObject);
begin
setlength(MyPoints,0);
PaintBox1.Repaint;
end;
----------------------------------------------
-

作者：

sxqwhxq (步惊云)	★☆☆☆☆	-
	普通会员

2023/10/21 15:32:41

6楼：

大师好，虽然上述fmx手写代码比我之前找的代码要精细，但是我发现与手机的手写输入相比仍有差距，怎样改善算法，提高手写的平滑精细度呢？
----------------------------------------------
-

作者：

sxqwhxq (步惊云)	★☆☆☆☆	-
	普通会员

2023/10/21 19:58:15

7楼：

还有，似乎无法将paintbox上的canvas保存为图片
----------------------------------------------
-

作者：

emailx45 (emailx45)	▲▲▲▲△	-
	普通会员

2023/10/21 20:07:54

8楼：

对您来说，“更准确”的定义是什么？你提供更多细节，因为中文文本的翻译并没有让我了解你真正的愿望。
What would be, for you, the definition of "more accurate"? you give more details, because the translation of the Chinese text didn't tell me much to understand your real desire.
----------------------------------------------
The higher the degree, the greater the respect given to the humblest!RAD 11.3

作者：

sxqwhxq (步惊云)	★☆☆☆☆	-
	普通会员

2023/10/21 20:12:37

9楼：

也就是说，我在 Android设备上写的字，与我在纸上写的字，在笔迹上有差异，当然这种差异还是可以接受的。
但主要的问题是，我无法将paintbox上的canvas.bitmap保存为文件或者流。
我现在是创建一个bitmap，跟踪在paintbox签名形成的图片，但把图片保存后，发现会有精度的丢失。
----------------------------------------------
-

作者：

emailx45 (emailx45)	▲▲▲▲△	-
	普通会员

2023/10/21 20:13:21

9楼：

NOTE: Im not master, just a entusiast
----------------------------------------------
The higher the degree, the greater the respect given to the humblest!RAD 11.3

作者：

sxqwhxq (步惊云)	★☆☆☆☆	-
	普通会员

2023/10/21 20:18:40

10楼：

这样会出错，无法保存：
procedure TForm2.Button2Click(Sender: TObject);
begin
    PaintBox1.Canvas.Bitmap.SaveToFile('test.bmp');
end;

我现在这样写：
procedure TForm3.PaintBox1Paint(Sender: TObject; Canvas: TCanvas);
begin
  for var i: integer := 1 to high(MyPoints) do
    if (MyPoints[i - 1].X <> 10000) and (MyPoints[i].X <> 10000) then
    begin
      DrawBMP.Canvas.BeginScene;
      DrawBMP.Canvas.DrawLine(MyPoints[i - 1],  MyPoints[i], 1, MyBrush);
      DrawBMP.Canvas.EndScene;
      Canvas.DrawLine(MyPoints[i - 1], MyPoints[i], 1, MyBrush);
    end;
end;
然后DrawBMP.savetofile('test.jpg');
不知道为什么，发现保存的图片比paintbox上画的图片丑陋些，应该是丢失了精度。
----------------------------------------------
-

作者：

emailx45 (emailx45)	▲▲▲▲△	-
	普通会员

2023/10/21 20:26:05

11楼：

0) in "Paint event" it's not necessary "BeginScene" because this is done on the event!

1) maybe the "resolution" used in Bitmap be diferent of Canvas (your current screen resolution), then the problem can be there. I need test it, but im not in Pc in this moment ok?

2) do the "copy process" out of paint event... when all is done to save it, for example!
----------------------------------------------
The higher the degree, the greater the respect given to the humblest!RAD 11.3

作者：

sxqwhxq (步惊云)	★☆☆☆☆	-
	普通会员

2023/10/21 21:08:05

12楼：

是的，在image上的图片和在paintbox上的画的图片分辨率不一样，将这两张图片合并保存后，paintbox的图形就变粗糙了
----------------------------------------------
-

作者：

sxqwhxq (步惊云)	★☆☆☆☆	-
	普通会员

2023/10/21 21:17:23

13楼：

That is to say, the handwriting on Android devices is different from that on paper, but this difference is acceptable.

The main problem is that I cannot save the canvas.bitmap on paintbox as a file or stream.

Currently, I am creating a bitmap to track the image formed by signing in paintbox, but I found that there will be a loss of accuracy after saving the image.
----------
Yes, the resolution of the image on the canvas and the image drawn on the paintbox are different. When these two images are merged and saved, the graphics on the paintbox become rough.
----------------------------------------------
-

作者：

sxqwhxq (步惊云)	★☆☆☆☆	-
	普通会员

2023/10/21 23:06:30

14楼：

It is said that using drawpath is more accurate than using drawpen. Can you help me write drawpath code?
----------------------------------------------
-

作者：

emailx45 (emailx45)	▲▲▲▲△	-
	普通会员

2023/10/22 3:31:13

15楼：

I can try, if you can!

BUT, to start:
1) TPath, it's nothing more than "TLIST" with "TPoints"... like I showed to you using ARRAY!!! BUT, using a class "TPATH"/"TPATHDATA" to easy usage!!!

.... FMX.Graphics.pas - RAD11.3
procedure TPathData.AddPath(APath: TPathData);
var
  I: Integer;
begin
  FPathData.Capacity := FPathData.Count + APath.Count;
  for I := 0 to APath.Count - 1 do
    FPathData.Add(APath.Points[I]);
  DoChanged;
end;

.... System.Generics.Collections.pas - RAD11.3
function TList<T>.Add(const Value: T): Integer;
begin
  if IsManagedType(T) then
  begin
    if (SizeOf(T) = SizeOf(Pointer)) and not (GetTypeKind(T) in [tkRecord, tkMRecord]) then
      Result := FListHelper.InternalAddMRef(Value, GetTypeKind(T))
    else if GetTypeKind(T) = TTypeKind.tkVariant then
      Result := FListHelper.InternalAddVariant(Value)
    else
      Result := FListHelper.InternalAddManaged(Value);
  end else
  case SizeOf(T) of
    1: Result := FListHelper.InternalAdd1(Value);
    2: Result := FListHelper.InternalAdd2(Value);
    4: Result := FListHelper.InternalAdd4(Value);
    8: Result := FListHelper.InternalAdd8(Value);
  else
    Result := FListHelper.InternalAddN(Value);
  end;
end;
.........

or be, I think that you can arrives in the same place... but with new knowledges... (this is good)

Do you want try?
----------------------------------------------
The higher the degree, the greater the respect given to the humblest!RAD 11.3

作者：

emailx45 (emailx45)	▲▲▲▲△	-
	普通会员

2023/10/22 3:48:47

16楼：

see the BMP generated by my code...

..
..

此帖子包含附件:emailx45_2023102234844.zip 大小:153.3K

----------------------------------------------
The higher the degree, the greater the respect given to the humblest!RAD 11.3

作者：

emailx45 (emailx45)	▲▲▲▲△	-
	普通会员

2023/10/22 3:49:10

17楼：

...

此帖子包含附件:

大小:159.6K

----------------------------------------------
The higher the degree, the greater the respect given to the humblest!RAD 11.3

作者：

emailx45 (emailx45)	▲▲▲▲△	-
	普通会员

2023/10/22 3:52:30

18楼：

use this way, it's more flexible...

--------
procedure MyHandSignaturePainting(ACanvas: TCanvas; APoints: TArray<TPointF>; AStrokeBrush: TStrokeBrush); // to "Canvas" of control and bitmap target...
begin
  if (ACanvas = nil) then
    Exit;
  //
  if ACanvas.BeginScene() then // not necessary if into "OnPaint" event...
    try
      for var i: integer := 1 to high(APoints) do
        if (APoints[i - 1].X <> 1000000) and (APoints[i].X <> 1000000) then
          ACanvas.DrawLine(APoints[i - 1], APoints[i], 1, AStrokeBrush);
    finally
      ACanvas.EndScene;
    end;
end;

procedure MyCanvasToBitmap(ACanvas: TCanvas; ABitmap: TBitmap; APoints: TArray<TPointF>; AStrokeBrush: TStrokeBrush);
begin
  if (ACanvas = nil) or (ABitmap = nil) then
    Exit;
  //
  ABitmap.SetSize(ACanvas.Width, ACanvas.Height); // Bitmap has a limit to max sizes... see on help!
  ABitmap.Clear(TAlphaColorRec.White);          // avoiding "black-out"...
  //
  MyHandSignaturePainting(ABitmap.Canvas, APoints, AStrokeBrush);
end;

procedure MyCopyBitmapTo(const ABitmapIN: TBitmap; var ABitmapOUT: TBitmap);
begin
  if (ABitmapIN = nil) or (ABitmapOUT = nil) then
    Exit;
  // try-except-....
  ABitmapOUT.SetSize(ABitmapIN.Size);
  //ABitmapOUT.Clear(TAlphaColorRec.White); // avoiding "black-out"...
  //
  ABitmapOUT.CopyFromBitmap(ABitmapIN);
end;

----------
procedure TForm1.Pnl_SignaturePaint(Sender: TObject; Canvas: TCanvas; const ARect: TRectF);
begin
  // this event is called many times, since control is created...
  //
  MyHandSignaturePainting(Canvas, LPoints, LStrokeBrush);
end;

----------
procedure TForm1.Button1Click(Sender: TObject);
begin
  if (Length(LPoints) < 2) then // have points?  0..1...
    exit;
  //
  // using same procedure to "Canvas OnPaint"...
  // if needs "scaling" on bitmap, then needs do it before printing...
  //
  MyCanvasToBitmap(Pnl_Signature.Canvas, imgHandSignature.Bitmap, LPoints, LStrokeBrush);

...
end;
----------------------------------------------
The higher the degree, the greater the respect given to the humblest!RAD 11.3

作者：

emailx45 (emailx45)	▲▲▲▲△	-
	普通会员

2023/10/22 4:02:39

19楼：

running....

.
.

此帖子包含附件:

大小:385.4K

----------------------------------------------
The higher the degree, the greater the respect given to the humblest!RAD 11.3

作者：

sxqwhxq (步惊云)	★☆☆☆☆	-
	普通会员

2023/10/22 8:58:26

20楼：

//您上面的代码与我上面的代码，绘图效果是一样的。我在这里写
The drawing effect of the code above you is the same as that of mine. I'm writing here

procedure TForm3.PaintBox1Paint(Sender: TObject; Canvas: TCanvas);
begin
  for var i: integer := 1 to high(MyPoints) do
    if (MyPoints[i - 1].X <> 10000) and (MyPoints[i].X <> 10000) then
    begin
      DrawBMP.Canvas.BeginScene;//此处打开 DrawBMP的canvas
      DrawBMP.Canvas.DrawLine(MyPoints[i - 1],  MyPoints[i], 1, MyBrush);
      DrawBMP.Canvas.EndScene;//此处关闭DrawBMP的canvas
      Canvas.DrawLine(MyPoints[i - 1], MyPoints[i], 1, MyBrush);//PaintBox1的canvas不做任何操作
    end;
end;

我这样阅起来更简洁。
----------------------------------------------
-

作者：

sxqwhxq (步惊云)	★☆☆☆☆	-
	普通会员

2023/10/22 9:31:58

21楼：

I have already inserted an image in Image1, which is used for signing. Then I draw some text in the PaintBox for signing. Finally, I use a Bitmap to draw the two images together. Now the problem is:

Due to the different resolutions of the image in Image1 and the image in the PaintBox (generally, the resolution of the image in Image1 is much higher than that in the PaintBox), if we do not change the resolution, after drawing the two images together, the image in the PaintBox will be obviously smaller. If we enlarge the image in the PaintBox, there will be obvious jagged edges.

Perhaps we need to use interpolation method to correct the image in the PaintBox?
----------------------------------------------
-

作者：

sxqwhxq (步惊云)	★☆☆☆☆	-
	普通会员

2023/10/22 9:33:13

22楼：

把paintbox放在image1上面，保持一样大小
我在image1里装一个图片，用来签名
然后在paintbox里画写文字进行签名
最后我用一个bitmap把两个图片drawbitmap在一起。
现在的问题是：
由于image1里的图片与paintbox里的分辨率不一样，（一般是image里图片的分辨率要比paintbox里高很多），如果不改变分辨率，两图drawbitmap在一起后，paintbox的图片明显变小了，如果把paintbox里的图放大后，则会出现了明显的锯齿。
也许需要把paintbox里的图用插值方法进行修正,或者改善绘制文字的算法，保存放大一定程序不会失真。
----------------------------------------------
-

作者：

sxqwhxq (步惊云)	★☆☆☆☆	-
	普通会员

2023/10/22 10:18:43

23楼：

I will place the PaintBox over Image1 and keep them the same size. I have inserted an image in Image1 for signing. Then I draw some text in the PaintBox for signing. Finally, I use a Bitmap to draw the two images together. The current issue is:

Due to the different resolutions of the image in Image1 and the image in the PaintBox (generally, the resolution of the image in Image1 is much higher than that in the PaintBox), if we do not change the resolution, after drawing the two images together, the image in the PaintBox will be obviously smaller. If we enlarge the image in the PaintBox, there will be obvious jagged edges.

Perhaps we need to use interpolation method to correct the image in the PaintBox, or improve the algorithm for drawing text to ensure that it does not lose its quality when zoomed in.
----------------------------------------------
-

作者：

sxqwhxq (步惊云)	★☆☆☆☆	-
	普通会员

2023/10/23 13:53:14

24楼：

终于解决了，用插值方法后仍然会有锯齿。
插值在两个点中插入中点，然而锯齿依旧
仔细分析是由于手写屏幕与背景图分辨率差距造成的。
现在用跟踪的bitmap扩大一倍后，再住图片上写字，保存后分辨率就没什么损失了
代价是保存的图片会变大差不多一倍
----------------------------------------------
-

作者：

emailx45 (emailx45)	▲▲▲▲△	-
	普通会员

2023/10/23 20:28:34

25楼：

@sxqwhxq

show the code for analize...
----------------------------------------------
The higher the degree, the greater the respect given to the humblest!RAD 11.3

作者：

sxqwhxq (步惊云)	★☆☆☆☆	-
	普通会员

2023/10/23 21:31:06

26楼：

现在仍然有问题，如果仅写3-5个汉字没问题，然后越写越慢越写越差。
问题还是这段代码：
procedure TForm3.PaintBox1Paint(Sender: TObject; Canvas: TCanvas);
begin
  for var i: integer := 1 to high(MyPoints) do
    if (MyPoints[i - 1].X <> 10000) and (MyPoints[i].X <> 10000) then
    begin
      DrawBMP.Canvas.BeginScene;//此处打开 DrawBMP的canvas
      DrawBMP.Canvas.DrawLine(MyPoints[i - 1],  MyPoints[i], 1, MyBrush);
      DrawBMP.Canvas.EndScene;//此处关闭DrawBMP的canvas
      Canvas.DrawLine(MyPoints[i - 1], MyPoints[i], 1, MyBrush);
    end;
end;
随着字数增加，MyPoints数组越来越大， Canvas.DrawLine会越来慢，效果越来越差
Canvas.DrawLine(MyPoints[i - 1], MyPoints[i], 1, MyBrush);
----------------------------------------------
-

作者：

emailx45 (emailx45)	▲▲▲▲△	-
	普通会员

2023/10/23 22:42:25

27楼：

0）不要坚持走一条通往无限的路！！！改变路线，即使它看起来是错误的，如果是的话，再次改变它。到了某个时候，正确的路线将会被揭示，即使有很多条路线。

1）您是否尝试过在写入完成后将点写入位图上？即使您不希望这样，这也有利于测试结果。然后，分析正反两点，然后重做必要的事情。

2）您是否尝试过在Mouse-ONDOWN事件中激活位图的BeginScene并在Mouse-ONUP事件中停用它？这样，它们每个只能使用一次！

3）我认为代码只执行实际必要的实时过程会更明智......所有其他过程都应该在必要时执行，即在创建点之后创建最终的位图。因此，您可以在 PaintBox、Panel 等画布上绘制点……并在屏幕上书写结束时将绘图保留在位图上。

0) Don’t insist on a path that goes to infinity!!!  change the route, even if it seems wrong, and, if so, change it again.  At some point, the proper route will be revealed, even if there are many.

1) Have you tried writing the points on the bitmap after writing is finished?  Even if you don't want it this way, it's good for testing results.  Then, analyze the positive and negative points, and then redo what is necessary.

2) Have you tried activating the bitmap's BeginScene in the Mouse-ONDOWN event and deactivating it in the Mouse-ONUP event?  This way, they will only be used once each!

3) I think it would be more sensible for the code to only carry out real-time processes that are actually necessary... all other processes should be carried out when necessary, that is, after creating the points, create the final bitmap.  So, you can draw the points on the canvas of PaintBox, Panel, etc.... and leave the drawing on the bitmap at the end of your writing on the screen.
----------------------------------------------
The higher the degree, the greater the respect given to the humblest!RAD 11.3

作者：

sxqwhxq (步惊云)	★☆☆☆☆	-
	普通会员

2023/10/23 22:52:30

28楼：

我还尝试这样，用image替代paintbox：
var
   LastPoint:TPointF;
   DrawSF:boolean;
procedure TForm2.Button1Click(Sender: TObject);
begin
  img1.Bitmap.Clear(TAlphaColors.Null);
end;

procedure TForm2.FormCreate(Sender: TObject);
begin
   MyBrush          := TStrokeBrush.Create(TBrushKind.Solid, TAlphaColorRec.black);
   MyBrush.Thickness := 1.3;
   img1.Bitmap := TBitmap.Create(round(img1.Width), round(img1.Height));
   img1.Bitmap.Clear(TAlphaColors.Null);
end;

procedure TForm2.img1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Single);
begin
   LastPoint.X:=X;
   LastPoint.Y:=Y;
   DrawSF:=true;
end;

procedure TForm2.img1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Single);
var
  thisPoint: TPointF;
begin
  if  DrawSF then
  begin
    thisPoint.X := X;
    thisPoint.Y := Y;
    with img1.Bitmap.Canvas do
    begin
    BeginScene;
    DrawLine(LastPoint, thisPoint, 1, MyBrush);
    EndScene;
  end;

    LastPoint := thisPoint;
  end;

end;

procedure TForm2.img1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Single);
begin
    DrawSF:=false;
end;

procedure TForm2.img1Tap(Sender: TObject; const Point: TPointF);
begin
  DrawSF:=True;
  lastPoint := Point;
end;
但写出的字还是有明显的锯齿。
----------------------------------------------
-

作者：

sxqwhxq (步惊云)	★☆☆☆☆	-
	普通会员

2023/10/24 12:20:51

29楼：

procedure TForm3.PaintBox1Paint(Sender: TObject; Canvas: TCanvas);
begin
  for var i: integer := 1 to high(MyPoints) do
    if (MyPoints[i - 1].X <> 10000) and (MyPoints[i].X <> 10000) then
       Canvas.DrawLine(MyPoints[i - 1], MyPoints[i], 1, MyBrush);
end;
把这个代码放在另外的按钮中，等画完后再一次写入位图，可解决越写越慢的问题：
DrawBMP.Canvas.BeginScene;//此处打开 DrawBMP的canvas
      DrawBMP.Canvas.DrawLine(MyPoints[i - 1],  MyPoints[i], 1, MyBrush);
      DrawBMP.Canvas.EndScene;//此处关闭DrawBMP的canvas
但是  Canvas.DrawLine(MyPoints[i - 1], MyPoints[i], 1, MyBrush);这种绘制文字的方法仍然有不足，仔细观察还是有锯齿。
----------------------------------------------
-

作者：

emailx45 (emailx45)	▲▲▲▲△	-
	普通会员

2023/10/24 22:24:17

30楼：

我们来谈谈数字环境中的“PPI”和“DPI”

see my little post
https://bbs.2ccc.com/topic.asp?topicid=685342
----------------------------------------------
The higher the degree, the greater the respect given to the humblest!RAD 11.3

信息

登陆以后才能回复