Fatal编程技术网
  • delphi/
  • Delphi 画布绘制-如何改进此Alpha绘制例程？

Delphi 画布绘制-如何改进此Alpha绘制例程？

delphi

Delphi 画布绘制-如何改进此Alpha绘制例程？,delphi,delphi-xe,Delphi,Delphi Xe,我正在使用不透明（Alpha透明）功能在画布上绘图，如下所示： var Form1: TForm1; IsDrawing: Boolean; implementation {$R *.dfm} procedure DrawOpacityBrush(ACanvas: TCanvas; X, Y: Integer; AColor: TColor; ASize: Integer; Opacity: Byte); var Bmp: TBitmap; I, J: Integer;

我正在使用不透明（Alpha透明）功能在画布上绘图，如下所示：

var
  Form1: TForm1;

  IsDrawing: Boolean;

implementation

{$R *.dfm}

procedure DrawOpacityBrush(ACanvas: TCanvas; X, Y: Integer; AColor: TColor; ASize: Integer; Opacity: Byte);
var
  Bmp: TBitmap;
  I, J: Integer;
  Pixels: PRGBQuad;
  ColorRgb: Integer;
  ColorR, ColorG, ColorB: Byte;
begin
  Bmp := TBitmap.Create;
  try
    Bmp.PixelFormat := pf32Bit; // needed for an alpha channel
    Bmp.SetSize(ASize, ASize);

    with Bmp.Canvas do
    begin
      Brush.Color := clFuchsia; // background color to mask out
      ColorRgb := ColorToRGB(Brush.Color);
      FillRect(Rect(0, 0, ASize, ASize));
      Pen.Color := AColor;
      Pen.Style := psSolid;
      Pen.Width := ASize;
      MoveTo(ASize div 2, ASize div 2);
      LineTo(ASize div 2, ASize div 2);
    end;

    ColorR := GetRValue(ColorRgb);
    ColorG := GetGValue(ColorRgb);
    ColorB := GetBValue(ColorRgb);

    for I := 0 to Bmp.Height-1 do
    begin
      Pixels := PRGBQuad(Bmp.ScanLine[I]);
      for J := 0 to Bmp.Width-1 do
      begin
        with Pixels^ do
        begin
          if (rgbRed = ColorR) and (rgbGreen = ColorG) and (rgbBlue = ColorB) then
            rgbReserved := 0
          else
            rgbReserved := Opacity;
          // must pre-multiply the pixel with its alpha channel before drawing
          rgbRed := (rgbRed * rgbReserved) div $FF;
          rgbGreen := (rgbGreen * rgbReserved) div $FF;
          rgbBlue := (rgbBlue * rgbReserved) div $FF;
        end;
        Inc(Pixels);
      end;
    end;

    ACanvas.Draw(X, Y, Bmp, 255);
  finally
    Bmp.Free;
  end;
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  case Button of
    mbLeft:
    begin
      IsDrawing := True;
      DrawOpacityBrush(Form1.Canvas, X, Y, clRed, 50, 85);
    end;
  end;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if (GetAsyncKeyState(VK_LBUTTON) <> 0) and
     (IsDrawing) then
  begin
    DrawOpacityBrush(Form1.Canvas, X, Y, clRed, 50, 85);
  end;
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  IsDrawing := False;
end;

