Проблема с регионами + UpdateLayeredWindow.
Вот скрин в XP:
Вот он же в Vista:
Вот код:| Код |
unit unit_layer1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, jpeg, ExtCtrls;
type
TfmLayer1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
{ Private declarations }
FRgn: HRGN;
FPanelRgn: HRGN;
FPanel: TPanel;
procedure UpdateProc(Sender: TObject);
protected
procedure CreateParams(var Params: TCreateParams); override;
public
{ Public declarations }
end;
const
BORDER_WIDTH = 10;
CAPTION_HEIGHT = 30;
var
fmLayer1: TfmLayer1;
implementation
{$R *.dfm}
procedure TfmLayer1.UpdateProc(Sender: TObject);
type
TRGBQArray = array[0..0] of TRGBQuad;
PRGBQArray = ^TRGBQArray;
var
lBlend: TBlendFunction;
lSize: TSize;
lTopLeft: TPoint;
i, j: integer;
lRow: PRGBQArray;
begin
with TBitmap.Create do
try
Width := Self.Width;
Height := Self.Height;
PixelFormat := pf32bit;
with Canvas do
begin
Brush.Color := clBlack;
FillRect(ClipRect);
Pen.Color := clSilver;
Brush.Color := $202020;
end;
FPanel.PaintTo(Canvas, FPanel.Left, FPanel.Top);
FrameRgn(Canvas.Handle, FRgn, Canvas.Brush.Handle, 1, 1);
for j := 0 to Height - 1 do
begin
lRow := Scanline[j];
for i := 0 to Width - 1 do
begin
if PtInRegion(FRgn, i, j) then
begin
with lRow[i] do
case RGB(rgbRed, rgbGreen, rgbBlue) of
clBlack: rgbReserved := 5;
clSilver: rgbReserved := 200;
else
rgbReserved := 175;
end;
end
else
if PtInRegion(FPanelRgn, i, j) then
lRow[i].rgbReserved := 255
else
lRow[i].rgbReserved := 0;
lRow[i].rgbBlue := Round(lRow[i].rgbBlue * lRow[i].rgbReserved / 255);
lRow[i].rgbGreen := Round(lRow[i].rgbGreen * lRow[i].rgbReserved / 255);
lRow[i].rgbRed := Round(lRow[i].rgbRed * lRow[i].rgbReserved / 255);
// Заглушка, чтобы спрятать уголки панели
if ((lRow[i].rgbBlue = 175) and
(lRow[i].rgbGreen = 175) and
(lRow[i].rgbRed = 175) and
(lRow[i].rgbReserved = 175)) or
((lRow[i].rgbBlue = 88) and
(lRow[i].rgbGreen = 88) and
(lRow[i].rgbRed = 88) and
(lRow[i].rgbReserved = 175)) then
begin
lRow[i].rgbBlue := 0;
lRow[i].rgbGreen := 0;
lRow[i].rgbRed := 0;
lRow[i].rgbReserved := 5;
end;
end;
end;
with lBlend do
begin
BlendOp := AC_SRC_OVER;
BlendFlags := 0;
SourceConstantAlpha := 255;
AlphaFormat := AC_SRC_ALPHA;
end;
with lSize do
begin
cx := Width;
cy := Height;
end;
lTopLeft := Point(0, 0);
UpdateLayeredWindow(Self.Handle, 0, nil, @lSize, Canvas.Handle,
@lTopLeft, clNone, @lBlend, ULW_ALPHA);
finally
Free;
end;
end;
procedure TfmLayer1.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.Style := Params.Style or WS_THICKFRAME;
end;
procedure TfmLayer1.FormCreate(Sender: TObject);
var
lRgn, lRgn2: HRGN;
lRound: Integer;
begin
DoubleBuffered := True;
Position := poScreenCenter;
FPanel := TPanel.Create(Self);
FPanel.Parent := Self;
FPanel.BoundsRect := Rect(BORDER_WIDTH, CAPTION_HEIGHT + BORDER_WIDTH,
Width - BORDER_WIDTH, Height - BORDER_WIDTH);
FPanel.Color := clWhite;
FPanel.Caption := 'Test Panel';
FRgn := CreateRectRgn(0, 0, Width, Height);
lRound := Width div 20;
if Height div 20 > lRound then
lRound := Height div 20;
lRgn := CreateRoundRectRgn(0, CAPTION_HEIGHT,
Width, Height, lRound, lRound);
lRound := Width div 20;
if Height div 20 > lRound then
lRound := Height div 20;
lRgn2 := CreateRoundRectRgn(0, 0, 120,
CAPTION_HEIGHT * 2, lRound, lRound);
CombineRgn(lRgn, lRgn, lRgn2, RGN_OR);
CombineRgn(FRgn, FRgn, lRgn, RGN_AND);
DeleteObject(lRgn);
DeleteObject(lRgn2);
lRound := FPanel.Width div 20;
if FPanel.Height div 20 > lRound then
lRound := FPanel.Height div 20;
FPanelRgn := CreateRoundRectRgn(BORDER_WIDTH, CAPTION_HEIGHT + BORDER_WIDTH,
Width - BORDER_WIDTH, Height - BORDER_WIDTH, lRound, lRound);
CombineRgn(FRgn, FRgn, FPanelRgn, RGN_DIFF);
SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(Handle, GWL_EXSTYLE) or
WS_EX_LAYERED);
end;
procedure TfmLayer1.FormDestroy(Sender: TObject);
begin
DeleteObject(FPanelRgn);
DeleteObject(FRgn);
end;
procedure TfmLayer1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if (Button = mbLeft) and (Tag <> 1) and (Y <= CAPTION_HEIGHT) then
begin
ReleaseCapture;
Perform(WM_SYSCOMMAND, $F012, 0);
end;
end;
procedure TfmLayer1.FormShow(Sender: TObject);
begin
UpdateProc(Self);
OnResize := UpdateProc;
end;
end.
|
Проект приложил. У кого есть идеи что к чему? |
