Форум: "WinAPI";
Текущий архив: 2008.12.21;
Скачать: [xml.tar.bz2];

Вниз

Снова про прозрачность части формы   Найти похожие ветки 

← →
Nil   (2008-02-04 16:51) [0]

Вот этот кусок делает непрозрачным произвольный кусок формы, который я могу задать маской:

unit Unit8;

interface

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

type
 TForm8 = class(TForm)
   Button1: TButton;
   procedure FormCreate(Sender: TObject);
   procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
     Shift: TShiftState; X, Y: Integer);
   procedure Button1Click(Sender: TObject);
   procedure FormPaint(Sender: TObject);
 private
   { Private declarations }
 public
   { Public declarations }
   procedure BuildCopy24to32(_B_in,_B_mask:TBitmap; var _B_out: TBitmap);
 protected
   procedure WMWINDOWPOSCHANGING(var Msg: TWMWINDOWPOSCHANGING); message WM_WINDOWPOSCHANGING;
 end;

var
 Form8: TForm8;

implementation

{$R *.dfm}

procedure TForm8.BuildCopy24to32(_B_in,_B_mask:TBitmap; var _B_out: TBitmap);
const
 MaxPixelCountA = MaxInt div SizeOf(TRGBQuad);
 MaxPixelCount = MaxInt div SizeOf(TRGBTriple);
type
 PRGBArray = ^TRGBArray;
 TRGBArray = array[0..MaxPixelCount-1] of TRGBTriple;
 PRGBAArray = ^TRGBAArray;
 TRGBAArray = array[0..MaxPixelCountA-1] of TRGBQuad;
var x, y: Integer; RowOut: PRGBAArray; RowIn,RowInMask:PRGBArray;
begin
 _B_out.Width:=_B_in.Width;
 _B_out.Height:=_B_in.Height;
 for y:=0 to _B_in.Height-1 do begin
    RowOut:= _B_out.ScanLine[y];
    RowIn:= _B_in.ScanLine[y];
    RowInMask:= _B_mask.ScanLine[y];
   for x:=0 to _B_in.Width-1 do begin
         RowOut[x].rgbReserved:=trunc((RowInMask[x].rgbtBlue+RowInMask[x].rgbtGreen+RowInMask[x].rgbtRed)/3);
         RowOut[x].rgbBlue:=byte(trunc(RowIn[x].rgbtBlue*RowOut[x].rgbReserved/255));
         RowOut[x].rgbGreen:=byte(trunc(RowIn[x].rgbtGreen*RowOut[x].rgbReserved/255));
         RowOut[x].rgbRed:=byte(trunc(RowIn[x].rgbtRed*RowOut[x].rgbReserved/255));
   end;
 end
end;

procedure TForm8.Button1Click(Sender: TObject);
begin
 ShowMessage("1");
 SendMessage(Handle,WM_PAINT,0,0);
end;

procedure TForm8.FormCreate(Sender: TObject);
var
 FWorkBMP, BGBmp, MaskBmp: TBitmap;
 zsize:TSize;
 zpoint:TPoint;
 zbf:TBlendFunction;
 TopLeft: TPoint;
 DC:HDC;
 Rgn: HRGN;
begin
 DoubleBuffered:=true;

 BGBmp:=TBitmap.Create;
 BGBmp.PixelFormat := pf32Bit;
 BGBmp.LoadFromFile("bg.bmp");

 MaskBmp:=TBitmap.Create;
 MaskBmp.PixelFormat := pf32Bit;
 MaskBmp.LoadFromFile("mask.bmp");

 FWorkBMP := TBitmap.Create;
 FWorkBMP.PixelFormat := pf32Bit;
 FWorkBMP.Width := BGBmp.Width;
 FWorkBMP.Height := BGBmp.Height;

 BuildCopy24to32(BGBmp,MaskBmp,FWorkBMP);

 SetWindowLong(Handle,GWL_EXSTYLE, GetWindowLong(Handle,GWL_EXSTYLE) or WS_EX_LAYERED);

 width:=FWorkBMP.Width;
 height:=FWorkBMP.Height;

 zsize.cx := FWorkBMP.Width;
 zsize.cy := FWorkBMP.Height;
 zpoint := Point(0,0);

 with zbf do begin
   BlendOp := AC_SRC_OVER;
   BlendFlags := 0;
   AlphaFormat := AC_SRC_ALPHA;
   SourceConstantAlpha := 255;
 end;
 DC:= GetDC(0);
 TopLeft:=BoundsRect.TopLeft;
 UpdateLayeredWindow(Handle,DC,@TopLeft,@zsize,FWorkBMP.Canvas.Handle,@zpoint,0,@ zbf, ULW_ALPHA);
 ReleaseDC(0, DC);

 Rgn := CreateRoundRectRgn(0, 0, FWorkBMP.Width, FWorkBMP.Height, 20, 20);
 SetWindowRgn(Handle, rgn, True);

 BGBmp.Free;
 MaskBmp.Free;
 FWorkBMP.Free;

