Graphics32 Простое масштабирование слоя чертежа

В целях обучения я пытаюсь создать приложение, которое ведет себя в основном так же, как пример приложения Graphics32 «ImgView_Layers», и затем я вношу небольшие изменения. Теперь я застрял на проблеме с простыми слоями рисования. Я создаю его так же, как в примере приложения. Чем в PaintSimpleDrawingHandler, я пытаюсь нарисовать какие-то другие фигуры, чем спираль по умолчанию. И тут возникает проблема. Спираль "по умолчанию" масштабируется вместе с изображением - при уменьшении масштаба спираль уменьшается, и наоборот. При изменении размера слоя изменяется и размер спирали. Если я рисую что-то еще, оно остается неизменным при масштабировании или изменении размера слоя.

Вот пример ромба, квадрата и спирали. Спираль "работает" нормально, остальное нет.

procedure TfrmMain.PaintSimpleDrawingHandler(Sender: TObject; Buffer: TBitmap32);
var
  Cx, Cy: Single;
  W2, H2: Single;
  I: Integer;
  yy, xx, yyy, xxx: integer;
const
  CScale = 1 / 200;
begin
  if Sender is TPositionedLayer then
    with TPositionedLayer(Sender).GetAdjustedLocation do
    begin
      W2 := (Right - Left) * 0.5;
      H2 := (Bottom - Top) * 0.5;
      Cx:= Left + W2;
      Cy:= Top + H2;
      W2 := W2 * CScale;
      H2 := H2 * CScale;
      Buffer.PenColor := clGreen32;

    // square
      xx := Round(Cx + W2 - 10);
      yy := Round(Cy + H2 - 10);
      xxx := Round(Cx + W2 + 10);
      yyy := Round(Cy + H2 + 10);

      Buffer.FrameRectS(xx, yy, xxx, yyy, clRoyalBlue32);
    ///square

    // diamond
      Buffer.MoveToF(Cx - 10, Cy);
      Buffer.LineToFS(Cx + W2, Cy + H2 - 10);
      Buffer.MoveToF(Cx, Cy - 10);
      Buffer.LineToFS(Cx + W2 + 10, Cy + H2);
      Buffer.MoveToF(Cx + 10, Cy);
      Buffer.LineToFS(Cx + W2, Cy + H2 + 10);
      Buffer.MoveToF(Cx, Cy + 10);
      Buffer.LineToFS(Cx + W2 - 10, Cy + H2);
    ///diamond

    // spiral
      Buffer.MoveToF(Cx, Cy);
      for I := 0 to 240 do
        Buffer.LineToFS(
          Cx + W2 * I * Cos(I * 0.125),
          Cy + H2 * I * Sin(I * 0.125));

    end;

end;

Я пробовал несколько разных фигур, разные способы их рисования, но все равно получаю тот же результат. Может кто-нибудь, пожалуйста, попытаться объяснить разницу между спиралью и остальными и помочь мне нарисовать нестандартные фигуры, которые будут увеличиваться и масштабироваться так же, как спираль?

Я использую Делфи XE7. Вот полный источник:

    unit Test;

interface
{$I GR32.inc}

uses
  Windows,
  Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.Menus, GR32_Image, Vcl.ExtCtrls,
  AdvToolBar, AdvShapeButton, AdvAppStyler, AdvToolBarStylers, AdvPreviewMenu,
  AdvPreviewMenuStylers, AdvPanel, DataModule, AdvGlassButton, Vcl.StdCtrls,
  AeroButtons, AdvGlowButton, GR32, GR32_Layers, GR32_RangeBars,
  GR32_Filters, GR32_Transforms, GR32_Resamplers, AdvTrackBar;