var
表1:TForm1；
IsDrawing：布尔型；
实施
{$R*.dfm}
过程DrawOpacityBrush（ACanvas:TCanvas；X，Y:Integer；AColor:TColor；ASize:Integer；Opacity:Byte）；
变量
Bmp:TBitmap；
一、 J：整数；
像素：PRGBQuad；
ColorRgb：整数；
ColorR、ColorG、ColorB：字节；
开始
Bmp:=TBitmap.Create；
尝试
Bmp.PixelFormat:=pf32位；//需要一个alpha通道
Bmp.SetSize（ASize，ASize）；
用Bmp.Canvas怎么办
开始
画笔颜色：=clFuchsia；//要遮罩的背景色
ColorRgb:=ColorToRGB（画笔颜色）；
FillRect（Rect（0，0，ASize，ASize））；
钢笔颜色：=一种颜色；
Pen.Style:=psSolid；
笔宽：=ASize；
MoveTo（亚细亚2区，亚细亚2区）；
LineTo（亚洲区2区、亚洲区2区）；
结束；
ColorR:=GetRValue（ColorRgb）；
ColorG:=GetGValue（ColorRgb）；
ColorB:=GetBValue（ColorRgb）；
对于I:=0到Bmp.Height-1 do
开始
像素：=PRGBQuad（Bmp.ScanLine[I]）；
对于J:=0到Bmp.Width-1 do
开始
用像素^do
开始
如果（rgbGreen=ColorR）和（rgbGreen=ColorG）以及（rgbBlue=ColorB），则
rgbReserved:=0
其他的
rgb:=不透明度；
//在绘制之前，必须将像素与其alpha通道预先相乘
rgbreed:=（rgbreed*rgbresered）div$FF；
rgbGreen:=（rgbGreen*rgbReserved）div$FF；
rgbBlue:=（rgbBlue*rgbReserved）div$FF；
结束；
Inc（像素）；
结束；
结束；
绘制（X，Y，Bmp，255）；
最后
Bmp.Free；
结束；
结束；
步骤t用于m1.FormMouseDown（发送方：ToObject；按钮：TMouseButton；
移位：t移位状态；X，Y：整数）；
开始
箱子按钮
布利夫特：
开始
IsDrawing:=真；
DrawOpacityBrush（Form1.Canvas，X，Y，clRed，50，85）；
结束；
结束；
结束；
过程TForm1.FormMouseMove（发送方：ToObject；Shift:TShiftState；X，
Y：整数）；
开始
if（GetAsyncKeyState（VK_LBUTTON）0）和
（画外音）那么
开始
DrawOpacityBrush（Form1.Canvas，X，Y，clRed，50，85）；
结束；
结束；
程序TForm1.FormMouseUp（发送方：TObject；按钮：TMouseButton；
移位：t移位状态；X，Y：整数）；
开始
IsDrawing:=假；
结束；
draw
DrawOpacityBrush（）
过程是Remy Lebeau对我最近提出的一个问题的更新：

虽然这是可行的，但结果并不能满足我现在的需要

目前，每次在MouseMove中调用
DrawOpacityBrush（）
过程时，它都会继续绘制笔刷椭圆形状。这是不好的，因为根据您在画布上移动鼠标的速度，输出结果与预期不符

这些示例图像应该能够更好地说明这一点：

-我将鼠标从画布底部快速移动到顶部的第一个红色笔刷。
-第二个红色笔刷我移动得慢了很多

正如您所看到的，不透明度是正确绘制的，但圆也会重复绘制

我希望它做的是：

var
  Form1: TForm1;

  IsDrawing: Boolean;

implementation

{$R *.dfm}

procedure DrawOpacityBrush(ACanvas: TCanvas; X, Y: Integer; AColor: TColor; ASize: Integer; Opacity: Byte);
var
  Bmp: TBitmap;
  I, J: Integer;
  Pixels: PRGBQuad;
  ColorRgb: Integer;
  ColorR, ColorG, ColorB: Byte;
begin
  Bmp := TBitmap.Create;
  try
    Bmp.PixelFormat := pf32Bit; // needed for an alpha channel
    Bmp.SetSize(ASize, ASize);

    with Bmp.Canvas do
    begin
      Brush.Color := clFuchsia; // background color to mask out
      ColorRgb := ColorToRGB(Brush.Color);
      FillRect(Rect(0, 0, ASize, ASize));
      Pen.Color := AColor;
      Pen.Style := psSolid;
      Pen.Width := ASize;
      MoveTo(ASize div 2, ASize div 2);
      LineTo(ASize div 2, ASize div 2);
    end;

    ColorR := GetRValue(ColorRgb);
    ColorG := GetGValue(ColorRgb);
    ColorB := GetBValue(ColorRgb);

    for I := 0 to Bmp.Height-1 do
    begin
      Pixels := PRGBQuad(Bmp.ScanLine[I]);
      for J := 0 to Bmp.Width-1 do
      begin
        with Pixels^ do
        begin
          if (rgbRed = ColorR) and (rgbGreen = ColorG) and (rgbBlue = ColorB) then
            rgbReserved := 0
          else
            rgbReserved := Opacity;
          // must pre-multiply the pixel with its alpha channel before drawing
          rgbRed := (rgbRed * rgbReserved) div $FF;
          rgbGreen := (rgbGreen * rgbReserved) div $FF;
          rgbBlue := (rgbBlue * rgbReserved) div $FF;
        end;
        Inc(Pixels);
      end;
    end;

    ACanvas.Draw(X, Y, Bmp, 255);
  finally
    Bmp.Free;
  end;
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  case Button of
    mbLeft:
    begin
      IsDrawing := True;
      DrawOpacityBrush(Form1.Canvas, X, Y, clRed, 50, 85);
    end;
  end;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if (GetAsyncKeyState(VK_LBUTTON) <> 0) and
     (IsDrawing) then
  begin
    DrawOpacityBrush(Form1.Canvas, X, Y, clRed, 50, 85);
  end;
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  IsDrawing := False;
end;
（1）在椭圆周围绘制不透明度线

