delphi - Delphi Graphics32 の相対マウス位置（レイヤーまで）

Question

すべてのフォームマージンに固定されている ImgView32 があります。フォームが最大化されます。

ImgView のビットマップは固定されていません (サイズが異なる場合があります)。

この質問のコードを使用して、透明なレイヤーに線を引こうとしています: Drawing lines on layer

問題は、その正確なコードを使用すると、次の画像のように左上隅にしか描画できないことです。フォームのリサイズ後の描画（最大化）

ご覧のとおり、線は左上隅にのみ描画できます。開始点と終了点に値を追加しようとすると、すべてが狂ってしまいます。したがって、ユーザーが中央の四角形の内側にのみ描画できるようにポイントを変換する方法を見つける必要があります (画像に表示されています)。

私はアイデアがありません。

助けてください

ユニット全体は次のとおりです。

unit MainU;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs,GR32, GR32_Image, GR32_Layers, GR32_Backends, GR32_PNG, StdCtrls,
  ExtCtrls;

type
  TForm5 = class(TForm)
    ImgView: TImgView32;
    Button1: TButton;
    Memo: TMemo;
    Edit3: TEdit;
    Button2: TButton;
    RadioGroup1: TRadioGroup;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure ImgViewPaintStage(Sender: TObject; Buffer: TBitmap32;
      StageNum: Cardinal);
    procedure ImgViewResize(Sender: TObject);
 private
    { Private declarations }
    FStartPoint, FEndPoint: TPoint;
    FDrawingLine: boolean;
    bm32: TBitmap32;
    BL : TBitmapLayer;
    FSelection: TPositionedLayer;
 public
    { Public declarations }
    procedure AddLineToLayer;
    procedure AddCircleToLayer;
    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;

    Procedure SelectGraficLayer(idu:string);
    procedure AddTransparentPNGlayer;

  end;

var
  Form5: TForm5;

implementation

{$R *.dfm}

var
  imwidth: integer;
  imheight: integer;
  OffsX, OffsY: Integer;

const
  penwidth = 3;
  pencolor = clBlue;  // Needs to be a VCL color!

procedure TForm5.AddLineToLayer;
begin
  bm32.Canvas.Pen.Color := pencolor;
  bm32.Canvas.Pen.Width := penwidth;
  bm32.Canvas.MoveTo(FStartPoint.X, FStartPoint.Y);
  bm32.Canvas.LineTo(FEndPoint.X, FEndPoint.Y);
end;

procedure TForm5.FormCreate(Sender: TObject);
var
  P: TPoint;
  W, H: Single;
begin
  imwidth := Form5.ImgView.Width;
  imheight := Form5.ImgView.Height;

  with ImgView.PaintStages[0]^ do
  begin
    if Stage = PST_CLEAR_BACKGND then Stage := PST_CUSTOM;
  end;

  bm32 := TBitmap32.Create;
  bm32.DrawMode := dmTransparent;
  bm32.SetSize(imwidth,imheight);
  bm32.Canvas.Pen.Width := penwidth;
  bm32.Canvas.Pen.Color := pencolor;

  with ImgView do
  begin
    Selection := nil;
    Layers.Clear;
    Scale := 1;
    Scaled := True;
    Bitmap.DrawMode := dmTransparent;
    Bitmap.SetSize(imwidth, imheight);
    Bitmap.Canvas.Pen.Width := 4;//penwidth;
    Bitmap.Canvas.Pen.Color := clBlue;
    Bitmap.Canvas.FrameRect(Rect(20, 20, imwidth-20, imheight-20));
    Bitmap.Canvas.TextOut(15, 32, 'ImgView');
  end;

  AddTransparentPNGLayer;

  BL := TBitmapLayer.Create(ImgView.Layers);
  try
    BL.Bitmap.DrawMode := dmTransparent;
    BL.Bitmap.SetSize(imwidth,imheight);
    BL.Bitmap.Canvas.Pen.Width := penwidth;
    BL.Bitmap.Canvas.Pen.Color := pencolor;
    BL.Location := GR32.FloatRect(0, 0, imwidth, imheight);
    BL.Scaled := False;
    BL.OnMouseDown := LayerMouseDown;
    BL.OnMouseUp := LayerMouseUp;
    BL.OnMouseMove := LayerMouseMove;
    BL.OnPaint := LayerOnPaint;
  except
  Edit3.Text:=IntToStr(BL.Index);
    BL.Free;
    raise;
  end;

  FDrawingLine := false;
  SwapBuffers32;
end;

procedure TForm5.FormDestroy(Sender: TObject);
begin
  bm32.Free;
  BL.Free;
end;

procedure TForm5.ImgViewPaintStage(Sender: TObject; Buffer: TBitmap32;
  StageNum: Cardinal);
const            //0..1
  Colors: array [Boolean] of TColor32 = ($FFFFFFFF, $FFB0B0B0);
