Снова про прозрачность части формы

← →
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 или позже:) (чтобы не сперли раньше времени:)) ).

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

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

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

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

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

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

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

---
Understanding is not required. Only obedience.

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