0

Good afternoon. Sorry for my English. I am using RAD Studio XE. In Graphics32, I need to completely disable the RubberbandLayer of the eraser. Tried ways to disable gum scaling. I can not. Tried RBLayer.Scaled: = False; It doesn't work for me. I use layers to render small "markers" to the screen. If you compile my code, you can display two kinds of markers - "shield" and "dot". To do this, press the right mouse button and select a marker. By scrolling the mouse wheel, you can change the size of the picture. I don't want to resize the markers but the RubberbandLayer is resized. Unfortunately, I cannot get rid of it. My code:

unit Unit1;

interface

uses
  Windows, Graphics,Controls, Forms, GR32_Image, GR32_Layers, GR32, 
  Menus, Classes, ExtCtrls;

type
  TForm1 = class(TForm)
    ImgView: TImgView32;
    PopupMenu1: TPopupMenu;
    A3: TMenuItem;
    A1: TMenuItem;
    procedure ActivateLayerMenu(X,Y: Integer);
    procedure ImgViewMouseWheelDown(Sender: TObject; Shift: TShiftState;
      MousePos: TPoint; var Handled: Boolean);
    procedure ImgViewMouseWheelUp(Sender: TObject; Shift: TShiftState;
      MousePos: TPoint; var Handled: Boolean);
    procedure ImgViewMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer);
    procedure ImgViewMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer; Layer: TCustomLayer);
    procedure ImgViewMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer);
    procedure NewPuntoOpen(PLoad: Boolean; MarkTxt: String);
    procedure A3Click(Sender: TObject);
    procedure A1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    MouseDragging: Boolean;
    OldScrollPosVert, OldScrollPosHorth,
    MouseX, MouseY: Integer;
    FSelection: TPositionedLayer;
    OldMousePos: TPoint;
    MyMouse: TMouse;
    procedure SetSelection(Value: TPositionedLayer);
    procedure WheelDown;
    procedure WheelUp;
  protected
    RBLayer: TRubberbandLayer;
    function CreatePositionedPunto: TPositionedLayer;
    procedure PaintPunto(Sender: TObject; Buffer: TBitmap32);
    procedure LayerMouseDown(Sender: TObject; Buttons: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure PaintShield(Sender: TObject; Buffer: TBitmap32);
  public
    { Public declarations }
    procedure CreateNewImage(AWidth, AHeight: Integer; FillColor: TColor32);
    property Selection: TPositionedLayer read FSelection write SetSelection;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.NewPuntoOpen(PLoad: Boolean; MarkTxt: String);
var
  L: TPositionedLayer;
begin
  Selection := nil;
  L := CreatePositionedPunto;
  L.OnPaint := PaintPunto;
 // L.MarkerText := MarkTxt;
  if PLoad Then L.Location := FloatRect(OldMousePos.X, OldMousePos.Y, OldMousePos.X  + 40, OldMousePos.Y + 40);
end;

function TForm1.CreatePositionedPunto: TPositionedLayer;
var
  P: TPoint;
  x1, y1: Single;
begin
  // get coordinates of the center of viewport
  with ImgView.GetViewportRect do
     P := ImgView.ControlToBitmap(GR32.Point((OldMousePos.X*2) div 2,
                                             (OldMousePos.Y*2) div 2));
  Result := TPositionedLayer.Create(ImgView.Layers);
  Result.Location := FloatRect(P.X - 20, P.Y - 8, P.X  + 20, P.Y + 32);
  Result.Scaled := True;
  Result.MouseEvents := True;
  Result.OnMouseDown := LayerMouseDown;
end;

procedure TForm1.PaintPunto(Sender: TObject; Buffer: TBitmap32);
var
  Cx, Cy, Cx2, Cy2,
  W2, H2: Single;
  FontCoef: Single;
  Q, S: String;
  P: TPoint;
  n, n5: Integer;
begin
  n := 0;
  n5:= 5;
  FontCoef := 1;
  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;

      Buffer.MoveToF(Cx,Cy);
      Buffer.Font.Name := 'Tahoma';
      Buffer.Font.Style := [fsBold];
      Q := Chr($25CF);
      Buffer.Font.Size := 25+n;
      Buffer.Font.Color := clAqua;
      Buffer.Textout( Round(Cx-12), Round(Cy-30), Q);
      Buffer.Font.Size := 15+n;
      Buffer.Font.Color := clWhite;
      Buffer.Textout( Round(Cx-7), Round(Cy-19), Q);

      Buffer.Font.Color := clBlack;
      Buffer.Font.Size := 10+n;
      Buffer.Textout( Round(Cx-n5), Round(Cy-13), Q);
   end;
end;

procedure TForm1.ActivateLayerMenu(X,Y: Integer);
  begin
   MouseX := MyMouse.CursorPos.X;
   MouseY := MyMouse.CursorPos.Y;
   OldMousePos := Point(X, Y);
   PopupMenu1.Popup(MouseX, MouseY);
end;

procedure TForm1.LayerMouseDown(Sender: TObject; Buttons: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Sender <> nil then
   begin
    Selection := TPositionedLayer(Sender);
    if Sender.ClassType = TPositionedLayer then
    begin
     RBLayer.Handles := [rhCenter, rhFrame];
   end;
end;
end;

procedure TForm1.ImgViewMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer);
var
  MyMouse: TMouse;
begin
    if Layer = nil then Selection := nil;
    if Button = mbLeft then
    begin
      OldMousePos := Point(X, Y);
      MouseDragging := True;
    end;
    if Button = mbRight then ActivateLayerMenu(X,Y);
end;

procedure TForm1.ImgViewMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer; Layer: TCustomLayer);
  var e: String;
  P: TPoint;
  begin
  if Selection <> nil then Exit;
  if MouseDragging then
  begin
   ImgView.Scroll(OldMousePos.X - X, OldMousePos.Y - Y);
   OldMousePos := Point(X, Y);
  end;