end;

procedure TForm8.FormMouseDown(Sender: TObject; Button: TMouseButton;
 Shift: TShiftState; X, Y: Integer);
begin
if Button <> mbRight then begin
  ReleaseCapture;
  SendMessage(Handle, WM_SYSCOMMAND, 61458, 0);
  end;
end;

procedure TForm8.FormPaint(Sender: TObject);
begin
 UpdateWindow(Handle);
 ShowMessage("1");
end;

procedure TForm8.WMWINDOWPOSCHANGING(var Msg: TWMWINDOWPOSCHANGING);
begin
SetWindowPos(Handle,HWND_TOPmost,Left,Top,Width,Height, SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE );
end;

end.



Всё красиво, только нельзя в этом примере создавать контролы на форме. Точнее можно, но они не отрисовываются и отрисовать их как я понял не получится. Эта тема бурно обсуждалась здесь: http://www.delphikingdom.com/asp/answer.asp?IDAnswer=48509
Тут предлагают каждый контрол отрисовывать на картинку с альфа каналом через PaintTo а потом её рисовать на форме через UpdateLayeredWindow. Это очень неудобно и не у всех контролов есть PaintTo да и уж очень много их на форме чтобы каждый руками отрисовывать.

Но всё таки как то хочется найти выход из ситуации. Может есть какие то другие пути решения задачи?

Заранее благодарен!!

---

← →
Nil   (2008-02-04 16:55) [1]

Суть задачи состоит в том, что нужно сделать форму с фоном в виде картинки, при этом часть этой картинки должна быть непрозрачной, ну и конечно же нужно чтобы была возможность положить на форму сколько угодно нужных контролов и вели они себя все правильно, а не так как в приведённом примере

---

← →
ketmar ©   (2008-02-04 17:29) [2]

справочные материалы по UpdateLayeredWindow() читал? ты сказал винде, что рисовать окошко будешь сам — с чего она тебе должна контролы отрисовывать?

---

← →
DVM ©   (2008-02-04 22:48) [3]

Что то всех прорвало в последнее время на этой UpdateLayeredWindow. И проблема как ни странно у всех одна и та же. Справку конечно читать нефиг.


> Nil  

Все что должно являться контролами надо нарисовать вначале. Клики и прочие события отлавливать. Контролы обновлять. Потом опять вызывать UpdateLayeredWindow. Короче, любишь кататься люби и саночки, как говорится, возить.

---

← →
Nil   (2008-02-05 01:41) [4]

> справочные материалы по UpdateLayeredWindow() читал? ты
> сказал винде, что рисовать окошко будешь сам — с чего она
> тебе должна контролы отрисовывать?

если бы не читал, таких вопросов бы не задавал. там написано форма не передаёт WM_PAINT при такой прозрачности, а как всё таки передать всем этот WM_PAINT я не знаю...


> Все что должно являться контролами надо нарисовать вначале.

в этом и вся проблема.. а если у контрола нет PaintTo или например контрол это TEdit?? ведь у него есть мигающий курсор, как сним быть и таких проблем куча, ведь есть же проще способ решения?


> Клики и прочие события отлавливать.

их отлавливать не нужно, они все работают. проблема в том, как послать всем контролам сообщение с просьбой перерисоваться на WS_EX_LAYERED и при ULW_ALPHA. вот в чём вопрос...


> Короче, любишь кататься люби и саночки, как говорится, возить.

это всё понятно, просто далеко не все компьютеры смогут такие саночки без особой нагрузки вывезти. а ведь как то это в винде реализовано, да и кучу других программ видел с такими эффектами. в этом и вопрос как там это всё реализовано?

---

← →
ketmar ©   (2008-02-05 02:55) [5]

>[4] Nil(05.02.08 01:41)
>ведь есть же проще способ решения?
есть. не страдать фигнёй.

---

← →
Nil   (2008-02-05 11:49) [6]

