delphi - Delphi Graphics32 レイヤー上でマウスを使って線を引く方法

Question

線を動的に描画するこの優れた方法(デルファイを使用した Photoshop スタイルの線の描画)を Graphics32に変換するのを手伝ってくれる人はいますか?

つまり、ImgView が必要で、それに新しいレイヤーを追加してから、フォームのキャンバスではなくレイヤーでこれらのメソッドを実行します。

したがって、私のコードは次のようになります。

 private
    FStartPoint, FEndPoint: TPoint;
    FDrawingLine: boolean;
    bm32: TBitmap32;

...

procedure TForm1.FormCreate(Sender: TObject);
begin
  bm32 := TBitmap32.Create;
  FDrawingLine := false;
end;

procedure TForm1.FormShow(Sender: TObject);
begin
  with ImgView do
  begin
    Selection := nil;
    RBLayer := nil;
    Layers.Clear;
    Scale := 1;
    Bitmap.SetSize(800, 600);
    Bitmap.Clear(clWhite32);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  B : TBitmapLayer;
  P: TPoint;
  W, H: Single;
begin
        B := TBitmapLayer.Create(ImgView.Layers);
        with B do
        try
          Bitmap.DrawMode := dmBlend;
          with ImgView.Bitmap do Location := GR32.FloatRect(0, 0, 600, 400);
          Scaled := True;
          OnMouseDown := LayerMouseDown;
          OnMouseUp := LayerMouseUp;
          OnMouseMove := LayerMouseMove;
          OnPaint := LayerOnPaint;
        except
          Free;
          raise;
        end;
end;

これらはリンクからの通常のキャンバス描画メソッドで使用されるイベントであるため、このコードを想定していますが、残りのメソッドは本来のように機能しません

procedure TForm1.AddLineToLayer;
begin
  bm32.Canvas.MoveTo(FStartPoint.X, FStartPoint.Y);
  bm32.Canvas.LineTo(FEndPoint.X, FEndPoint.Y);
end;

procedure TForm1.SwapBuffers32;
begin
  BitBlt(imgView.Canvas.Handle, 0, 0, ClientWidth, ClientHeight,bm32.Canvas.Handle, 0, 0, SRCCOPY);
end;

procedure TForm1.SwapBuffers;
begin
  BitBlt(Canvas.Handle, 0, 0, ClientWidth, ClientHeight,
    bm.Canvas.Handle, 0, 0, SRCCOPY);
end;


procedure TForm1.LayerMouseDown(Sender: TObject; Buttons: TMouseButton;Shift: TShiftState; X, Y: Integer);
begin
  FStartPoint := Point(X, Y);
  FDrawingLine := true;
end;

procedure TForm1.LayerMouseUp(Sender: TObject; Buttons: TMouseButton;Shift: TShiftState; X, Y: Integer);
begin
  FDrawingLine := false;
  FEndPoint := Point(X, Y);
  AddLineToLayer;
  SwapBuffers;
end;

procedure TForm1.LayerMouseMove(Sender: TObject; Shift: TShiftState;X, Y: Integer);
begin
  if FDrawingLine then
  begin
    SwapBuffers;
    ImgView.Canvas.MoveTo(FStartPoint.X, FStartPoint.Y);
    ImgView.Canvas.LineTo(X, Y);
  end;
end;

procedure TForm1.LayerOnPaint(Sender: TObject; Buffer: TBitmap32);
begin
  SwapBuffers;
end;

だからうまくいきません。何も起こりません。通常のキャンバス描画のようにこの作業を行うのを手伝ってくれる人はいますか? Button1Click で作成した 1 つのレイヤーだけでこれを実現したい (ImgView はフォームに配置された ImgView32 コントロールであり、フォームにもボタンがあります)

結果は次のようになります (Canvas では描画が許可されていないというエラーが表示されます) ここに画像の説明を入力最初に onButtonClick でエラーが表示され、OK した後、描画を開始すると、移動する線が消去されません (上の画像のように)。 onMouseUp で Canvas エラーが再び表示されます。

私は何を間違っていますか？

SwapBuffers32 を使用すると、何も描画されず、キャンバスエラーが表示され続けます。

編集:Tom Brunbergの提案の後に機能させるためにいくつかの変更を加えたところ、次のコードになりました:

 private
    FStartPoint, FEndPoint: TPoint;
    FDrawingLine: boolean;
    bm32: TBitmap32;
    B : TBitmapLayer;
    FSelection: TPositionedLayer;
  public
    procedure AddLineToLayer;
    procedure SwapBuffers32;
    procedure LayerMouseDown(Sender: TObject; Buttons: TMouseButton;Shift: TShiftState; X, Y: Integer);
    procedure LayerMouseUp(Sender: TObject; Buttons: TMouseButton;Shift: TShiftState; X, Y: Integer);
    procedure LayerMouseMove(Sender: TObject; Shift: TShiftState;X, Y: Integer);
    procedure LayerOnPaint(Sender: TObject; Buffer: TBitmap32);
    procedure SetSelection(Value: TPositionedLayer);
    property Selection: TPositionedLayer read FSelection write SetSelection;
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
var
  P: TPoint;
  W, H: Single;
