Graphics32禁用RubberbandLayer缩放 实现标记大小不随视图缩放改变

问题根源 #

你设置RBLayer.Scaled := False无效的核心原因是：当你给TRubberbandLayer指定ChildLayer属性时，它会自动同步子图层的位图坐标边界，而你的子图层（TPositionedLayer）设置了Scaled := True，画布缩放时子层的逻辑坐标对应到屏幕的大小会变化，RBLayer跟着同步自然也会缩放。

解决方案 #

手动接管RBLayer的位置更新逻辑，关闭自动子层同步，每次画布缩放时重新计算RBLayer的屏幕坐标，即可实现选择框尺寸固定。

第一步：新增位置更新方法 #

在窗体的私有方法声明里新增UpdateRubberbandPosition方法：

private
  procedure UpdateRubberbandPosition;

方法实现如下：

procedure TForm1.UpdateRubberbandPosition;
var
  LayerBmpRect: TFloatRect;
  CtrlLeft, CtrlTop: Integer;
begin
  if (FSelection = nil) or (RBLayer = nil) then Exit;
  // 取标记层的原始位图坐标
  LayerBmpRect := FSelection.Location;
  // 转换为当前缩放比例下的控件坐标
  CtrlLeft := ImgView.BitmapToClient(GR32.Point(LayerBmpRect.Left, LayerBmpRect.Top)).X;
  CtrlTop := ImgView.BitmapToClient(GR32.Point(LayerBmpRect.Left, LayerBmpRect.Top)).Y;
  // 固定选择框尺寸为40*40像素，可根据需求调整
  RBLayer.Location := FloatRect(CtrlLeft, CtrlTop, CtrlLeft + 40, CtrlTop + 40);
end;

第二步：修改SetSelection逻辑 #

移除自动子层绑定，改为手动更新位置：

procedure TForm1.SetSelection(Value: TPositionedLayer);
begin
  if Value <> Selection then
  begin
    if RBLayer <> nil then
    begin
      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.Scaled := False;
        RBLayer.Handles := [rhCenter, rhFrame];
        // 固定选择框尺寸，和UpdateRubberbandPosition里的尺寸保持一致
        RBLayer.MinHeight := 40;
        RBLayer.MaxHeight := 40;
        RBLayer.MinWidth := 40;
        RBLayer.MaxWidth := 40;
      end
      else RBLayer.BringToFront;
      // 移除原来的RBLayer.ChildLayer := Value代码
      UpdateRubberbandPosition;
      RBLayer.LayerOptions := LOB_VISIBLE or LOB_MOUSE_EVENTS;
    end;
  end;
end;

第三步：缩放时同步更新选择框位置 #

在WheelUp、WheelDown方法末尾调用位置更新方法：

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

procedure TForm1.WheelUp;
var
  s: Single;
begin
  s := ImgView.Scale * 1.01;
  if s > 5 then s := 5;
  ImgView.Scale := s;
  UpdateRubberbandPosition; // 新增这行
end;

如果你的标记支持拖拽移动，拖拽结束后也需要调用UpdateRubberbandPosition同步选择框位置。

内容的提问来源于stack exchange，提问作者Alexandr