如何在 Delphi 中检测 TImage 区域的色调

Question

我正在向用户提交的图像添加叠加层，这意味着图像可能色调较暗或色调较浅。是否有某种机制可以让我确定 Timage 的特定区域是浅色调还是深色调？这将允许我显示我的叠加层的白色或黑色版本，具体取决于。我在 MacOS 上使用 Delphi 10.4，所以我正在使用 FMX。叠加层是一小段文字和一张图片（黑色或白色）。

这将覆盖在我的样式书定义中为 TListboxItem 找到的 TImage。

Answer 1

此函数将返回给定位图和区域的平均亮度。它使用快速加权平均值。它没有考虑图像的 alpha 通道。

function LumBitmapRegion(const ABitmap : TBitmap ; ARegion : TRect) : Byte;
Var
  Lx, Ly : Integer;
  LSum : Cardinal;
  bdata : TBitmapData;
  LRow : PAlphaColorArray;
  pt : PByte;
  LLum : Word;
begin
  LSum := 0;
  ABitmap.Map(TMapAccess.Read, bdata);
  ARegion.Intersect(Rect(0, 0, ABitmap.Width, ABitmap.Height));
try
  for Ly := ARegion.Top to ARegion.Bottom - 1 do begin
    LRow := bdata.GetScanline(Ly);
    pt := @TAlphaColorRec(LRow[ARegion.Left]).B;
    for Lx := ARegion.Left to ARegion.Right - 1 do begin
      // Y = (R+R+R+B+G+G+G+G)>>3
      LLum := pt^; Inc(pt);
      Inc(LLum, pt^ shl 2); Inc(pt);
      Inc(LLum, pt^ * 3); Inc(pt, 2);
      LLum := LLum shr 3;
      Inc(LSum, LLum);
    end;
  end;

  Result := LSum div Cardinal(ARegion.Width * ARegion.Height);
finally
  ABitmap.Unmap(bdata);
end;
end;

这是一个演示应用程序。通过单击按钮加载图像，然后单击图像以使矩形在该点居中。标签将显示 0 到 255 之间的亮度。

表格：

object Form1: TForm1
  Left = 0
  Top = 0
  Caption = 'Form1'
  ClientHeight = 480
  ClientWidth = 640
  FormFactor.Width = 320
  FormFactor.Height = 480
  FormFactor.Devices = [Desktop]
  DesignerMasterStyle = 0
  object Image1: TImage
    MultiResBitmap = <
      item
      end>
    Position.X = 8.000000000000000000
    Position.Y = 8.000000000000000000
    Size.Width = 441.000000000000000000
    Size.Height = 409.000000000000000000
    Size.PlatformDefault = False
    OnMouseDown = Image1MouseDown
  end
  object Button1: TButton
    Position.X = 512.000000000000000000
    Position.Y = 32.000000000000000000
    Text = 'Load Image'
    OnClick = Button1Click
  end
  object Rectangle2: TRectangle
    Fill.Kind = None
    Position.X = 240.000000000000000000
    Position.Y = 216.000000000000000000
    Size.Width = 50.000000000000000000
    Size.Height = 50.000000000000000000
    Size.PlatformDefault = False
  end
  object Label1: TLabel
    Position.X = 504.000000000000000000
    Position.Y = 168.000000000000000000
    Text = 'Label1'
  end
  object OpenDialog1: TOpenDialog
    Left = 496
    Top = 72
  end
end

单位：

unit Unit1;

interface

uses
  System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
  FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs,
  FMX.Controls.Presentation, FMX.StdCtrls, FMX.Objects;

type
  TForm1 = class(TForm)
    Image1: TImage;
    OpenDialog1: TOpenDialog;
    Button1: TButton;
    Rectangle2: TRectangle;
    Label1: TLabel;
    procedure Button1Click(Sender: TObject);
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Single);
  private
    { Private declarations }
    procedure UpdateLum;
  public
    { Public declarations }
  end;

  function LumBitmapRegion(const ABitmap : TBitmap ; ARegion : TRect) : Byte;

var
  Form1: TForm1;

implementation

uses
  FMX.Utils;

{$R *.fmx}

procedure TForm1.Button1Click(Sender: TObject);
begin
  if not OpenDialog1.Execute then Exit;

  Image1.Bitmap.LoadFromFile(OpenDialog1.FileName);
  Image1.Width := Image1.Bitmap.Width;
  Image1.Height := Image1.Bitmap.Height;

  UpdateLum;
end;

procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Single);
begin
  Rectangle2.Position.Point := PointF(X, Y) +
                               Image1.Position.Point.Round -
                               PointF(Rectangle2.Width, Rectangle2.Height)/2;
  UpdateLum;
end;

procedure TForm1.UpdateLum;
var
  LRect : TRect;
  LLum : Byte;
begin
  LRect := Rectangle2.AbsoluteRect.Round;
  LRect.Offset(TPoint.Zero - Image1.Position.Point.Round);
  LLum := LumBitmapRegion(Image1.Bitmap, LRect);
  Label1.Text := IntToStr(LLum);
  if LLum < 128 then Rectangle2.Stroke.Color := $FFFFFFFF
                else Rectangle2.Stroke.Color := $FF000000;

end;

function LumBitmapRegion(const ABitmap : TBitmap ; ARegion : TRect) : Byte;
Var
  Lx, Ly : Integer;
  LSum : Cardinal;
  bdata : TBitmapData;
  LRow : PAlphaColorArray;
  pt : PByte;
  LLum : Word;
begin
  LSum := 0;
  ABitmap.Map(TMapAccess.Read, bdata);
  ARegion.Intersect(Rect(0, 0, ABitmap.Width, ABitmap.Height));
try
  for Ly := ARegion.Top to ARegion.Bottom - 1 do begin
    LRow := bdata.GetScanline(Ly);
    pt := @TAlphaColorRec(LRow[ARegion.Left]).B;
    for Lx := ARegion.Left to ARegion.Right - 1 do begin
      // Y = (R+R+R+B+G+G+G+G)>>3
      LLum := pt^; Inc(pt);
      Inc(LLum, pt^ shl 2); Inc(pt);
      Inc(LLum, pt^ * 3); Inc(pt, 2);
      LLum := LLum shr 3;
      Inc(LSum, LLum);
    end;
  end;

  Result := LSum div Cardinal(ARegion.Width * ARegion.Height);
finally
  ABitmap.Unmap(bdata);
end;
end;

end.