Top.Mail.Ru
Мастера DELPHI, Delphi programming community Титульная страница Поиск, карта сайта Написать письмо 
| Новости | Поиск | FAQ | Статьи | Книги | Новости VCL |
| Форумы ЧАТ | Орешник | KOL и MCK |
Форумы -» Основная («Начинающим»)/ Базы / WinAPI / Компоненты / Сети / Media / Игры / Corba и COM / KOL / FreePascal / .Net / Прочее / RSDN.ORG

« предыдущая ветвь | форум | следующая ветвь »

Снова про прозрачность части формы [D7, WinXP]


Nil ©   (2008-02-04 16:51:00) 

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

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 да и уж очень много их на форме чтобы каждый руками отрисовывать.

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

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

ketmar   (2008-02-09 14:21:00) [1]

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

---
Understanding is not required. Only obedience.

DVM   (2008-02-09 14:19:00) [2]


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

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

Andrewtitoff   (2008-02-08 23:47:00) [3]

А зачем этот геморой та?, я конечно незнаю какая у тебя дельфя стоит, просто у меня 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 соответственно твоя маска...

Dmitry S   (2008-02-05 20:31:00) [4]


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

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

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

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

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

ketmar   (2008-02-05 13:01:00) [5]

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

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


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

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

ketmar   (2008-02-05 02:55:00) [7]

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

Nil   (2008-02-05 01:41:00) [8]


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

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


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

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


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

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


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

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

DVM   (2008-02-04 22:48:00) [9]

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


> Nil  

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

ketmar   (2008-02-04 17:29:00) [10]

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

Nil   (2008-02-04 16:55:00) [11]

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

Наверх

Титульная страница Поиск, карта сайта Написать письмо