delphigraphics32

Graphics32 Simple drawing layer scaling


For a learning purpose, I am trying to build an application, that behaves basically the same way, as a Graphics32 example application "ImgView_Layers" and than I am making slight changes. Now I am stuck on a problem with simple drawing layers. I create one the same way, as in the sample app. Than in the PaintSimpleDrawingHandler, I am trying to draw some other shapes, than the default spiral. And here comes the problem. The "default" spiral, is being scaled with the image - when zoomed out, the spiral is being zoomed out and vice versa. When the layer size is changed, the size of the spiral is changed as well. If I draw anything else, it remains unchanged when zooming, or changing the size of the layer.

Here is an example of a diamond, square and a spiral. The spiral "works" fine, the rest does not.

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;

I tried a few different shapes, different ways to draw them, but still get the same result. Can someone please try to explain the difference between the spiral and the rest, and help me to draw custom shapes, that will be zoomed and scaled the same way as the spiral?

I use Delphi XE7. Here is the complete source:

    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.

Solution

  • If I draw anything else, it remains unchanged when zooming, or changing the size of the layer.

    And that is because you don't change the size of your objects with the zooming or resizing:

      // 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);
    

    The size of the rectangle is defined by the constants -10 and +10 (Cx+W2 and Cy+H2 defines the center point). Try, for example, this instead:

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