Нужна такая фича, которая может скины для проги Style XP ставить и на другие ОС, в частности на 98 и 2000. Я даже гдет это видел, но вот блин не помню где и даже как называется... Никто не в курсе?
4 ответов в этой теме
#2
PLUR
-
- Постоялец
-
- 1 682 сообщений
Techno, Sex and nothing more!
- Откуда:[kopli.tln.ee]
Отправлено 21 января 2005 - 23:17
Windows blinds, Aston shell...
[ ++ :: D-Lab project //.com// :: ++ ]
#3
::Костян::
-
- Пользователь
-
- 243 сообщений
- Откуда:Estonia
Отправлено 22 января 2005 - 13:03
ne etu temu ja znaju.
Ja prosto imel vvedu stob skin na windows 98 se stavit s XP.
Ili stoto vrode etogo .
Ja prosto imel vvedu stob skin na windows 98 se stavit s XP.
Ili stoto vrode etogo .
#4
PLUR
-
- Постоялец
-
- 1 682 сообщений
Techno, Sex and nothing more!
- Откуда:[kopli.tln.ee]
Отправлено 22 января 2005 - 13:23
не как!
[ ++ :: D-Lab project //.com// :: ++ ]
#5
::Костян::
-
- Пользователь
-
- 243 сообщений
- Откуда:Estonia
Отправлено 22 января 2005 - 21:12
Izvenite menja S-Модератор. 
Ja prosto ne znal sto tak ne lzja delat - eto prosto moi pervii forum gde ja zaregestrirovalsja.
Kstati ja nashol tot sait gde ta infa lezit no ce to ja ne fega ne ponel.
MOzet objasniti takomu laimeru kak ja.
Счастливые обладатели Windows XP могут позволить себе такие прелести современного интерфейса как полупрозрачные окна, работа с альфа каналом и т.п. В то время как пользователи 98-го довольствуются стандартным "серо-чёрным" десктопом или в лучшем случае его "цветным" оформлением и красивыми заставками. Эта статья призвана помочь разработчикам ПО для Windows 98 обеспечить свои приложения теми прелестями, которые стали вседоступными только в XP
Постановка задачи
Большинство из вас наверное уже видело как выделяется группа файлов в Windows XP. Здесь как и в множестве других графических операций используется эффект полупрозрачности. Сейчас мы постараемся воспроизвести его на Windows 98.
С чего начать
Windows 98 и все последующие версии Windows имеют в своем составе библиотеку под названием msimg32.dll. Которая и предоставляет нам функции для работы над полупрозрачными изображениями. В ее состав входят такие основные функции:
Function TransparentBlt( DestDC:HDC; nXOriginDest, nYOriginDest, nWidthOriginDest, nHeightOriginDest:Integer; SrcDC:HDC; nXOriginSrc, nYOriginSrc, nWidthOriginSrc, nHeightOriginSrc:Integer; crTransparent:Integer):Integer;
function GradientFillRect( DC:HDC; pVertex:PTriVertex; dwNumVertex:Integer; pMesh:PGradientRect; dwNumMesh:Integer; dwMode:Integer):Integer;
function GradientFillTri( DC:HDC; pVertex:PTriVertex; dwNumVertex:Integer; pMesh:PGradientTriangle; dwNumMesh:Integer; dwMode:Integer):Integer;
function AlphaBlend( DestDC:HDC; nXOriginDest, nYOriginDest, nWidthDest, nHeightDest:Integer; SrcDC:HDC; nXOriginSrc, nYOriginSrc, nWidthSrc, nHeightSrc:Integer; BlendFunc:TBlendFunc):Boolean;
Для решения поставленной задачи мы воспользуемся функцией AlphaBlend, которая в качестве параметров принимает значения:
DestDC - идентификатор холста на который будет накладываться изображение
nXDest, nYDest, nWidthDest, nHeightDest - координаты области холста на который будет накладываться изображение. Если размеры накладываемых изображений не совпадают то проводится маштабироваение.
SrcDC - идентификатор накладываемого изображения.
nXSrc, nYSrc, nWidthSrc, nHeightSrc - координаты накладываемой области
BlendFunc - структура параметров альфа смешивания.
BlendFunc имеет тип TBlendFunc который определяется как:
TBlendFunc = packed record
BlendOP:Byte;
BlendFlags:Byte;
SourceConstantAlpha:Byte;
AlphaFormat:Byte;
end;
PBlendFunc = ^TBlendFunc;
Где BlendOP - операция альфа смешивания, BlendFlags - флаги операции, AlphaFormat - формат операции, SourceConstantAlpha - константа определяющая степень прозрачности.
Приложение
Для разработки нашего приложения мы сперва запустим Borland Delphi и перейдем в окон редактирования исходного кода. Здесь нам потребуется создать новый компонент - наследник TListBox в котором мы доопределим:
Координаты вершин прямоугольника выделения
Свойство EnablePaint разрешающее(запрещающее) отрисовку прямоугольника выделения.
Метод WMPaint который и будет отрисовывать изображение
Поле FTemp:TBitmap, которое содержит фон отрисовываемого прямоугольника.
Шаблон этого класса будет выгладеть следующим образом:
TMyListBox = class(TListBox)
private
FTemp:TBitmap;
FResult:TBitmap;
FPaintLeft,FPaintTop,FPaintRight,FPaintBottom:Integer;
FEnablePaint:Boolean;
procedure WMPaint(var Message:TWMPaint);message WM_Paint;
procedure SetPaintLeft(Value:Integer);
procedure SetPaintTop(Value:Integer);
procedure SetPaintRight(Value:Integer);
procedure SetPaintBottom(Value:Integer);
procedure SetEnablePaint(Value:Boolean);
public
procedure AfterConstruction;override;
procedure BeforeDestruction;override;
property PaintLeft:Integer read FPaintLeft write SetPaintLeft;
property PaintRight:Integer read FPaintRight
write SetPaintRight;
property PaintBottom:Integer read FPaintBottom write
SetPaintBottom;
property PaintTop:Integer read FPaintTop write SetPaintTop;
property EnablePaint:Boolean read FEnablePaint write
SetEnablePaint;
end;
Теперь остановимся подробнее на реализации метода WMPaint, а реализацию остальных членов класса смотрите в модуле. Итак из определения видно, что метод WMPaint вызывается когда нашему компоненту будет послано сообщение WM_Paint. В самом методе мы напишем код отрисовки компонента:
procedure TMyListBox.WMPaint(var Message:TWMPaint);
var DC:HDC;
BFunc:TBlendFunc;
begin
inherited;
if EnablePaint then
begin
FResult.Width:=Width;
FResult.Height:=Height;
FResult.Canvas.CopyRect(Rect(0,0,Width,Height),
Canvas,Rect(0,0,Width,Height));
DC:=FResult.Canvas.Handle;
BFunc.BlendOP:=$0;
BFunc.BlendFlags:=0;
BFunc.SourceConstantAlpha:=70;
BFunc.AlphaFormat:=0;
msimg32.AlphaBlend(DC,PaintLeft,PaintTop,PaintRight-PaintLeft,
PaintBottom-PaintTop,FTemp.Canvas.Handle,0,0,FTemp.Width,
FTemp.Height,BFunc);
Canvas.Draw(0,0,FResult);
end;
end;
Как видно из кода сперва директивой "inherited" мы передаем управление методу-предку нашего WMPaint, для того чтоб он отрисовал наш ListBox в нормальном состоянии. После, мы проверяем разрешение на отрисовку нашего выделяющего прямоугольника и если разрешение получено - рисуем его.
Итак. Класс создан, теперь его надо только вывести на форму. Для этого в реакции формы на создание запишем код:
Procedure TForm1.FormCreate(Sender:TObject);
begin
Back:=TBitmap.Create;
MyListBox:=TMyLIstBox.Create(Self);
MyLIstBox.Parent:=Self;
MyListbox.SetBounds(0,30,300,300);
Back.Width:=10;
Back.Height:=10;
Back.Canvas.Brush.Color:=clRed;
Back.Canvas.FillRect(REct(0,0,10,10));
MyLIstBox.FTemp.Assign(Back);
MyListBox.Items.Add('Testing1');
MyListBox.Items.Add('Testing1');
MyListBox.Items.Add('Testing1');
MyListBox.Items.Add('Testing1');
MyListBox.Items.Add('Testing1');
MyListBox.Items.Add('Testing1');
MyListBox.Items.Add('Testing1');
MyLIstBox.Visible:=True;
End;
Не забывая при этом в одной из секций класса TForm1 определить поля Back:TBitmap и MyListBox:TMyListBox.
Теперь после запуска приложения мы видим стандартный TListBox который пока еще ничем не блистает. Для того, чтобы получилось зрелище изображенное на рисунке нам надо реализовать реакции нашего компонента на события мыши таким образом:
procedure TForm1.ListBox1MouseDown(Sender: TObject;
Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
MyListBox.ItemIndex:=-1;
MyListbox.PaintLeft:=X;
MyListbox.PaintTop:=Y;
MyListbox.PaintRight:=X;
MyListbox.PaintBottom:=Y;
MyListBox.EnablePaint:=True;
end;
procedure TForm1.ListBox1MouseUp(Sender: TObject;
Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
MyListBox.ItemIndex:=-1;
MyListBox.PaintLeft:=0;
MyListBox.PaintRight:=0;
MyListBox.PaintTop:=0;
MyListBox.PaintBottom:=0;
MyListBox.EnablePaint:=False;
end;
procedure TForm1.ListBox1MouseMove(Sender: TObject;
Shift: TShiftState; X,
Y: Integer);
begin
MyListBox.ItemIndex:=-1;
MyListBox.PaintRight:=X;
MyListBox.PaintBottom:=Y;
end;
И не забываем назначить эти обработчики соответствующим событиям нашего компонента:
procedure TForm1.FormCreate(Sender: TObject);
begin
Back:=TBitmap.Create;
MyListBox:=TMyLIstBox.Create(Self);
MyLIstBox.Parent:=Self;
MyListbox.SetBounds(0,30,300,300);
MyLIstBox.OnMouseDown:=ListBox1MouseDown; //Mouse Down
MyLIstBox.OnMouseUp:=ListBox1MouseUp; // Mouse Up
MyLIstBox.OnMouseMove:=ListBox1MouseMove; // Mouse Move
Back.Width:=10;
Back.Height:=10;
Back.Canvas.Brush.Color:=clRed;
Back.Canvas.FillRect(REct(0,0,10,10));
MyLIstBox.FTemp.Assign(Back);
MyListBox.Items.Add('Testing1');
MyListBox.Items.Add('Testing1');
MyListBox.Items.Add('Testing1');
MyListBox.Items.Add('Testing1');
MyListBox.Items.Add('Testing1');
MyListBox.Items.Add('Testing1');
MyListBox.Items.Add('Testing1');
MyLIstBox.Visible:=True;
end;
Наконец после запуска этой редакции приложения мы с гордостью можем насладится XPstyle - выделением нашего компонента.
Послесловие
Конечно же это демонстрационное приложение не может претендовать на эффективность. Так на компьютере автора выделение больших областей проходило с заметным эффектом мерцания, который отнюдь не украшал приложение. Возможные выходы из этой ситуации - использование двойного буфера для отображения выделения, или же использование сообщения WM_NCPAINT, которое вызывается для отрисовки только части изображения, и которое можно настроить для обработки только изменяющихся областей изображения. Пример показан в том же листинге, но над ним еще надо поработать.
Листинг 2. Демонстрационное приложение
unit Main;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ComCtrls, ExtCtrls;
type
TMyListBox = class(TListBox)
private
FTemp:TBitmap;
FResult,FResult0:TBitmap;
FPaintLeft,FPaintTop,FPaintRight,FPaintBottom:Integer;
FEnablePaint:Boolean;
procedure WMPaint(var Message:TWMPaint);message WM_Paint;
procedure WMNCPaint(var Message:TWMNCPaint);message WM_NCPaint;
procedure SetPaintLeft(Value:Integer);
procedure SetPaintTop(Value:Integer);
procedure SetPaintRight(Value:Integer);
procedure SetPaintBottom(Value:Integer);
procedure SetEnablePaint(Value:Boolean);
public
procedure AfterConstruction;override;
procedure BeforeDestruction;override;
property PaintLeft:Integer read FPaintLeft write SetPaintLeft;
property PaintRight:Integer read FPaintRight write SetPaintRight;
property PaintBottom:Integer read FPaintBottom write SetPaintBottom;
property PaintTop:Integer read FPaintTop write SetPaintTop;
property EnablePaint:Boolean read FEnablePaint write SetEnablePaint;
end;
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
Image1: TImage;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure ListBox1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure ListBox1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure ListBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure FormDestroy(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
Back:TBitmap;
{ Private declarations }
public
MyLIstBox:TMyListBox;
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses msimg32,DebugUnit,Math;
{$R *.dfm}
procedure TMyListBox.AfterConstruction;
begin
inherited AfterConstruction;
Ftemp:=TBitmap.Create;
FResult:=TBitmap.Create;
FResult0:=TBitmap.Create;
FTemp.Width:=10;
FTemp.Height:=10;
FTemp.Canvas.Brush.Color:=clRed;
FTemp.Canvas.FillRect(REct(0,0,10,10));
FEnablePaint:=False;
end;
procedure TMyListBox.BeforeDestruction;
begin
FTemp.Free;
FResult.Free;
FREsult0.Free;
inherited BeforeDestruction;
end;
procedure TMyListBox.SetEnablePaint(Value:Boolean);
begin
FResult.Width:=Width;
FResult.Height:=Height;
if FEnablePaint<>Value then
begin
FEnablePaint:=Value;
Self.Invalidate;
end;
end;
procedure TMyListBox.SetPaintLeft(Value:Integer);
var P:TRect;
begin
if Value<>FPaintLeft then
begin
FPaintLeft:=Value;
Self.Invalidate;
end;
end;
procedure TMyListBox.SetPaintRight(Value:Integer);
var P,P0:TRect;
begin
if Value<>FPaintRight then
begin
P:=Rect(PaintLeft,PaintTop,Max(Value,FPaintRight),PaintBottom);
P0:=Rect(Min(FPaintRight,Value),PaintTop,Max(FPaintRight,Value),FPaintBottom);
Self.Perform(WM_NCPAINT,CreateRectRgnIndirect(P0),0);
InvalidateRect(Self.Handle,@P,True);
FPaintRight:=Value;
end;
end;
procedure TMyListBox.SetPaintBottom(Value:Integer);
var P,P0:TRect;
begin
if Value<>FPaintBottom then
begin
P:=Rect(PaintLeft,PaintTop,PaintRight,Max(FPaintBottom,Value));
P0:=Rect(PaintLeft,Min(FPaintBottom,Value),PaintRight,Max(FPaintBottom,Value));
Self.Perform(WM_NCPAINT,CreateRectRgnIndirect(P0),0);
InvalidateRect(Self.Handle,@P,True);
FPaintBottom:=Value;
end;
end;
procedure TMyListBox.SetPaintTop(Value:Integer);
var P:TRect;
begin
if Value<>FPaintTop then
begin
FPaintTop:=Value;
Self.Invalidate;
end;
end;
procedure TMyListBox.WMNCPaint(var Message:TWMNCPaint);
var R:TRect;
DC:HDC;
BFunc:TBlendFunc;
begin
inherited;
(*if EnablePaint then
begin
FillChar(R,SizeOf®,0);
GetRgnBox(Message.RGN,R);
// PrintStatus(Format('Top:%d Left:%d Bottom:%d Right:%d',[R.Top,R.Left,R.Bottom,R.Right]));
FResult0.Width:=R.Right-R.Left;
FResult0.Height:=R.Bottom-R.Top;
FResult0.Canvas.CopyRect(Rect(0,0,Width,Height),Canvas,R);
DC:=FResult0.Canvas.Handle;
BFunc.BlendOP:=$0;
BFunc.BlendFlags:=0;
BFunc.SourceConstantAlpha:=100;
BFunc.AlphaFormat:=0;
msimg32.AlphaBlend(DC,0,0,FResult0.Width,FResult0.Height,FTemp.Canvas.Handle,0,0,FTemp.Width,FTemp.Height,BFunc);
Canvas.Draw(R.Left,R.Top,FResult0);
end;*)
end;
procedure TMyListBox.WMPaint(var Message:TWMPaint);
var DC:HDC;
BFunc:TBlendFunc;
begin
inherited;
if EnablePaint then
begin
FResult.Width:=Width;
FResult.Height:=Height;
FResult.Canvas.CopyRect(Rect(0,0,Width,Height),Canvas,Rect(0,0,Width,Height));
DC:=FResult.Canvas.Handle;
BFunc.BlendOP:=$0;
BFunc.BlendFlags:=0;
BFunc.SourceConstantAlpha:=70;
BFunc.AlphaFormat:=0;
msimg32.AlphaBlend(DC,PaintLeft,PaintTop,PaintRight-PaintLeft,PaintBottom-PaintTop,FTemp.Canvas.Handle,0,0,FTemp.Width,FTemp.Height,BFunc);
Canvas.Draw(0,0,FResult);
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Back:=TBitmap.Create;
MyListBox:=TMyLIstBox.Create(Self);
MyLIstBox.Parent:=Self;
MyListbox.SetBounds(0,30,300,300);
MyLIstBox.OnMouseDown:=ListBox1MouseDown;
MyLIstBox.OnMouseUp:=ListBox1MouseUp;
MyLIstBox.OnMouseMove:=ListBox1MouseMove;
Back.Width:=10;
Back.Height:=10;
Back.Canvas.Brush.Color:=clRed;
Back.Canvas.FillRect(REct(0,0,10,10));
MyLIstBox.FTemp.Assign(Back);
MyListBox.Items.Add('Testing1');
MyListBox.Items.Add('Testing1');
MyListBox.Items.Add('Testing1');
MyListBox.Items.Add('Testing1');
MyListBox.Items.Add('Testing1');
MyListBox.Items.Add('Testing1');
MyListBox.Items.Add('Testing1');
MyLIstBox.Visible:=False;
end;
procedure TForm1.ListBox1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
MyListBox.ItemIndex:=-1;
MyListbox.PaintLeft:=X;
MyListbox.PaintTop:=Y;
MyListbox.PaintRight:=X;
MyListbox.PaintBottom:=Y;
MyListBox.EnablePaint:=True;
end;
procedure TForm1.ListBox1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
MyListBox.ItemIndex:=-1;
MyListBox.PaintLeft:=0;
MyListBox.PaintRight:=0;
MyListBox.PaintTop:=0;
MyListBox.PaintBottom:=0;
MyListBox.EnablePaint:=False;
end;
procedure TForm1.ListBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
MyListBox.ItemIndex:=-1;
MyListBox.PaintRight:=X;
MyListBox.PaintBottom:=Y;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
Back.Free;
MyLIstBox.Free;
end;
end.
Ja prosto ne znal sto tak ne lzja delat - eto prosto moi pervii forum gde ja zaregestrirovalsja.
Kstati ja nashol tot sait gde ta infa lezit no ce to ja ne fega ne ponel.
MOzet objasniti takomu laimeru kak ja.
Счастливые обладатели Windows XP могут позволить себе такие прелести современного интерфейса как полупрозрачные окна, работа с альфа каналом и т.п. В то время как пользователи 98-го довольствуются стандартным "серо-чёрным" десктопом или в лучшем случае его "цветным" оформлением и красивыми заставками. Эта статья призвана помочь разработчикам ПО для Windows 98 обеспечить свои приложения теми прелестями, которые стали вседоступными только в XP
Постановка задачи
Большинство из вас наверное уже видело как выделяется группа файлов в Windows XP. Здесь как и в множестве других графических операций используется эффект полупрозрачности. Сейчас мы постараемся воспроизвести его на Windows 98.
С чего начать
Windows 98 и все последующие версии Windows имеют в своем составе библиотеку под названием msimg32.dll. Которая и предоставляет нам функции для работы над полупрозрачными изображениями. В ее состав входят такие основные функции:
Function TransparentBlt( DestDC:HDC; nXOriginDest, nYOriginDest, nWidthOriginDest, nHeightOriginDest:Integer; SrcDC:HDC; nXOriginSrc, nYOriginSrc, nWidthOriginSrc, nHeightOriginSrc:Integer; crTransparent:Integer):Integer;
function GradientFillRect( DC:HDC; pVertex:PTriVertex; dwNumVertex:Integer; pMesh:PGradientRect; dwNumMesh:Integer; dwMode:Integer):Integer;
function GradientFillTri( DC:HDC; pVertex:PTriVertex; dwNumVertex:Integer; pMesh:PGradientTriangle; dwNumMesh:Integer; dwMode:Integer):Integer;
function AlphaBlend( DestDC:HDC; nXOriginDest, nYOriginDest, nWidthDest, nHeightDest:Integer; SrcDC:HDC; nXOriginSrc, nYOriginSrc, nWidthSrc, nHeightSrc:Integer; BlendFunc:TBlendFunc):Boolean;
Для решения поставленной задачи мы воспользуемся функцией AlphaBlend, которая в качестве параметров принимает значения:
DestDC - идентификатор холста на который будет накладываться изображение
nXDest, nYDest, nWidthDest, nHeightDest - координаты области холста на который будет накладываться изображение. Если размеры накладываемых изображений не совпадают то проводится маштабироваение.
SrcDC - идентификатор накладываемого изображения.
nXSrc, nYSrc, nWidthSrc, nHeightSrc - координаты накладываемой области
BlendFunc - структура параметров альфа смешивания.
BlendFunc имеет тип TBlendFunc который определяется как:
TBlendFunc = packed record
BlendOP:Byte;
BlendFlags:Byte;
SourceConstantAlpha:Byte;
AlphaFormat:Byte;
end;
PBlendFunc = ^TBlendFunc;
Где BlendOP - операция альфа смешивания, BlendFlags - флаги операции, AlphaFormat - формат операции, SourceConstantAlpha - константа определяющая степень прозрачности.
Приложение
Для разработки нашего приложения мы сперва запустим Borland Delphi и перейдем в окон редактирования исходного кода. Здесь нам потребуется создать новый компонент - наследник TListBox в котором мы доопределим:
Координаты вершин прямоугольника выделения
Свойство EnablePaint разрешающее(запрещающее) отрисовку прямоугольника выделения.
Метод WMPaint который и будет отрисовывать изображение
Поле FTemp:TBitmap, которое содержит фон отрисовываемого прямоугольника.
Шаблон этого класса будет выгладеть следующим образом:
TMyListBox = class(TListBox)
private
FTemp:TBitmap;
FResult:TBitmap;
FPaintLeft,FPaintTop,FPaintRight,FPaintBottom:Integer;
FEnablePaint:Boolean;
procedure WMPaint(var Message:TWMPaint);message WM_Paint;
procedure SetPaintLeft(Value:Integer);
procedure SetPaintTop(Value:Integer);
procedure SetPaintRight(Value:Integer);
procedure SetPaintBottom(Value:Integer);
procedure SetEnablePaint(Value:Boolean);
public
procedure AfterConstruction;override;
procedure BeforeDestruction;override;
property PaintLeft:Integer read FPaintLeft write SetPaintLeft;
property PaintRight:Integer read FPaintRight
write SetPaintRight;
property PaintBottom:Integer read FPaintBottom write
SetPaintBottom;
property PaintTop:Integer read FPaintTop write SetPaintTop;
property EnablePaint:Boolean read FEnablePaint write
SetEnablePaint;
end;
Теперь остановимся подробнее на реализации метода WMPaint, а реализацию остальных членов класса смотрите в модуле. Итак из определения видно, что метод WMPaint вызывается когда нашему компоненту будет послано сообщение WM_Paint. В самом методе мы напишем код отрисовки компонента:
procedure TMyListBox.WMPaint(var Message:TWMPaint);
var DC:HDC;
BFunc:TBlendFunc;
begin
inherited;
if EnablePaint then
begin
FResult.Width:=Width;
FResult.Height:=Height;
FResult.Canvas.CopyRect(Rect(0,0,Width,Height),
Canvas,Rect(0,0,Width,Height));
DC:=FResult.Canvas.Handle;
BFunc.BlendOP:=$0;
BFunc.BlendFlags:=0;
BFunc.SourceConstantAlpha:=70;
BFunc.AlphaFormat:=0;
msimg32.AlphaBlend(DC,PaintLeft,PaintTop,PaintRight-PaintLeft,
PaintBottom-PaintTop,FTemp.Canvas.Handle,0,0,FTemp.Width,
FTemp.Height,BFunc);
Canvas.Draw(0,0,FResult);
end;
end;
Как видно из кода сперва директивой "inherited" мы передаем управление методу-предку нашего WMPaint, для того чтоб он отрисовал наш ListBox в нормальном состоянии. После, мы проверяем разрешение на отрисовку нашего выделяющего прямоугольника и если разрешение получено - рисуем его.
Итак. Класс создан, теперь его надо только вывести на форму. Для этого в реакции формы на создание запишем код:
Procedure TForm1.FormCreate(Sender:TObject);
begin
Back:=TBitmap.Create;
MyListBox:=TMyLIstBox.Create(Self);
MyLIstBox.Parent:=Self;
MyListbox.SetBounds(0,30,300,300);
Back.Width:=10;
Back.Height:=10;
Back.Canvas.Brush.Color:=clRed;
Back.Canvas.FillRect(REct(0,0,10,10));
MyLIstBox.FTemp.Assign(Back);
MyListBox.Items.Add('Testing1');
MyListBox.Items.Add('Testing1');
MyListBox.Items.Add('Testing1');
MyListBox.Items.Add('Testing1');
MyListBox.Items.Add('Testing1');
MyListBox.Items.Add('Testing1');
MyListBox.Items.Add('Testing1');
MyLIstBox.Visible:=True;
End;
Не забывая при этом в одной из секций класса TForm1 определить поля Back:TBitmap и MyListBox:TMyListBox.
Теперь после запуска приложения мы видим стандартный TListBox который пока еще ничем не блистает. Для того, чтобы получилось зрелище изображенное на рисунке нам надо реализовать реакции нашего компонента на события мыши таким образом:
procedure TForm1.ListBox1MouseDown(Sender: TObject;
Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
MyListBox.ItemIndex:=-1;
MyListbox.PaintLeft:=X;
MyListbox.PaintTop:=Y;
MyListbox.PaintRight:=X;
MyListbox.PaintBottom:=Y;
MyListBox.EnablePaint:=True;
end;
procedure TForm1.ListBox1MouseUp(Sender: TObject;
Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
MyListBox.ItemIndex:=-1;
MyListBox.PaintLeft:=0;
MyListBox.PaintRight:=0;
MyListBox.PaintTop:=0;
MyListBox.PaintBottom:=0;
MyListBox.EnablePaint:=False;
end;
procedure TForm1.ListBox1MouseMove(Sender: TObject;
Shift: TShiftState; X,
Y: Integer);
begin
MyListBox.ItemIndex:=-1;
MyListBox.PaintRight:=X;
MyListBox.PaintBottom:=Y;
end;
И не забываем назначить эти обработчики соответствующим событиям нашего компонента:
procedure TForm1.FormCreate(Sender: TObject);
begin
Back:=TBitmap.Create;
MyListBox:=TMyLIstBox.Create(Self);
MyLIstBox.Parent:=Self;
MyListbox.SetBounds(0,30,300,300);
MyLIstBox.OnMouseDown:=ListBox1MouseDown; //Mouse Down
MyLIstBox.OnMouseUp:=ListBox1MouseUp; // Mouse Up
MyLIstBox.OnMouseMove:=ListBox1MouseMove; // Mouse Move
Back.Width:=10;
Back.Height:=10;
Back.Canvas.Brush.Color:=clRed;
Back.Canvas.FillRect(REct(0,0,10,10));
MyLIstBox.FTemp.Assign(Back);
MyListBox.Items.Add('Testing1');
MyListBox.Items.Add('Testing1');
MyListBox.Items.Add('Testing1');
MyListBox.Items.Add('Testing1');
MyListBox.Items.Add('Testing1');
MyListBox.Items.Add('Testing1');
MyListBox.Items.Add('Testing1');
MyLIstBox.Visible:=True;
end;
Наконец после запуска этой редакции приложения мы с гордостью можем насладится XPstyle - выделением нашего компонента.
Послесловие
Конечно же это демонстрационное приложение не может претендовать на эффективность. Так на компьютере автора выделение больших областей проходило с заметным эффектом мерцания, который отнюдь не украшал приложение. Возможные выходы из этой ситуации - использование двойного буфера для отображения выделения, или же использование сообщения WM_NCPAINT, которое вызывается для отрисовки только части изображения, и которое можно настроить для обработки только изменяющихся областей изображения. Пример показан в том же листинге, но над ним еще надо поработать.
Листинг 2. Демонстрационное приложение
unit Main;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ComCtrls, ExtCtrls;
type
TMyListBox = class(TListBox)
private
FTemp:TBitmap;
FResult,FResult0:TBitmap;
FPaintLeft,FPaintTop,FPaintRight,FPaintBottom:Integer;
FEnablePaint:Boolean;
procedure WMPaint(var Message:TWMPaint);message WM_Paint;
procedure WMNCPaint(var Message:TWMNCPaint);message WM_NCPaint;
procedure SetPaintLeft(Value:Integer);
procedure SetPaintTop(Value:Integer);
procedure SetPaintRight(Value:Integer);
procedure SetPaintBottom(Value:Integer);
procedure SetEnablePaint(Value:Boolean);
public
procedure AfterConstruction;override;
procedure BeforeDestruction;override;
property PaintLeft:Integer read FPaintLeft write SetPaintLeft;
property PaintRight:Integer read FPaintRight write SetPaintRight;
property PaintBottom:Integer read FPaintBottom write SetPaintBottom;
property PaintTop:Integer read FPaintTop write SetPaintTop;
property EnablePaint:Boolean read FEnablePaint write SetEnablePaint;
end;
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
Image1: TImage;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure ListBox1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure ListBox1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure ListBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure FormDestroy(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
Back:TBitmap;
{ Private declarations }
public
MyLIstBox:TMyListBox;
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses msimg32,DebugUnit,Math;
{$R *.dfm}
procedure TMyListBox.AfterConstruction;
begin
inherited AfterConstruction;
Ftemp:=TBitmap.Create;
FResult:=TBitmap.Create;
FResult0:=TBitmap.Create;
FTemp.Width:=10;
FTemp.Height:=10;
FTemp.Canvas.Brush.Color:=clRed;
FTemp.Canvas.FillRect(REct(0,0,10,10));
FEnablePaint:=False;
end;
procedure TMyListBox.BeforeDestruction;
begin
FTemp.Free;
FResult.Free;
FREsult0.Free;
inherited BeforeDestruction;
end;
procedure TMyListBox.SetEnablePaint(Value:Boolean);
begin
FResult.Width:=Width;
FResult.Height:=Height;
if FEnablePaint<>Value then
begin
FEnablePaint:=Value;
Self.Invalidate;
end;
end;
procedure TMyListBox.SetPaintLeft(Value:Integer);
var P:TRect;
begin
if Value<>FPaintLeft then
begin
FPaintLeft:=Value;
Self.Invalidate;
end;
end;
procedure TMyListBox.SetPaintRight(Value:Integer);
var P,P0:TRect;
begin
if Value<>FPaintRight then
begin
P:=Rect(PaintLeft,PaintTop,Max(Value,FPaintRight),PaintBottom);
P0:=Rect(Min(FPaintRight,Value),PaintTop,Max(FPaintRight,Value),FPaintBottom);
Self.Perform(WM_NCPAINT,CreateRectRgnIndirect(P0),0);
InvalidateRect(Self.Handle,@P,True);
FPaintRight:=Value;
end;
end;
procedure TMyListBox.SetPaintBottom(Value:Integer);
var P,P0:TRect;
begin
if Value<>FPaintBottom then
begin
P:=Rect(PaintLeft,PaintTop,PaintRight,Max(FPaintBottom,Value));
P0:=Rect(PaintLeft,Min(FPaintBottom,Value),PaintRight,Max(FPaintBottom,Value));
Self.Perform(WM_NCPAINT,CreateRectRgnIndirect(P0),0);
InvalidateRect(Self.Handle,@P,True);
FPaintBottom:=Value;
end;
end;
procedure TMyListBox.SetPaintTop(Value:Integer);
var P:TRect;
begin
if Value<>FPaintTop then
begin
FPaintTop:=Value;
Self.Invalidate;
end;
end;
procedure TMyListBox.WMNCPaint(var Message:TWMNCPaint);
var R:TRect;
DC:HDC;
BFunc:TBlendFunc;
begin
inherited;
(*if EnablePaint then
begin
FillChar(R,SizeOf®,0);
GetRgnBox(Message.RGN,R);
// PrintStatus(Format('Top:%d Left:%d Bottom:%d Right:%d',[R.Top,R.Left,R.Bottom,R.Right]));
FResult0.Width:=R.Right-R.Left;
FResult0.Height:=R.Bottom-R.Top;
FResult0.Canvas.CopyRect(Rect(0,0,Width,Height),Canvas,R);
DC:=FResult0.Canvas.Handle;
BFunc.BlendOP:=$0;
BFunc.BlendFlags:=0;
BFunc.SourceConstantAlpha:=100;
BFunc.AlphaFormat:=0;
msimg32.AlphaBlend(DC,0,0,FResult0.Width,FResult0.Height,FTemp.Canvas.Handle,0,0,FTemp.Width,FTemp.Height,BFunc);
Canvas.Draw(R.Left,R.Top,FResult0);
end;*)
end;
procedure TMyListBox.WMPaint(var Message:TWMPaint);
var DC:HDC;
BFunc:TBlendFunc;
begin
inherited;
if EnablePaint then
begin
FResult.Width:=Width;
FResult.Height:=Height;
FResult.Canvas.CopyRect(Rect(0,0,Width,Height),Canvas,Rect(0,0,Width,Height));
DC:=FResult.Canvas.Handle;
BFunc.BlendOP:=$0;
BFunc.BlendFlags:=0;
BFunc.SourceConstantAlpha:=70;
BFunc.AlphaFormat:=0;
msimg32.AlphaBlend(DC,PaintLeft,PaintTop,PaintRight-PaintLeft,PaintBottom-PaintTop,FTemp.Canvas.Handle,0,0,FTemp.Width,FTemp.Height,BFunc);
Canvas.Draw(0,0,FResult);
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Back:=TBitmap.Create;
MyListBox:=TMyLIstBox.Create(Self);
MyLIstBox.Parent:=Self;
MyListbox.SetBounds(0,30,300,300);
MyLIstBox.OnMouseDown:=ListBox1MouseDown;
MyLIstBox.OnMouseUp:=ListBox1MouseUp;
MyLIstBox.OnMouseMove:=ListBox1MouseMove;
Back.Width:=10;
Back.Height:=10;
Back.Canvas.Brush.Color:=clRed;
Back.Canvas.FillRect(REct(0,0,10,10));
MyLIstBox.FTemp.Assign(Back);
MyListBox.Items.Add('Testing1');
MyListBox.Items.Add('Testing1');
MyListBox.Items.Add('Testing1');
MyListBox.Items.Add('Testing1');
MyListBox.Items.Add('Testing1');
MyListBox.Items.Add('Testing1');
MyListBox.Items.Add('Testing1');
MyLIstBox.Visible:=False;
end;
procedure TForm1.ListBox1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
MyListBox.ItemIndex:=-1;
MyListbox.PaintLeft:=X;
MyListbox.PaintTop:=Y;
MyListbox.PaintRight:=X;
MyListbox.PaintBottom:=Y;
MyListBox.EnablePaint:=True;
end;
procedure TForm1.ListBox1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
MyListBox.ItemIndex:=-1;
MyListBox.PaintLeft:=0;
MyListBox.PaintRight:=0;
MyListBox.PaintTop:=0;
MyListBox.PaintBottom:=0;
MyListBox.EnablePaint:=False;
end;
procedure TForm1.ListBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
MyListBox.ItemIndex:=-1;
MyListBox.PaintRight:=X;
MyListBox.PaintBottom:=Y;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
Back.Free;
MyLIstBox.Free;
end;
end.
