Вопрос по – Как сделать TFrame (и все на нем) частично прозрачным?

9

У меня есть объект, состоящий изTFrame, на этомTPanel и на этомTImage. Растровое изображение назначено наTImage содержащий пианино. Этот фрейм-объект ставится наTImage, содержащий изображение, содержащее сетку. Смотрите изображение для примера.

Вопрос: Можно ли сделать рамку частично прозрачной, чтобы фоновое изображение, содержащее сетку (в главной форме), было смутно видно? В идеале количество прозрачности может быть установлено пользователем. Растровое изображение имеет глубину 32 бита, но эксперименты с альфа-каналом не помогли. Панель не является строго необходимой. Он используется, чтобы быстро обвести границу вокруг объекта. Я мог бы нарисовать это на изображении.

Обновление 1 Добавлен небольшой пример кода. Основной блок рисует фон с вертикальными линиями. Второй блок содержит TFrame и TImage, которые рисуют горизонтальную линию. То, что я хотел бы видеть, - то, что вертикальные линии частично сияют через Изображение TFrame.

Обновление 2 Что я не указал в своем первоначальном вопросе: TFrame является частью гораздо большего приложения и ведет себя независимо. Было бы полезно, если бы проблема прозрачности могла быть решена самим TFrame.

///////////////// Main unit, on mouse click draw lines and plot TFrame
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls,
  Unit2;

type
  TForm1 = class(TForm)
    Image1: TImage;
    procedure Image1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var background: TBitmap;
    f: TFrame2;
    i, c: Int32;
begin
   background := TBitmap.Create;
   background.Height := Image1.Height;
   background.Width  := Image1.Width;
   background.Canvas.Pen.Color := clBlack;

   for i := 0 to 10 do
   begin
      c := i * background.Width div 10;
      background.Canvas.MoveTo (c, 0);
      background.Canvas.LineTo (c, background.Height);
   end;
   Image1.Picture.Assign (background);
   Application.ProcessMessages;

   f := TFrame2.Create (Self);
   f.Parent := Self;
   f.Top    := 10;
   f.Left   := 10;
   f.plot;
end;

end.

///////////////////Unit containing the TFrame
unit Unit2;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
  Dialogs, ExtCtrls;

type
  TFrame2 = class(TFrame)
    Image1: TImage;

    procedure plot;
  end;

implementation

{$R *.dfm}

procedure TFrame2.plot;
var bitmap: TBitmap;
begin
   bitmap := TBitmap.Create;
   bitmap.Height := Image1.Height;
   bitmap.Width  := Image1.Width;
   bitmap.PixelFormat := pf32Bit;
   bitmap.Canvas.MoveTo (0, bitmap.Height div 2);
   bitmap.Canvas.LineTo (bitmap.Width, bitmap.Height div 2);
   Image1.Picture.Assign (bitmap);
end;

end.

Обновление 3 Я надеялся, что будет какое-то сообщение или вызов API, что приведет к решению, которое элемент управления может сделать частично прозрачным, как сообщение WMEraseBkGnd для полной прозрачности. В своих решениях и Sertac, и NGLN оба указывают на имитирующая прозрачность с функцией AlphaBlend. Эта функция объединяет два растровых изображения и поэтому требует знания фонового изображения. Теперь у моего TFrame есть дополнительное свойство:BackGround: TImage, который назначен родительским контролем. Это дает желаемый результат (это так профессионально, чтобы увидеть, как это работает: -)

RRUZ указывает на библиотеку Graphics32. То, что я видел, дает фантастические результаты, для меня кривая обучения слишком крутая.

Спасибо за вашу помощь

То, что вы ищете, обычно решается с помощью слоев, попробуйте использовать Graphics32 библиотека, которая поддерживает слои. RRUZ
@ RRUZ, я несколько раз пытался понять Graphics32, но это просто слишком сложно для меня. Я надеялся, что будет решение, понятное для меня: -) Arnold
@ Sertac, есть два Tbitmaps и два Timage. Один TImage / TBitmap находится на фрейме, поэтому я могу перемещать эту комбинацию. Arnold
Разместите некоторый код, может быть легче получить хороший ответ. Leonardo Herrera
Есть 2 изображения? Sertac Akyuz

Ваш Ответ

3   ответа
7