（2）有一个选项可以防止绘制任何椭圆

此模拟示例图像应给出我希望如何绘制的想法：

3条紫色刷线显示选项（1）

要实现选项（2）画笔线内的圆圈不应存在

这样你就可以在画图时花点时间，而不是在画布上疯狂地移动鼠标，希望得到你需要的结果。只有当你决定回到你刚刚做的笔刷笔划时，该区域的不透明度才会变得更暗等等

如何实现这些类型的绘图效果？

我希望能够利用TImage，因为这是我目前正在做的事情，所以在函数或过程中将TCanvas作为参数传递是理想的。我还将使用MouseDown、MouseMove和MouseUp事件进行绘图

这是我使用NGLN提供的方法得到的输出：

var
  Form1: TForm1;

  IsDrawing: Boolean;

implementation

{$R *.dfm}

procedure DrawOpacityBrush(ACanvas: TCanvas; X, Y: Integer; AColor: TColor; ASize: Integer; Opacity: Byte);
var
  Bmp: TBitmap;
  I, J: Integer;
  Pixels: PRGBQuad;
  ColorRgb: Integer;
  ColorR, ColorG, ColorB: Byte;
begin
  Bmp := TBitmap.Create;
  try
    Bmp.PixelFormat := pf32Bit; // needed for an alpha channel
    Bmp.SetSize(ASize, ASize);

    with Bmp.Canvas do
    begin
      Brush.Color := clFuchsia; // background color to mask out
      ColorRgb := ColorToRGB(Brush.Color);
      FillRect(Rect(0, 0, ASize, ASize));
      Pen.Color := AColor;
      Pen.Style := psSolid;
      Pen.Width := ASize;
      MoveTo(ASize div 2, ASize div 2);
      LineTo(ASize div 2, ASize div 2);
    end;

    ColorR := GetRValue(ColorRgb);
    ColorG := GetGValue(ColorRgb);
    ColorB := GetBValue(ColorRgb);

    for I := 0 to Bmp.Height-1 do
    begin
      Pixels := PRGBQuad(Bmp.ScanLine[I]);
      for J := 0 to Bmp.Width-1 do
      begin
        with Pixels^ do
        begin
          if (rgbRed = ColorR) and (rgbGreen = ColorG) and (rgbBlue = ColorB) then
            rgbReserved := 0
          else
            rgbReserved := Opacity;
          // must pre-multiply the pixel with its alpha channel before drawing
          rgbRed := (rgbRed * rgbReserved) div $FF;
          rgbGreen := (rgbGreen * rgbReserved) div $FF;
          rgbBlue := (rgbBlue * rgbReserved) div $FF;
        end;
        Inc(Pixels);
      end;
    end;

    ACanvas.Draw(X, Y, Bmp, 255);
  finally
    Bmp.Free;
  end;
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  case Button of
    mbLeft:
    begin
      IsDrawing := True;
      DrawOpacityBrush(Form1.Canvas, X, Y, clRed, 50, 85);
    end;
  end;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if (GetAsyncKeyState(VK_LBUTTON) <> 0) and
     (IsDrawing) then
  begin
    DrawOpacityBrush(Form1.Canvas, X, Y, clRed, 50, 85);
  end;
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  IsDrawing := False;
end;

不透明度似乎也适用于图像，它应该只适用于多段线。

为什么不画一条多段线呢

unit Unit1;

interface

uses
  Windows, Classes, Graphics, Controls, Forms, ExtCtrls;

type
  TPolyLine = record
    Count: Integer;
    Points: array of TPoint;
  end;

  TPolyLines = array of TPolyLine;

  TForm1 = class(TForm)
    PaintBox: TPaintBox;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormResize(Sender: TObject);
     procedure PaintBoxMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure PaintBoxMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure PaintBoxPaint(Sender: TObject);
  private
    FBlendFunc: BLENDFUNCTION;
    FBmp: TBitmap;
    FPolyLineCount: Integer;
    FPolyLines: TPolyLines;
    procedure AddPoint(APoint: TPoint);
    function LastPoint: TPoint;
    procedure NewPolyLine;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.AddPoint(APoint: TPoint);