> есть. не страдать фигнёй.

от души)) но не убедительно

---

← →
ketmar ©   (2008-02-05 13:01) [7]

>[6] Nil(05.02.08 11:49)
зато правда. ну не будет тебе лёгкой победы, а будет тебе сто лет геморроя. может, попробуешь всё-таки обойтись просто свойствами AlphaXXX из Delphi?

---

← →
Dmitry S ©   (2008-02-05 20:31) [8]

> ketmar ©   (05.02.08 13:01) [7]

А у меня все получилось тип топ:) Правда окно сам создал, да и контролов у меня нет и VCL-а тоже нет. Но полупрозрачность наура. Но, выложить смогу только 14 или позже:) (чтобы не сперли раньше времени:)) ).

А вообще я не вижу ничего плохого в том, чтобы все контролы самому отрисовывать. Покапаться в справке и все тип топ будет.

Да и не знаю, что у тебя там за проект где нужны контролы и полу-прозрачность:) Не знаю где это может понадобится:) Если для красоты - то нафиг они нужны - эти контролы, если для работы - то нафиг прозрачность:)

Есть пример, правда на АСМе, где, помоему, листбокс на такой форме висит. Могу найти - разберешься как там сделали:)

---

← →
Andrewtitoff ©   (2008-02-08 23:47) [9]

А зачем этот геморой та?, я конечно незнаю какая у тебя дельфя стоит, просто у меня 2007-ая, там в свойствах формы и как и в более старых версиях прозрачность задается (AlphaBlend если я не ошибаюсь) и можно свойством TransparentColorValue задавать цвет который небудет прорисовываться, без всяких там масок....

Не ну конечно если тебе хочется погемороиться с масками то попробуй так:

function BitmapToRgn(Image: TBitmap): HRGN;
var
 TmpRgn: HRGN;
 x, y: integer;
 ConsecutivePixels: integer;
 CurrentPixel: TColor;
 CurrentColor: TColor;
begin
 Result := CreateRectRgn(0, 0, Image.Width, Image.Height);
 if (Image.Width = 0) or (Image.Height = 0) then
   exit;
 for y := 0 to Image.Height - 1 do
 begin
   CurrentColor := Image.Canvas.Pixels[0,y];
   ConsecutivePixels := 1;
   for x := 0 to Image.Width - 1 do
   begin
     CurrentPixel := Image.Canvas.Pixels[x, y];
     if CurrentColor = CurrentPixel then
       inc(ConsecutivePixels)
     else
     begin
        if CurrentColor = clWhite then
       begin
         TmpRgn := CreateRectRgn(x - ConsecutivePixels, y, x, y + 1);
         CombineRgn(Result, Result, TmpRgn, RGN_DIFF);
          DeleteObject(TmpRgn);
       end;
       CurrentColor := CurrentPixel;
       ConsecutivePixels := 1;
     end;
   end;
   if (CurrentColor = clWhite) and (ConsecutivePixels > 0) then
   begin
     TmpRgn := CreateRectRgn(x-ConsecutivePixels, y, x, y+1);
     CombineRgn(Result, Result, TmpRgn, RGN_DIFF);
     DeleteObject(TmpRgn);
   end;
 end;
end;

Ну и соответственно в OnCreate твоей формы пишешь такой код:

procedure TForm1.FormCreate(Sender: TObject);
var
 MaskBmp: TBitmap;
begin
 MaskBmp := TBitmap.Create;
 try
   MaskBmp.LoadFromFile("Mask.bmp");
   Height := MaskBmp.Height;
   Width := MaskBmp.Width;
   SetWindowRgn(Self.Handle, BitmapToRgn(MaskBmp), True);
 finally
   MaskBmp.Free;
 end;
end;

Где Mask.bmp соответственно твоя маска...

---

← →
DVM ©   (2008-02-09 14:19) [10]

> Andrewtitoff ©   (08.02.08 23:47) [9]
> А зачем этот геморой та?

Регионами не добиться такого же качества как с UpdateLayeredWindow.

---

← →
ketmar ©   (2008-02-09 14:21) [11]

>[10] DVM © (2008-02-09 14:19:00)
да. и такого же геморроя тоже. %-)

---
Understanding is not required. Only obedience.

---

Страницы: 1 вся ветка

Форум: "WinAPI";
Текущий архив: 2008.12.21;
Скачать: [xml.tar.bz2];

Наверх

Память: 0.49 MB
Время: 0.048 c