Отправляет email-рассылки с помощью сервиса Sendsay

Карьера и развитие для начинающих программистов

Рассылка закрыта

При закрытии подписчики были переданы в рассылку "О карьере и профессиональном развитии IT-специалистов" на которую и рекомендуем вам подписаться.

Вы можете найти рассылки сходной тематики в Каталоге рассылок.

←   Июль 2004   →
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
Автор
Вячеслав Панкратов

Статистика

3.166 подписчиков
-4 за неделю
←   Все выпуски   →

Программирование для начинающих и не только


Информационный Канал Subscribe.Ru

XP стиль своими руками

Счастливые обладатели 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(R),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.
http://subscribe.ru/
E-mail: ask@subscribe.ru		 Адрес подписки
 Отписаться
В избранное