interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Spin, XPMan;
type
TForm1 = class(TForm)
Button1: TButton;
Label1: TLabel;
ColorDialog1: TColorDialog;
SpinEdit1: TSpinEdit;
Label2: TLabel;
XPManifest1: TXPManifest;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure SpinEdit1Change(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
BM:TBitmap; { картинка, в которой хранится изображение экрана }
BM2:TBitmap; { картинка, в которой хранится фон окна }
Moving:Boolean; { а эта переменная равна True, если окно в данный момент
перетаскивается пользователем }
procedure WMEraseBkgnd(var Msg:TWMEraseBkgnd);message WM_EraseBkgnd;
procedure WMPaint(var Msg:TWMPaint);message WM_Paint;
procedure WMMove(var Msg:TMessage);message WM_Move; // Если вместо WM_Move поставить
// WM_WindowPosChanged, ничего
// не изменится.
procedure WMEnterSizeMove(var Msg:TMessage);message WM_EnterSizeMove;
procedure WMExitSizeMove(var Msg:TMessage);message WM_ExitSizeMove;
public
{ Public declarations }
end;
var
Form1: TForm1;
const Transparency:Integer=40; { Прозрачность в процентах. Должна быть от 0 до 100 }
TranspColor:TColor=clBlack; { Цвет окна }
DelayTime:Integer=400; { Время задержки в миллисекундах }
implementation
{$R *.DFM}
type PRGBArray=^TRGBArray;
TRGBArray=array[0..1000000] of TRGBTriple;
{ Вместо 1000000 может быть любое число, даже 0, только тогда придётся
отключить проверку диапазона. Экземпляры массивов этого типа всё равно
не создаются }
procedure Delay(DelayTime:Integer);
var TicksNow:Integer;
begin
TicksNow:=GetTickCount;
repeat
Application.ProcessMessages
until GetTickCount-TicksNow>=DelayTime
end;
{ Эта процедура приостанавливает линейное выполнение программы на заданное число
миллисекунд, не прерывая, тем не менее, фоновых процессов. }
procedure TForm1.WMEraseBkgnd;
begin
Msg.Result:=1
{ В общем-то, мы ничего не сделали в ответ на это сообщение, но
зато послали отчёт, что всё сделано в лучшем виде. Если это
будут читать маленькие дети, то пусть они помнят, что обманывать
всё равно нехорошо, хоть я и показываю плохой пример. }
end;
procedure TForm1.WMPaint;
var DC:HDC; // Контекст устройства. Он нам понадобится целых два раза
PS:TPaintStruct; // А сюда будут записаны те самые ЦУ, которые мы проигнорируем.
CW,CH,CX,CY:Integer; // размеры клиентской части окна
SL:PRGBArray; // Указатель на строку пикселей
X,Y:Integer; // Нужно для организации циклов
begin
CW:=ClientWidth;
CH:=ClientHeight; // На всякий случай запоминаем все необходимые размеры.
CX:=ClientOrigin.X; // Может быть, после того, как окно будет спрятано, они изменятся.
CY:=ClientOrigin.Y; // А может, и нет. Проверьте сами, если не лень
if not Moving then // Этот кусок кода не стоит выполнять, когда окно
begin // перетаскивается пользователем.
ShowWindow(Handle,SW_Hide); // Прячем окно. Кстати, я пробовал не прятать окно,
// а использовать SetWindowRgn, чтобы вырезать его
// клиентскую часть. Почему-то не сработало.
// Что касается этого механизма, то он не будет
// работать с окнами типа MDIChild, потому что
// такие окна нельзя спрятать.
SetActiveWindow(0); // Эта строка заслуживает более подробного комментария.
// Когда наше окно прячется, будучи активным, то активным
// становится другое окно. Цвет его заголовка меняется, и
// в результате не выполнена главная задача: сделать так,
// чтобы на экране было всё то же самое, но без нашего окна.
// Поэтому делаем все окна неактивными, и получаем нужный
// результат. Если же наше окно было неактивным, то эта
// строчка никому не мешает (сам не знаю, почему, но факт!)
Delay(400); // Ждём и молимся, чтобы все окна успели перерисоваться!
DC:=GetDC(0); // Получаем контекст рабочего стола
BitBlt(BM.Canvas.Handle,0,0,BM.Width,BM.Height,DC,0,0,SrcCopy);
ReleaseDC(0,DC); // Больше этот контекст нам не нужен, о чём мы и сообщаем
end;
// Начиная с этого места, код выполняется при любом значении Moving
BM2.Width:=CW+1; // Ну, это даже не интересно рассказывать...
BM2.Height:=CH+1; // Просто готовим картинку к тому, что сейчас будем рисовать
BM2.PixelFormat:=pf24bit;
BM2.Canvas.Draw(-CX,-CY,BM);
for Y:=0 to CH do // А в этих циклах на записанный нами кусок экрана
begin // Накладывается светофильтр
SL:=BM2.ScanLine[Y];
for X:=0 to CW do
begin
SL[X].rgbtRed:=(Transparency*SL[X].rgbtRed+(100-Transparency)*GetRValue(TranspColor)) div 100;
SL[X].rgbtGreen:=(Transparency*SL[X].rgbtGreen+(100-Transparency)*GetGValue(TranspColor)) div 100;
SL[X].rgbtBlue:=(Transparency*SL[X].rgbtBlue+(100-Transparency)*GetBValue(TranspColor)) div 100
{ Предыдущие три строчки - реализация алгоритма смешения цветов
Pr:=(Pa*Wa+Pb*Wb)/(Wa+Wb), где Pr - результирующий цвет,
Pa и Pb - исходные цвета, Wa и Wb - веса этих цветов.
У нас в качестве Pa берётся цвет пикселя скопированной с экрана картинки,
В качестве Pb - заранее заданный цвет TranspColor, Wa=Transparency,
Wb=100-Transparency. Очевидно, что эту операцию необходимо выполнить для
каждого из основных цветов в отдельности.
Здесь открывается широкое поле для деятельности. Можно, например, сделать
Transparency не постоянным, а зависящим от координаты - получится градиентная
прозрачность. Или можно в качестве Pb взять не фиксированный цвет, а цвет
пикселя другой картинки - получится окно, фоном которого служит
полупрозрачная картинка. В конце концов, можно изменить алгоритм смешения
цветов, и тогда откроются новые возможности.
Кстати, вот пример градиентной прозрачности:
SL[X].rgbtRed:=((CH-Y)*SL[X].rgbtRed+Y*GetRValue(TranspColor)) div CH;
SL[X].rgbtGreen:=((CH-Y)*SL[X].rgbtGreen+Y*GetGValue(TranspColor)) div CH;
SL[X].rgbtBlue:=((CH-Y)*SL[X].rgbtBlue+Y*GetBValue(TranspColor)) div CH;
Хочу добавить, что это смотрится нормально только в режимах True Color.
High Color для этого недостаточно. А в режимах, худших, чем High Color,
полупрозрачные окна выглядят страшнее, чем ядерная война.
}
end
end;
ShowWindow(Handle,SW_Show); // Снова показываем окно
DC:=BeginPaint(Handle,PS); // Получаем разрешение начать перерисовку вместе с ЦУ.
// Кстати, если разобраться с исходниками стандартных
// модулей Delphi, то видно, что их авторы тоже
// проигнорировали все ЦУ. Наводит на размышления...
BitBlt(DC,0,0,BM2.Width,BM2.Height,BM2.Canvas.Handle,0,0,SrcCopy); // Рисуем получившуюся картинку
Msg.DC:=DC; // Эти две строчки учитывают особенности обработки WM_Paint в Delphi.
inherited; // Windows всегда посылает это сообщение с параметром wParam=0.
// Обработчик Delphi сделан так, что он может обрабатывать это
// сообщение при wParam<>0. В этом случае этот параметр интерпретируется
// как дескриптор контекста, BeginPaint и EndPaint не вызываются.
// Это позволяет писать вот такие обработчики.
EndPaint(Handle,PS) // Ну, в общем-то и всё...
end;
procedure TForm1.WMMove;
begin
Invalidate; // Всё, пора перерисовываться
inherited
end;
procedure TForm1.WMEnterSizeMove;
begin
Moving:=True;
inherited
end;
procedure TForm1.WMExitSizeMove;
begin
inherited;
Moving:=False
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
BM:=TBitmap.Create;
BM.Width:=GetSystemMetrics(SM_CXScreen); // Так мы узнаём размеры экрана. В принципе,
BM.Height:=GetSystemMetrics(SM_CYScreen); // если TaskBar виден постоянно, то нам,
// казалось бы, нужно запоминать несколько
// меньшую часть экрана. Но окна, не
// имеющие рамки и заголовка, могут занимать
// и эту область, а когда они занимают,
// то и нормальные окна тоже могут
// покушаться на эту территторию. Так что
// не будем мелочиться.
BM.PixelFormat:=pf24bit;
BM2:=TBitmap.Create;
Moving:=False
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if ColorDialog1.Execute then
begin
Invalidate
end
end;
procedure TForm1.SpinEdit1Change(Sender: TObject);
begin
Invalidate
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
BM.Free;
BM2.Free
end;
end.
04.04.2006, 20:53
Линейный вид