var
  R: TRect;
  I, J: Integer;
  OddY: Integer;
  TilesHorz, TilesVert: Integer;
  TileX, TileY: Integer;
  TileHeight, TileWidth: Integer;
begin
  TileHeight := 13;
  TileWidth := 13;

  TilesHorz := Buffer.Width div TileWidth;
  TilesVert := Buffer.Height div TileHeight;
  TileY := 0;

  for J := 0 to TilesVert do
  begin
    TileX := 0;
    OddY := J and $1;
    for I := 0 to TilesHorz do
    begin
      R.Left := TileX;
      R.Top := TileY;
      R.Right := TileX + TileWidth;
      R.Bottom := TileY + TileHeight;
      Buffer.FillRectS(R, Colors[I and $1 = OddY]);
      Inc(TileX, TileWidth);
    end;
    Inc(TileY, TileHeight);
  end;
end;

procedure TForm5.ImgViewResize(Sender: TObject);
begin
  OffsX := (ImgView.ClientWidth - imwidth) div 2;
  OffsY := (ImgView.ClientHeight - imheight) div 2;
  BL.Location := GR32.FloatRect(OffsX, OffsY, imwidth+OffsX, imheight+OffsY);
end;

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

procedure TForm5.LayerMouseMove(Sender: TObject; Shift: TShiftState; X,  Y: Integer);
begin
  if FDrawingLine then
  begin
    SwapBuffers32;
      BL.Bitmap.Canvas.Pen.Color := pencolor;
      BL.Bitmap.Canvas.MoveTo(FStartPoint.X-OffsX, FStartPoint.Y-OffsY);
      BL.Bitmap.Canvas.LineTo(X-OffsX, Y-OffsY);
  end;
end;

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

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

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

procedure TForm5.SwapBuffers32;
begin
    TransparentBlt(
      BL.Bitmap.Canvas.Handle, 0, 0, BL.Bitmap.Width, BL.Bitmap.Height,
      bm32.Canvas.Handle, 0, 0, bm32.Width, bm32.Height, clWhite);
end;

procedure TForm5.AddTransparentPNGlayer;
var
  mypng:TPortableNetworkGraphic32;
  B : TBitmapLayer;
  P: TPoint;
  W, H: Single;
begin
      try
        mypng := TPortableNetworkGraphic32.Create;
        mypng.LoadFromFile('C:\Location\Of\ATransparentPNGFile.png');
        B := TBitmapLayer.Create(ImgView.Layers);
        with B do
        try
          mypng.AssignTo(B.Bitmap);
          Bitmap.DrawMode := dmBlend;
          with ImgView.GetViewportRect do
            P := ImgView.ControlToBitmap(GR32.Point((Right + Left) div 2, (Top + Bottom) div 2));
          W := Bitmap.Width * 0.5;
          H := Bitmap.Height * 0.5;
          Location := GR32.FloatRect(P.X - W, P.Y - H, P.X + W, P.Y + H);
          Scaled := True;
          OnMouseDown := LayerMouseDown;
        except
          Free;
          raise;
        end;
        Selection := B;
        Edit3.Text:=IntToStr(B.Index);
      finally
        mypng.Free;
      end;
end;

end.

私は何を間違っていますか？上記のユニットをテストして、私の意味を確認してください。ImgView を追加してすべての余白に固定し、実行時にフォームを最大化して線を描画することを忘れないでください...

編集

上の緑色の画像では、中央に四角形のような四角形がありますが (あまり目立ちません)、よく見るとわかります。

私の問題は誤解されているかもしれないので、次の画像を見てください

ImgView の中央にある白い四角形 (ビットマップ) にのみ描画できるようにする必要があります。どう説明したらよいかわかりません。

それは私のプロジェクトのポイントではないため、長方形/ビットマップをImgViewに正確にフィットさせることは私にとって解決策ではありません。

Paint.net を見て、私のプロジェクトが同じようなことをしていると想像してみてください (それほど複雑ではないことを除けば)。しかし、原則は同じです。新しいプロジェクトを開始するときにドキュメント/画像のサイズを決定し、さまざまな画像をレイヤーとして追加し、それらを拡大縮小して回転させます。次に、ユーザーが内部に線を描画できるようにしたいと考えています特別なレイヤー (描画レイヤー) しかし、すべてはそのドキュメントサイズの境界内で発生します。たとえば上の画像のように、ドキュメントのサイズは A5 (100dpi) を 83% にスケーリングしたものです。

したがって、私の問題は、ユーザーが白い長方形の外側 (画面の中央) に線を引くことを許可できないことです。したがって、彼らの線はそれらの境界で始まり、そこで終わることができます。

テストユニットが完全にきれいではないことはわかっています。メインプロジェクトで使用されているいくつかの関数を貼り付け、この例に関係のないいくつかの部分をすばやく削除しました。AddTransparentPng プロシージャは、透明なイメージを ImgView に追加するテストを許可するためだけに存在するため、描画レイヤーが別のレイヤーをカバーしていないかどうかをテストできます。