type
  TfrmMain = class(TForm)
    pnlMain: TPanel;
    AdvToolBarPager1: TAdvToolBarPager;
    AdvToolBarPager11: TAdvPage;
    AdvToolBarPager12: TAdvPage;
    AdvToolBarPager13: TAdvPage;
    pnlMainRight: TAdvPanel;
    pnlMainLeft: TAdvPanel;
    pnlMainCenter: TAdvPanel;
    AdvShapeButton1: TAdvShapeButton;
    pnlMainBottom: TAdvPanel;
    iwMain: TImgView32;
    btManImgPick: TAdvGlowButton;
    tbZoom: TAdvTrackBar;
    btZoom: TAdvGlowButton;
    btAddMark: TAdvGlowButton;
    procedure FormCreate(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure btManImgPickClick(Sender: TObject);
    procedure OpenImage(const FileName: string);
    procedure iwMainMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer);
    procedure iwMainMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer);
    procedure iwMainMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer);
    procedure iwMainResize(Sender: TObject);
    procedure tbZoomChange(Sender: TObject);
    procedure btZoomClick(Sender: TObject);
    procedure iwMainMouseWheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
    procedure iwMainMouseWheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
    procedure btAddMarkClick(Sender: TObject);
  private
    FSelection: TPositionedLayer;
    FDragging: Boolean;
    FFrom: TPoint;
    procedure SetSelection(Value: TPositionedLayer);
  public
    property Selection: TPositionedLayer read FSelection write SetSelection;
  protected
    RBLayer: TRubberbandLayer;
    procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
    procedure RBResizing(Sender: TObject; const OldLocation: TFloatRect;
      var NewLocation: TFloatRect; DragState: TRBDragState; Shift: TShiftState);
    procedure LayerDblClick(Sender: TObject);
    procedure iwAutofit;
    function CreatePositionedLayer: TPositionedLayer;
    procedure LayerMouseDown(Sender: TObject; Buttons: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure PaintSimpleDrawingHandler(Sender: TObject; Buffer: TBitmap32);
    procedure drawMark();
  end;

var
  frmTest: TfrmMain;
  DataModule: TDataModule;
implementation

{$R *.dfm}

uses
  JPEG,
  NewImageUnit, RGBALoaderUnit, Math, Printers, GR32_LowLevel, GR32_Paths,
  GR32_VectorUtils, GR32_Backends, GR32_Text_VCL, GR32_ColorGradients,
  GR32_Polygons, GR32_Geometry;

procedure TfrmMain.OpenImage(const FileName: string);
begin
  with iwMain do
  try
    Selection := nil;
    RBLayer := nil;
    Layers.Clear;
    Scale := 1;
    Bitmap.LoadFromFile(FileName);
  finally
    //pnlImage.Visible := not Bitmap.Empty;
  end;
end;

procedure TfrmMain.PaintSimpleDrawingHandler(Sender: TObject;
  Buffer: TBitmap32);
var
  Cx, Cy: Single;
  W2, H2: Single;
  I: Integer;
  yy, xx, yyy, xxx: integer;
const
  CScale = 1 / 200;
begin
  if Sender is TPositionedLayer then
    with TPositionedLayer(Sender).GetAdjustedLocation do
    begin
      W2 := (Right - Left) * 0.5;
      H2 := (Bottom - Top) * 0.5;
      Cx:= Left + W2;
      Cy:= Top + H2;
      W2 := W2 * CScale;
      H2 := H2 * CScale;
      Buffer.PenColor := clGreen32;

      xx := Round(Cx + W2 - 10);
      yy := Round(Cy + H2 - 10);
      xxx := Round(Cx + W2 + 10);
      yyy := Round(Cy + H2 + 10);

      Buffer.FrameRectS(xx, yy, xxx, yyy, clRoyalBlue32);

      Buffer.MoveToF(Cx - 10, Cy);
      Buffer.LineToFS(Cx + W2, Cy + H2 - 10);
      Buffer.MoveToF(Cx, Cy - 10);
      Buffer.LineToFS(Cx + W2 + 10, Cy + H2);
      Buffer.MoveToF(Cx + 10, Cy);
      Buffer.LineToFS(Cx + W2, Cy + H2 + 10);
      Buffer.MoveToF(Cx, Cy + 10);
      Buffer.LineToFS(Cx + W2 - 10, Cy + H2);


      Buffer.MoveToF(Cx, Cy);
      for I := 0 to 240 do
        Buffer.LineToFS(
          Cx + W2 * I * Cos(I * 0.125),
          Cy + H2 * I * Sin(I * 0.125));

    end;
end;

procedure TfrmMain.RBResizing(Sender: TObject;
  const OldLocation: TFloatRect; var NewLocation: TFloatRect;
  DragState: TRBDragState; Shift: TShiftState);
var
  w, h, cx, cy: Single;
  nw, nh: Single;

begin
  if DragState = dsMove then Exit; // we are interested only in scale operations
  if Shift = [] then Exit; // special processing is not required

  if ssCtrl in Shift then
  begin
    { make changes symmetrical }

    with OldLocation do
    begin
      cx := (Left + Right) / 2;
      cy := (Top + Bottom) / 2;
      w := Right - Left;
      h := Bottom - Top;
    end;

    with NewLocation do
    begin
      nw := w / 2;
      nh := h / 2;
      case DragState of
        dsSizeL: nw := cx - Left;
        dsSizeT: nh := cy - Top;
        dsSizeR: nw := Right - cx;
        dsSizeB: nh := Bottom - cy;
        dsSizeTL: begin nw := cx - Left; nh := cy - Top; end;
        dsSizeTR: begin nw := Right - cx; nh := cy - Top; end;
        dsSizeBL: begin nw := cx - Left; nh := Bottom - cy; end;
        dsSizeBR: begin nw := Right - cx; nh := Bottom - cy; end;
      end;
      if nw < 2 then nw := 2;
      if nh < 2 then nh := 2;

      Left := cx - nw;
      Right := cx + nw;
      Top := cy - nh;
      Bottom := cy + nh;
    end;
  end;
end;

procedure TfrmMain.SetSelection(Value: TPositionedLayer);
begin
  if Value <> FSelection then
  begin
    if RBLayer <> nil then
    begin
      RBLayer.ChildLayer := nil;
      RBLayer.LayerOptions := LOB_NO_UPDATE;
      //pnlBitmapLayer.Visible := False;
      //pnlButtonMockup.Visible := False;
      //pnlMagnification.Visible := False;
      iwMain.Invalidate;
    end;

    FSelection := Value;

    if Value <> nil then
    begin
      if RBLayer = nil then
      begin
        RBLayer := TRubberBandLayer.Create(iwMain.Layers);
        RBLayer.MinHeight := 1;
        RBLayer.MinWidth := 1;
      end
      else
        RBLayer.BringToFront;
      RBLayer.ChildLayer := Value;
      RBLayer.LayerOptions := LOB_VISIBLE or LOB_MOUSE_EVENTS or LOB_NO_UPDATE;
      RBLayer.OnResizing := RBResizing;
      RBLayer.OnDblClick := LayerDblClick;

      if Value is TBitmapLayer then
        with TBitmapLayer(Value) do
        begin
          //pnlBitmapLayer.Visible := True;
          //GbrLayerOpacity.Position := Bitmap.MasterAlpha;
          //CbxLayerInterpolate.Checked := Bitmap.Resampler.ClassType = TDraftResampler;
        end
      else if Value.Tag = 2 then
      begin
        // tag = 2 for button mockup
        //pnlButtonMockup.Visible := True;
      end
      else if Value.Tag = 3 then
      begin
        // tag = 3 for magnifiers
        //pnlMagnification.Visible := True;
      end;
    end;
  end;
end;

procedure TfrmMain.tbZoomChange(Sender: TObject);
begin
  iwMain.Scale:= tbZoom.Position / 10;
  btZoom.Caption:= FloatToStr(tbZoom.Position / 10 * 100) + '%';
end;

procedure TfrmMain.btAddMarkClick(Sender: TObject);
begin
  drawMark();
end;

procedure TfrmMain.btManImgPickClick(Sender: TObject);
var jpg : TJPEGImage;
    //bcImage : TBacmedImage;
    //Center : Coordinant;
begin
  with DataModule1.OpenPictureDialog do
    if Execute then
    begin
      jpg:=TJPEGImage.Create;
      jpg.LoadFromFile(FileName);
      //Center.x:=round(jpg.Width/2);
      //Center.y:=round(jpg.Height/2);
      //bcImage:=TBacmedImage.Create(jpg,100,'AAA',1,Center,jpg.Width,23.83);
      OpenImage(FileName);
    end;
    iwAutofit();
end;

procedure TfrmMain.btZoomClick(Sender: TObject);
begin
  iwAutofit();
end;

function TfrmMain.CreatePositionedLayer: TPositionedLayer;
var
  P: TPoint;
begin
  // get coordinates of the center of viewport
  with iwMain.GetViewportRect do
    P := iwMain.ControlToBitmap(GR32.Point((Right + Left) div 2, (Top + Bottom) div 2));

  Result := TPositionedLayer.Create(iwMain.Layers);
  Result.Location := FloatRect(P.X - 32, P.Y - 32, P.X + 32, P.Y + 32);
  Result.Scaled := True;
  Result.MouseEvents := True;
  Result.OnMouseDown := LayerMouseDown;
  Result.OnDblClick := LayerDblClick;
end;

procedure TfrmMain.drawMark;
var
  L: TPositionedLayer;
begin
  L := CreatePositionedLayer;
  L.OnPaint := PaintSimpleDrawingHandler;
  L.Tag := 1;
  Selection := L;
end;

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  DataModule:= TDataModule.Create(self);
end;

procedure TfrmMain.FormResize(Sender: TObject);
begin
  //pnlMainRight.Width:= round(frmTest.Width / 5);
end;

procedure TfrmMain.iwAutofit;
begin
  if iwMain.Bitmap.Height > 0 then //jednoducha cesta jak checknout neprirazeny obrazek. Pokud je neprirazeny, nezoomovat.
  begin
    tbZoom.Position:= Round(iwMain.Height / iwMain.Bitmap.Height * 10);
    btZoom.Caption:= IntToStr(Round(iwMain.Height / iwMain.Bitmap.Height * 100)) + '%';
    iwMain.Scale:= iwMain.Height / iwMain.Bitmap.Height;
  end;
end;

procedure TfrmMain.iwMainMouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer);
begin
  if Button = mbMiddle then
  begin
    FDragging := True;
    iwMain.Cursor:= crDrag;
    FFrom := Point(X, Y);
  end;