begin
   bm32 := TBitmap32.Create;
   bm32.SetSize(800,600);
      with ImgView do
        begin
          Selection := nil;
          Layers.Clear;
          Scale := 1;
          Bitmap.SetSize(800, 600);
          Bitmap.Clear(clWhite32);
        end;

        B := TBitmapLayer.Create(ImgView.Layers);
        with B do
        try
          Bitmap.DrawMode := dmBlend;
          B.Bitmap.SetSize(800,600);
          with ImgView.Bitmap do Location := GR32.FloatRect(0, 0, 800, 600);
          Scaled := True;
          OnMouseDown := LayerMouseDown;
          OnMouseUp := LayerMouseUp;
          OnMouseMove := LayerMouseMove;
          OnPaint := LayerOnPaint;
        except
          Free;
          raise;
        end;
  FDrawingLine := false;
end;

procedure TForm1.AddLineToLayer;
begin
  bm32.Canvas.MoveTo(FStartPoint.X, FStartPoint.Y);
  bm32.Canvas.LineTo(FEndPoint.X, FEndPoint.Y);
end;

procedure TForm1.SwapBuffers32;
begin
//  BitBlt(imgView.Canvas.Handle, 0, 0, ClientWidth, ClientHeight,bm32.Canvas.Handle, 0, 0, SRCCOPY);
  BitBlt(B.Bitmap.Canvas.Handle, 0, 0, ClientWidth, ClientHeight,bm32.Canvas.Handle, 0, 0, SRCCOPY);
end;


procedure TForm1.LayerMouseDown(Sender: TObject; Buttons: TMouseButton;Shift: TShiftState; X, Y: Integer);
begin
  FStartPoint := Point(X, Y);
  FDrawingLine := true;
end;

procedure TForm1.LayerMouseUp(Sender: TObject; Buttons: TMouseButton;Shift: TShiftState; X, Y: Integer);
begin
  FDrawingLine := false;
  FEndPoint := Point(X, Y);
  AddLineToLayer;
  SwapBuffers32;
end;

procedure TForm1.LayerMouseMove(Sender: TObject; Shift: TShiftState;X, Y: Integer);
begin
  if FDrawingLine then
  begin
    SwapBuffers32;
    ImgView.Canvas.MoveTo(FStartPoint.X, FStartPoint.Y);
    ImgView.Canvas.LineTo(X, Y);
  end;
end;

procedure TForm1.LayerOnPaint(Sender: TObject; Buffer: TBitmap32);
begin
  SwapBuffers32;
end;


procedure TForm1.SetSelection(Value: TPositionedLayer);
begin
  if Value <> FSelection then
  begin
    FSelection := Value;
  end;
end;

これで、Canvas エラーはなくなりましたが、マウス移動の線は描画されたままです... 解決策は、BitBlt 関数 (swapbuffers32) にあるはずです。何か案は？

score 1 · Accepted Answer

不要な行の消去に失敗するという問題を理解するには、Anders Rejbrands ソリューションがどのように機能するかを確認する必要があります。インメモリビットマップbmは、必要な行を格納するビットマップです。フォームのcanvasは、マウス操作をキャッチしてユーザーにフィードバックを提供するパッドとして機能します。MouseDownとMouseUpイベント (必要な開始点と終了点を決定する) の間に、多くのMouseMoveイベントを受け取ります。それぞれについて、フォームキャンバスからごみ (前の MouseMove の残り)を消去MouseMoveする最初の呼び出しSwapBuffersを行います。次に、始点から現在のマウス位置まで線を引きます。消去は、フォームキャンバスにコンテンツをコピー (BitBlt) することによって行われます。bm

不要な行の消去が機能しないため、bm32コードを詳しく調べる必要があります。FormCreate で作成しますが、サイズを指定することはありません。そして、それが問題です。からコピーするものはありませんSwapBuffers32。

また、ビットマップにはサイズがないため、描画できません。したがって、エラーメッセージ。

の他のバージョンは、他のコードには表示されない変数をSwapBuffer参照しているbmため、それについてはまったくコメントできません。

ユーザーコードの更新後に編集します。

FormCreate で、bm32 のサイズを設定した後、追加します。

  bm32.Clear(clWhite32); // Add this line

次の2行を変更します

//    with ImgView.Bitmap do Location := GR32.FloatRect(0, 0, 800, 600);
    B.Location := GR32.FloatRect(0, 0, 800, 600);
//    Scaled := True;
    Scaled := False;

そして最後に FormCreate の最後に追加します

  SwapBuffers32;

LayerMouseMove で、ImgView を B.BitMap に置き換えます

//    ImgView.Canvas.MoveTo(FStartPoint.X, FStartPoint.Y);
//    ImgView.Canvas.LineTo(X, Y);
    B.Bitmap.Canvas.MoveTo(FStartPoint.X, FStartPoint.Y);
    B.Bitmap.Canvas.LineTo(X, Y);

SwapBuffers32 では、ClientWidth と ClientHeight を B.Bitmap のプロパティに置き換えます。

  BitBlt(B.Bitmap.Canvas.Handle, 0, 0, B.Bitmap.Width, B.Bitmap.Height,bm32.Canvas.Handle, 0, 0, SRCCOPY);

これらの変更は、bm32 が意図した行を引き続き収集できるように機能します。MouseUp の最後の呼び出しは SwapBuffers に対するものであるため、B レイヤーはこれらの行の最終コピーを取得します。レイヤーに描画したかったので、ImgView.Bitmapは何にも関係しません。

ユーザーからのコメントの後に編集...

実際、私が行った変更がもう 1 つあります。言い忘れすみません。

FormCreate で、with B...

//    Bitmap.DrawMode := dmBlend;
    Bitmap.DrawMode := dmOpaque;

delphi - Delphi Graphics32 レイヤー上でマウスを使って線を引く方法

2 に答える 2

Related

Reference