(Scaled プロパティはレイヤー (B) に属し、'with B' ステートメントの下にあります。With 'ImgView.Bitmap... Location' ステートメントを削除したので、もう気にする必要はありません :) )

とにかく、線の描画に影響しないコードには注意しないでください。そのコードは注意が必要です。

EDIT レイヤーのスケーリングをtrue（Scaled：= true）に設定すると、次の画像のようにすべてが台無しになります。ここに画像の説明を入力

まだオフセットを使用する必要がありますが、少し異なります

ありがとうございました

score 4 · Accepted Answer

エラー 1

LayerMouseMove() では、BL.Bitmap.Canvas.MoveTo() の FStartPoint から OffsX と OffsY を減算します。FStartPoint は、LayerMouseDown() で既に調整されています。「3 つの Mouse proc で、X と Y の引数のみを X-OffsX と Y-OffsY になるように調整してください」と言いました。注arguments onlyここに LayerMouseMove() が修正されています。

procedure TForm5.LayerMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if FDrawingLine then
  begin
    SwapBuffers32;
      BL.Bitmap.Canvas.Pen.Color := pencolor;
//      BL.Bitmap.Canvas.MoveTo(FStartPoint.X-OffsX, FStartPoint.Y-OffsY);
      BL.Bitmap.Canvas.MoveTo(FStartPoint.X, FStartPoint.Y);
      BL.Bitmap.Canvas.LineTo(X-OffsX, Y-OffsY);
  end;
end;

エラー 2

if FDrawingLine then ...また、レイヤーの外でマウスダウンが発生し、レイヤー内でマウスアップが発生した場合の偽の行を回避するために、LayerMouseUp() に条件を追加するように指示しました。修正された LayerMouseUp():

procedure TForm5.LayerMouseUp(Sender: TObject; Buttons: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if FDrawingLine then
  begin
    FDrawingLine := false;
    FEndPoint := Point(X-OffsX, Y-OffsY);
    AddLineToLayer;
    SwapBuffers32;
  end;
end;

エラー 3

投稿されたコードは、最初の画像が示すようには機能しません。BL.Location := ...画像は、ImgViewResize()の行をアウトコメントしたように見えます。のためにこれをした可能性がありますError one。とにかく、次のように ImgViewResize を使用し、上記の他の修正を行うと、次の図に示すような結果が得られます。

procedure TForm5.ImgViewResize(Sender: TObject);
begin
  // centering the drawing area
  OffsX := (ImgView.ClientWidth - imwidth) div 2;
  OffsY := (ImgView.ClientHeight - imheight) div 2;
  BL.Location := GR32.FloatRect(OffsX, OffsY, imwidth+OffsX, imheight+OffsY);
end;

描画領域のサイズを変数imwidthおよび定義します。imheightこれらを変更する場合は、再計算する必要がOffsXありOffsY、バックバッファのサイズも変更する必要がありますbm32。

ここに画像の説明を入力

隅の線は、ウィンドウの中央にある作図領域 (imwidth と imheight で定義) の範囲を示します。ウィンドウを最大化しても同じです。

score 0 · Accepted Answer

わかりました、解決しました。最終的な（関連する）コードは次のとおりです。

procedure TForm5.ImgViewResize(Sender: TObject);
begin
  OffsX := (ImgView.ClientWidth - imwidth) div 2;
  OffsY := (ImgView.ClientHeight - imheight) div 2;
  BL.Location := GR32.FloatRect(OffsX, OffsY, imwidth+OffsX, imheight+OffsY);
end;

procedure TForm5.SwapBuffers32;
begin
    TransparentBlt(
      BL.Bitmap.Canvas.Handle, 0, 0, BL.Bitmap.Width, BL.Bitmap.Height,
      bm32.Canvas.Handle, 0, 0, bm32.Width, bm32.Height, clWhite);
end;


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

procedure TForm5.LayerMouseMove(Sender: TObject; Shift: TShiftState; X,  Y: Integer);
begin
  if FDrawingLine then
  begin
    SwapBuffers32;
      BL.Bitmap.Canvas.Pen.Color := pencolor;
      BL.Bitmap.Canvas.MoveTo(FStartPoint.X, FStartPoint.Y);
      BL.Bitmap.Canvas.LineTo(X-OffsX, Y-OffsY);
  end;
end;


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

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

procedure TForm5.AddLineToLayer;
begin
  bm32.Canvas.Pen.Color := pencolor;
  bm32.Canvas.Pen.Width := penwidth;
  bm32.Canvas.MoveTo(FStartPoint.X, FStartPoint.Y);
  bm32.Canvas.LineTo(FEndPoint.X, FEndPoint.Y);
end;

このコードでは、すべてが期待どおりに機能します。線の描画は境界内でのみ発生します

ありがとうございました

delphi - Delphi Graphics32 の相対マウス位置（レイヤーまで）

2 に答える 2

Related

Reference