begin
  with FPolyLines[FPolyLineCount - 1] do
  begin
    if Length(Points) = Count then
      SetLength(Points, Count + 64);
    Points[Count] := APoint;
    Inc(Count);
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  FBmp := TBitmap.Create;
  FBmp.Canvas.Brush.Color := clWhite;
  FBmp.Canvas.Pen.Width := 30;
  FBmp.Canvas.Pen.Color := clRed;
  FBlendFunc.BlendOp := AC_SRC_OVER;
  FBlendFunc.SourceConstantAlpha := 80;
  DoubleBuffered := True;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FBmp.Free;
end;

procedure TForm1.FormResize(Sender: TObject);
begin
  FBmp.Width := PaintBox.Width;
  FBmp.Height := PaintBox.Height;
end;

function TForm1.LastPoint: TPoint;
begin
  with FPolyLines[FPolyLineCount - 1] do
    Result := Points[Count - 1];
end;

procedure TForm1.NewPolyLine;
begin
  Inc(FPolyLineCount);
  SetLength(FPolyLines, FPolyLineCount);
  FPolyLines[FPolyLineCount - 1].Count := 0;
end;

procedure TForm1.PaintBoxMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if ssLeft in Shift then
  begin
    NewPolyLine;
    AddPoint(Point(X, Y));
    PaintBox.Invalidate;
  end;
end;

procedure TForm1.PaintBoxMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if ssLeft in Shift then
    if Sqr(LastPoint.X - X) + Sqr(LastPoint.Y - Y) > 30 then
    begin
      AddPoint(Point(X, Y));
      PaintBox.Invalidate;
    end;
end;

procedure TForm1.PaintBoxPaint(Sender: TObject);
var
  R: TRect;
  I: Integer;
begin
  R := PaintBox.ClientRect;
  FBmp.Canvas.FillRect(R);
  for I := 0 to FPolyLineCount - 1 do
    with FPolyLines[I] do
      FBmp.Canvas.Polyline(Copy(Points, 0, Count));
  Windows.AlphaBlend(PaintBox.Canvas.Handle, 0, 0, R.Right, R.Bottom,
    FBmp.Canvas.Handle, 0, 0, R.Right, R.Bottom, FBlendFunc);
end;

end.

第二张图片显示了如何将其与背景相结合，并通过对代码的以下细微添加获得，而
FGraphic
是一张运行时加载的图片：

procedure TForm1.PaintBoxPaint(Sender: TObject);
var
  R: TRect;
  I: Integer;
begin
  R := PaintBox.ClientRect;
  FBmp.Canvas.FillRect(R);
  for I := 0 to FPolyLineCount - 1 do
    with FPolyLines[I] do
      FBmp.Canvas.Polyline(Copy(Points, 0, Count));
  PaintBox.Canvas.StretchDraw(R, FGraphic);
  Windows.AlphaBlend(PaintBox.Canvas.Handle, 0, 0, R.Right, R.Bottom,
    FBmp.Canvas.Handle, 0, 0, R.Right, R.Bottom, FBlendFunc);
end;
或者，要组合已绘制的作品（如
图像
），请将其画布复制到
画框
：

但与David在评论中提到的一样，我也强烈建议在
画框上绘制所有内容：这就是它的用途。
如何在TImage画布上绘制？我似乎只能在表单上工作。你需要一个TPaintbox而不是TImage。嗨，大卫，我真的很想在TImage上做这件事，因为到目前为止我一直在做加载/保存和在画布上绘画等工作。你需要使用一个paintbox。您当前的代码完全被破坏了，因为您是在鼠标下键而不是在绘制方法中绘制的。否。不能在鼠标事件中绘制。您必须根据WM_PAINT进行绘制。这是一条很难的规则。这意味着一个
绘制
覆盖，或一个绘制框。正如我在上一篇评论中所说的，您当前的代码完全被破坏了。尝试在顶部拖动另一个窗口。“使需求更清晰”是在有人回答了手头的问题后更改问题。最好先仔细考虑一下需求，再问一个新问题。公平地说，考虑到我发布的使用TCanvas的示例，我从NGLN得到的答案不包括这个参数，而是一个不同的m