которое копирует фоновое изображение в верхнее изображение иAlphaBlend растровое изображение поверх него, сохраняя прозрачность черных точек:

раздел 1

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Unit2, ExtCtrls, ComCtrls, StdCtrls;

type
  TForm1 = class(TForm)
    Clip_View1: TClip_View;
    TrackBar1: TTrackBar;
    Label1: TLabel;
    procedure TrackBar1Change(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
  TrackBar1.Min := 0;
  TrackBar1.Max := 255;
  TrackBar1.Position := 255;
end;

procedure TForm1.TrackBar1Change(Sender: TObject);
begin
  Label1.Caption := IntToStr(TrackBar1.Position);
  Clip_View1.Transparency := TrackBar1.Position;
end;

end.

модуль 2

unit Unit2;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls;

type
  TClip_View = class(TFrame)
    Image1: TImage;
    Panel1: TPanel;
    Image2: TImage;
  protected
    procedure SetTransparency(Value: Byte);
  private
    FTopBmp: TBitmap;
    FTransparency: Byte;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Transparency: Byte read FTransparency write SetTransparency;
  end;

implementation

{$R *.dfm}

{ TClip_View }

constructor TClip_View.Create(AOwner: TComponent);
begin
  inherited;
  Image1.Left := 0;
  Image1.Top := 0;
  Image1.Picture.LoadFromFile(ExtractFilePath(Application.ExeName) + '..\..\back.bmp');
  Image1.Picture.Bitmap.PixelFormat := pf32bit;
  Image1.Width := Image1.Picture.Bitmap.Width;
  Image1.Height := Image1.Picture.Bitmap.Height;

  FTopBmp := TBitmap.Create;
  FTopBmp.LoadFromFile(ExtractFilePath(Application.ExeName) + '..\..\top.bmp');
  FTopBmp.PixelFormat := pf32bit;
  Image2.SetBounds(1, 1, FTopBmp.Width, FTopBmp.Height);
  Panel1.SetBounds(20, 20, Image2.Width + 2, Image2.Height + 2);
  Image2.Picture.Bitmap.SetSize(Image2.Width, Image2.Height);
  Image2.Picture.Bitmap.Canvas.Draw(0, 0, FTopBmp);
end;

destructor TClip_View.Destroy;
begin
  FTopBmp.Free;
  inherited;
end;

procedure TClip_View.SetTransparency(Value: Byte);
var
  Bmp: TBitmap;
  R: TRect;
  X, Y: Integer;
  Pixel: PRGBQuad;
  BlendFunction: TBlendFunction;
begin
  if Value <> FTransparency then begin
    FTransparency := Value;
    R := Image2.BoundsRect;
    OffsetRect(R, Panel1.Left, + Panel1.Top);
    Image2.Picture.Bitmap.Canvas.CopyRect(Image2.ClientRect,
                                          Image1.Picture.Bitmap.Canvas, R);

    Bmp := TBitmap.Create;
    Bmp.SetSize(FTopBmp.Width, FTopBmp.Height);
    Bmp.PixelFormat := pf32bit;
    Bmp.Assign(FTopBmp);
    try
      for Y := 0 to Bmp.Height - 1 do begin
        Pixel := Bmp.ScanLine[Y];
        for X := 0 to Bmp.Width - 1 do begin
          if (Pixel.rgbBlue <> 0) and (Pixel.rgbGreen <> 0) and
              (Pixel.rgbRed <> 0) then begin
            Pixel.rgbBlue := MulDiv(Pixel.rgbBlue, Value, $FF);
            Pixel.rgbGreen := MulDiv(Pixel.rgbGreen, Value, $FF);
            Pixel.rgbRed := MulDiv(Pixel.rgbRed, Value, $FF);
            Pixel.rgbReserved := Value;
          end else                      // don't touch black pixels
            Pixel.rgbReserved := $FF;
          Inc(Pixel);
        end;
      end;

      BlendFunction.BlendOp := AC_SRC_OVER;
      BlendFunction.BlendFlags := 0;
      BlendFunction.SourceConstantAlpha := 255;
      BlendFunction.AlphaFormat := AC_SRC_ALPHA;
      AlphaBlend(Image2.Picture.Bitmap.Canvas.Handle,
          0, 0, Image2.Picture.Bitmap.Width, Image2.Picture.Bitmap.Height,
          Bmp.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height,
          BlendFunction);
    finally
      Bmp.Free;
    end;
  end;
end;

end.


Во время запуска:

Применить прозрачность:

Это именно то, что я хотел получить! Но и здесь с решением NGLN: функция AlphaBlend, похоже, должна знать оба растровых изображения, в то время как в моем приложении TFrame не знает о своем окружении. Arnold
Если исходное растровое изображение является 32-разрядным, TCanvas.Draw (из этого растрового изображения) будет использовать AlphaBlend, так что вы, вероятно, можете просто использовать Draw, не используя вызовы BlendFunc или API и т. Д., Просто установив свойства растрового изображения. Rudy Velthuis
@ Арнольд - Во-первых, я не знаю, получил ли тыOffsetRect правильно, это будет зависеть от того, избавишься ли ты от панели, будет ли фоновое изображение на форме или на рамке, чего я не знаю. Во-вторых, вам не нужноFrame_Image.Picture.Bitmap.Canvas.Draw(0, 0, FTopBmp);, этоAlphaBlend который будет рисовать на переднем плане изображения. В-третьих, в вашем обновлении не видно, если у вас есть правильное по размеру растровое изображение для переднего изображения, вам может потребоватьсяFrame_Image.Picture.Bitmap.SetSize(FTopBmp.Width, FTopBmp.Height); передCopyRect. Sertac Akyuz
@ Arnold - Приведенный выше код не использует фоновое растровое изображение, он копирует его из фонового TImage. Но то же самое не относится к верхнему растровому изображению, вы должны иметь его оригинальную копию, чтобы иметь возможность применять прозрачные пленки разного уровня к AlphaBlend. Я не могу придумать иного способа удовлетворить ваши требования, кроме как использовать AlphaBlend .. Sertac Akyuz
@ Rudy - Какие свойства растрового изображения мне нужно установить? Arnold
8

Скройте рамку и используйтеFrame.PaintTo. Например, следующим образом:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Image1: TImage; //Align = alClient, Visible = False
    Frame21: TFrame2; //Visible = False
    procedure FormPaint(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormResize(Sender: TObject);
  private
    FBlendFunc: TBlendFunction;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

{ TForm1 }

procedure TForm1.FormPaint(Sender: TObject);
var
  Bmp: TBitmap;
begin
  Bmp := TBitmap.Create;
  try
    Bmp.Width := Frame21.Width;
    Bmp.Height := Frame21.Height;
    Frame21.PaintTo(Bmp.Canvas, 0, 0);
    Canvas.StretchDraw(ClientRect, Image1.Picture.Graphic);
    with Frame21 do
      Windows.AlphaBlend(Canvas.Handle, Left, Top, Left + Width, Top + Height,
        Bmp.Canvas.Handle, 0, 0, Width, Height, FBlendFunc);
  finally
    Bmp.Free;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  FBlendFunc.BlendOp := AC_SRC_OVER;
  FBlendFunc.BlendFlags := 0;
  FBlendFunc.SourceConstantAlpha := 255 div 2;
  FBlendFunc.AlphaFormat := 0;
end;

procedure TForm1.FormResize(Sender: TObject);
begin
  Invalidate;
end;

end.

Рамочный блок:

unit Unit2;

interface

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

type
  TFrame2 = class(TFrame)
    Image1: TImage;  //Align = alClient
    Panel1: TPanel;  //Align = alClient, BevelWidth = 5
  end;

implementation

{$R *.dfm}

end.

Результат

Перепишите выше для вашей конкретной ситуации, в идеале рисование наTPaintBox избавиться от компонента изображения в главной форме. Но когда единственным значимым элементом кадра является изображение, я бы тоже перестал его использовать и сам начал рисовать.

Впечатляет, попробую вечером. Один недостаток, который я вижу, состоит в том, что это решение требует, чтобы TFrame «знал» лежащий битовый массив. Нет способа обойти это? Arnold
@ Арнольд Нет, рамка не знает изображения в форме. Обратите внимание, что мой блок кадров вообще не имеет кода, рисование выполняется в основном модуле формы. NGLN
2

TPaintBox вместо. В егоOnPaint event, сначала нарисуйте свою сетку, а затем альфа-смешайте изображение рулона сверху. Нет необходимости использовать любойTImage, TPanel, илиTFrame компоненты вообще.

Похожие вопросы