end;

procedure TfrmMain.iwMainMouseMove(Sender: TObject; Shift: TShiftState;
  X, Y: Integer; Layer: TCustomLayer);
begin
  if FDragging then
  begin
    iwMain.Scroll(FFrom.X - X, FFrom.Y - Y);
    FFrom.X:= X;
    FFrom.Y:= Y;
  end;

end;

procedure TfrmMain.iwMainMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer);
begin
  if Button = mbMiddle then
  begin
    FDragging := False;
    iwMain.Cursor:= crDefault;
    iwMain.SetFocus;
  end;
end;

procedure TfrmMain.iwMainMouseWheelDown(Sender: TObject;
  Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
begin
  tbZoom.Position:= tbZoom.Position - 1;
end;

procedure TfrmMain.iwMainMouseWheelUp(Sender: TObject;
  Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
begin
  tbZoom.Position:= tbZoom.Position + 1;
end;

procedure TfrmMain.iwMainResize(Sender: TObject);
begin
  iwAutofit();
end;

procedure TfrmMain.LayerDblClick(Sender: TObject);
begin
  if Sender is TRubberbandLayer then
    TRubberbandLayer(Sender).Quantize;
end;

procedure TfrmMain.LayerMouseDown(Sender: TObject;
  Buttons: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if Sender <> nil then Selection := TPositionedLayer(Sender);
end;

procedure TfrmMain.WMNCHitTest(var Message: TWMNCHitTest);
const
  EDGEDETECT = 7; // adjust
var
  deltaRect: TRect;
begin
  inherited;
  if BorderStyle = TFormBorderStyle(0) then
    with Message, deltaRect do
    begin
      Left := XPos - BoundsRect.Left;
      Right := BoundsRect.Right - XPos;
      Top := YPos - BoundsRect.Top;
      Bottom := BoundsRect.Bottom - YPos;
      if (Top < EDGEDETECT) and (Left < EDGEDETECT) then
        Result := HTTOPLEFT
      else if (Top < EDGEDETECT) and (Right < EDGEDETECT) then
        Result := HTTOPRIGHT
      else if (Bottom < EDGEDETECT) and (Left < EDGEDETECT) then
        Result := HTBOTTOMLEFT
      else if (Bottom < EDGEDETECT) and (Right < EDGEDETECT) then
        Result := HTBOTTOMRIGHT
      else if (Top < EDGEDETECT) then
        Result := HTTOP
      else if (Left < EDGEDETECT) then
        Result := HTLEFT
      else if (Bottom < EDGEDETECT) then
        Result := HTBOTTOM
      else if (Right < EDGEDETECT) then
        Result := HTRIGHT
    end;
end;

end.

person j.kaspar    schedule 13.11.2017    source источник
comment
Не могли бы вы добавить полный исходный код и сообщить мне, какая у вас версия Delphi?   -  person Aqil    schedule 14.11.2017
comment
@Aqil Я использую XE7. Я добавил полный исходный код к вопросу. Спасибо   -  person j.kaspar    schedule 14.11.2017


Ответы (1)


Если я рисую что-то еще, оно остается неизменным при масштабировании или изменении размера слоя.

И это потому, что вы не меняете размер своих объектов при масштабировании или изменении размера:

  // square
  xx := Round(Cx + W2 - 10);
  yy := Round(Cy + H2 - 10);
  xxx := Round(Cx + W2 + 10);
  yyy := Round(Cy + H2 + 10);

  Buffer.FrameRectS(xx, yy, xxx, yyy, clRoyalBlue32);

Размер прямоугольника определяется константами -10 и +10 (Cx+W2 и Cy+H2 определяют центральную точку). Попробуйте, например, это вместо этого:

  xx  := Round(Cx + W2 *(- 2));
  yy  := Round(Cy + H2 *(- 2));
  xxx := Round(Cx + W2 *(+ 2));
  yyy := Round(Cy + H2 *(+ 2));
person Tom Brunberg    schedule 14.11.2017
comment
Спасибо! Так просто... :) Я ожидал сложной проблемы и проглядел очевидную вещь... - person j.kaspar; 14.11.2017