quadratischen Rahmen auf Canvas ziehen

    quadratischen Rahmen auf Canvas ziehen

    Ich verwende den nachfolgenen Code aus dem SwissDelphiCenter (Server ist seit einigen Tagen down) und zeichne damit erfolgreich einen Auswahlrahmen mit der Maus auf einem Canvas.
    Nun würde ich ihn gerne so verändern, dass kein Rechteck, sondern stets nur ein Quadrat gezogen werden kann. Die Y-Koordinate soll also an die X-Koordinate gekoppelt werden.

    Ich habe schon viel rumprobiert aber es gelingt mir nicht.
    Weiss jemand Rat?


    Delphi-Code

    1. private
    2. { Private declarations }
    3. AnchorX, AnchorY,
    4. CurX, CurY: Integer;
    5. Bounding: Boolean;
    6. end;
    7. implementation
    8. procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
    9. Shift: TShiftState; X, Y: Integer);
    10. begin
    11. AnchorX := X;
    12. CurX := X;
    13. AnchorY := Y;
    14. CurY := Y;
    15. Bounding := True;
    16. end;
    17. procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
    18. Y: Integer);
    19. begin
    20. if Bounding then
    21. begin
    22. Canvas.Pen.Mode := pmNot;
    23. Canvas.Pen.Width := 2;
    24. Canvas.Brush.Style := bsClear;
    25. Canvas.Rectangle(AnchorX, AnchorY, CurX, CurY);
    26. CurX := X;
    27. CurY := Y;
    28. Canvas.Rectangle(AnchorX, AnchorY, CurX, CurY);
    29. end;
    30. end;
    31. procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
    32. Shift: TShiftState; X, Y: Integer);
    33. begin
    34. if Bounding then
    35. begin
    36. Bounding := False;
    37. Canvas.Pen.Mode := pmNot;
    38. Canvas.Brush.Style := bsClear;
    39. Canvas.Rectangle(AnchorX, AnchorY, CurX, CurY);
    40. end;
    41. end;
    ... auf einen Bitmap.

    Hier mein angepasster Code für Rechtecke:

    Delphi-Code

    1. procedure TFPhotoCut.ImagePreviewMouseDown(Sender: TObject;
    2. Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    3. begin
    4. // http://swissdelphicenter.ch/de/showcode.php?id=1236
    5. AnchorX := X;
    6. CurX := X;
    7. AnchorY := Y;
    8. CurY := Y;
    9. Mousedown := True
    10. end;
    11. procedure TFPhotoCut.ImagePreviewMouseMove(Sender: TObject; Shift: TShiftState;
    12. X, Y: Integer);
    13. begin
    14. if Mousedown then
    15. with Canvas do
    16. begin
    17. Pen.Mode := pmNot;
    18. Pen.Width := 2;
    19. Pen.Color := clred;
    20. Brush.Style := bsClear;
    21. Rectangle(AnchorX, AnchorY, CurX, CurY);
    22. CurX := X;
    23. CurY := Y;
    24. Rectangle(AnchorX, AnchorY, X, Y)
    25. end
    26. end;
    27. procedure TFPhotoCut.ImagePreviewMouseUp(Sender: TObject; Button: TMouseButton;
    28. Shift: TShiftState; X, Y: Integer);
    29. var
    30. Bmp: TBitmap;
    31. FaktorX, FaktorY: double;
    32. begin
    33. if Mousedown then
    34. begin
    35. Mousedown := False;
    36. Canvas.Pen.Mode := pmNot;
    37. Canvas.Brush.Style := bsClear;
    38. Canvas.Rectangle(AnchorX, AnchorY, CurX, CurY);
    39. if (curX > AnchorX) and (curY > AnchorY) then
    40. begin
    41. //Koordinaten umrechnen auf das dem Fenster in der Größe angepasste Originalbild:
    42. FaktorX := ImagePreview.Picture.Width / ImagePreview.Width;
    43. Faktory := ImagePreview.Picture.Height / ImagePreview.Height;
    44. Bmp := TBitmap.Create;
    45. Bmp.PixelFormat := pf32Bit;
    46. Bmp.Width := Round((CurX - AnchorX) * faktorX);
    47. Bmp.Height := Round((CurY - AnchorY) * FaktorY);
    48. try
    49. BitBlt(BMP.canvas.Handle, 0, 0, Bmp.width, Bmp.height,
    50. ImagePreview.Picture.Bitmap.Canvas.Handle, Round(AnchorX * faktorX), Round(AnchorY *
    51. faktorY), SRCCOPY);
    52. with FCutout do
    53. begin
    54. Width := Round((FCutout.Height - 89) * Bmp.Width / Bmp.Height);
    55. Image1.Picture.Bitmap.Assign(Bmp);
    56. showmodal
    57. end;
    58. finally
    59. Bmp.Free
    60. end
    61. end
    62. else
    63. MyMessageDLG(_('Endpunkt muss rechts unter dem Startpunkt liegen'), mtInformation,
    64. MessTitleInf)
    65. end
    66. end;
    Hallo DeddyH,

    ... Danke. So hatte ich mir das auch gedacht aber dabei wohl schlampig gecoded.

    Hier nun der funktionierende Code für quadratische Rahmen:

    Delphi-Code

    1. procedure TFPhotoCut.ImagePreviewMouseMove(Sender: TObject; Shift: TShiftState;
    2. X, Y: Integer);
    3. begin
    4. if Mousedown then
    5. with Canvas do
    6. begin
    7. Pen.Mode := pmNot;
    8. Pen.Width := 2;
    9. Pen.Color := clred;
    10. Brush.Style := bsClear;
    11. Rectangle(AnchorX, AnchorY, CurX, CurY);
    12. CurX := X;
    13. CurY := AnchorY+X-AnchorX;
    14. Rectangle(AnchorX, AnchorY, X, AnchorY+X-AnchorX)
    15. end
    16. end;