end;

procedure TForm1.ImgViewMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer);
begin
  if Button = mbLeft then
  begin
   MouseDragging := False;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
CreateNewImage(500, 300, clWhite);
end;

procedure TForm1.ImgViewMouseWheelDown(Sender: TObject; Shift: TShiftState;
  MousePos: TPoint; var Handled: Boolean);
begin
  WheelDown;
end;

procedure TForm1.WheelDown;
var
  s: Single;
begin
  s := ImgView.Scale / 1.01;
  if s < 0.2 then s := 0.2;
  ImgView.Scale := s;
end;

procedure TForm1.ImgViewMouseWheelUp(Sender: TObject; Shift: TShiftState;
  MousePos: TPoint; var Handled: Boolean);
begin
  WheelUp;
end;

procedure TForm1.WheelUp;
var
  s: Single;
begin
  s := ImgView.Scale * 1.01;
  if s > 5 then s := 5;
  ImgView.Scale := s;
end;

procedure TForm1.A1Click(Sender: TObject);
var
  L: TPositionedLayer;
begin
  Selection := nil;
  L := CreatePositionedPunto;
  L.OnPaint := PaintShield;
end;

procedure TForm1.PaintShield(Sender: TObject; Buffer: TBitmap32);
var
  Cx, Cy, W2, H2: Single;
  G: char;
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;
      Buffer.MoveToF(Cx,Cy);
      Buffer.Font.Name := 'Webdings';
      Buffer.Font.Style := Buffer.Font.Style-[fsBold];
      G := 'd';
      Buffer.Font.Size := 26;
      Buffer.Font.Color := clBlack;
      Buffer.Textout( Round(Cx-22), Round(Cy-24), G);
      Buffer.Font.Size := 20;
      Buffer.Font.Color := clAqua;
      Buffer.Textout( Round(Cx-17), Round(Cy-18), G);
    end;
end;

procedure TForm1.A3Click(Sender: TObject);
begin
  NewPuntoOpen(False, '');
 // showmessage(FloatToStr( ImgView.Scale ));
end;

procedure TForm1.CreateNewImage(AWidth, AHeight: Integer; FillColor: TColor32);
begin
  with ImgView do
  begin
    Selection := nil;
    RBLayer := nil;
    Layers.Clear;
    Scale := 1;
    Bitmap.SetSize(AWidth, AHeight);
    Bitmap.Clear(FillColor);
  end;
end;

procedure TForm1.SetSelection(Value: TPositionedLayer);
begin
  if Value <> Selection then
  begin
    if RBLayer <> nil then
    begin
      RBLayer.ChildLayer := nil;
      RBLayer.LayerOptions := LOB_NO_UPDATE;
      ImgView.Invalidate;
    end;
    FSelection := Value;
    if Value <> nil then
    begin
      if RBLayer = nil then
      begin
        RBLayer := TRubberBandLayer.Create(ImgView.Layers);
        RBLayer.MinHeight := 10;
        RBLayer.MinWidth := 10;
        RBLayer.MaxHeight := 12;
        RBLayer.MaxWidth := 12;
        RBLayer.Scaled := False;
      end
      else RBLayer.BringToFront;
      RBLayer.ChildLayer := Value;
      RBLayer.LayerOptions := LOB_VISIBLE or LOB_MOUSE_EVENTS or LOB_NO_UPDATE;
    end;
  end;
end;

end.
Alexandr
  • 1
  • 1
  • I tried to replicate the problem with your code, but wasn't successful. E.g. `TPositionedLayer` doesn't have a property `MarkerText` and `ResizePunto` is not declared. Please provide a [mre], with emphasis on *minimal* but still *complete* , so I can better understand your actual problem and provide an answer. – Tom Brunberg Nov 29 '21 at 09:53
  • Thank you for your attention to my problem. I tried to simplify the code as much as possible and clean it from unnecessary experiments. MarkerText and ResizePunto do not affect the process. You can delete them and links to them. As a result, the code looks like this: – Alexandr Nov 29 '21 at 11:00
  • Никакого русского, пожалуйста. When you edit your question DO NOT use the space for answers. There is an "Edit" button beneath the tags of your question. – Tom Brunberg Nov 29 '21 at 12:26
  • I removed MarkerText, ResizePunto and the code with them. – Alexandr Nov 29 '21 at 18:55
  • I have your code running. But just to clarify, is the problem, a) that the markers change size (since you say *I don't want to resize the markers*, in my test they don't resize), or b) is it that the distance between the markers change with changes of the scale? I assume the latter? I will return to the matter after noon (EU time) tomorrow. – Tom Brunberg Nov 29 '21 at 21:35
  • Changes the size of the frame (RBLayer). It is visible when you click on the marker with the mouse. You need to fix the size of the frame (RBLayer). – Alexandr Nov 30 '21 at 09:03
  • and put things in order in the "uses". – Alexandr Nov 30 '21 at 10:00
  • The reason for the `RBLayer` to resize when zooming in or out is in `function CreatePositionedPunto: TPositionedLayer` where you set `Result.Scaled := True;`. If you change that to `False` then the `RBLayer` will not resize. However, then you must manually reposition all marker positions. – Tom Brunberg Nov 30 '21 at 12:39
  • I know about it. Probably the solution is in the source code of Graphics32. I don't see any other solution. – Alexandr Nov 30 '21 at 18:02

0 Answers0