Модераторы: Snowy, bartram, MetalFan, bems, Poseidon, Riply
  

Поиск:

Ответ в темуСоздание новой темы Создание опроса
> О прозрачных формах, и разных эффектах 
:(
    Опции темы
SoWa
Дата 4.6.2005, 03:05 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Харекришна
****


Профиль
Группа: Комодератор
Сообщений: 2422
Регистрация: 18.10.2004
Где: Екатеринбург

Репутация: 2
Всего: 74



Как сделать полупрозрачное окно


ТЕОРИЯ:

Предисловие:
Недавно поднималась тема о прозрачности окна и непрозрачности компонентов. Решения были разные. Представляю вашему вниманию еще одно решение с улучшением- наложением светофильтров. Окно программы будет не просто прозрачным, но и цветным.

Прежде всего, хочу предупредить, что этот текст рассчитан на людей, знакомых с функциями WinAPI и сообщениями Windows и поэтому вряд ли будет полезен тем, кто предпочитает ограничиваться работой на уровне компонентов Delphi.

Теперь ещё два предупреждения: во первых, полупрозрачное окно иногда перерисовывается не совсем правильно. Во-вторых, эта программа написана только для демонстрации самого принципа создания полупрозрачных окон и кое-что в ней можно (и иногда даже нужно) улучшить.

Внутренняя схема перерисовки окон в Windows такова, что каждый раз перерисовывается только та его часть, которая не закрыта другими окнами и, следовательно, видна на экране. Это ускоряет процесс обновления экрана. Но полупрозрачное окно должно каким-то образом получать информацию о том, что нарисовано под ним. Здесь мы вступаем в противоречие с правилами Windows, поэтому следует прибегнуть к некоторому обману. При необходимости перерисовать полупрозрачное окно надо это окно ненадолго убрать с экрана. Как только все нижележащие окна будут перерисованы, надо запомнить ту область экрана, которая будет закрыта окном, вновь вывести на экран это окно и отрисовать его с учётом сохранённой картинки. Первая трудность на этом пути - как узнать, что перерисовка всех окон закончилась? Самый примитивный способ- подождать! Скажу только, что времени задержки 400 мс, которое установлено в этом примере вполне хватило. Вторая трудность - если вдруг окно, лежащее под полупрозрачным, обновилось, то это не приведёт сразу же к перерисовке этого окна.

Теперь о том, как осуществить всё это на практике. Перерисовка окна определяется обработкой одного из двух сообщений: WM_EraseBkgnd и WM_Paint. WM_Paint лучше вот почему: Во-первых, WM_EraseBkgnd может посылаться по несколько раз, соответственно окно перерисовывается до нескольких раз подряд. Во-вторых, между WM_EraseBkgnd и WM_Paint есть существенная разница: в первом случае Windows сам определяет, какая часть окна должна перерисоваться, и рисовать за пределами этой части просто не разрешает. А полупрозрачное окно, вообще говоря, обладает нетрадиционной точкой зрения на этот вопрос, что и приводит к конфликтам, особенно тогда, когда полупрозрачное окно частично закрыто другими окнами. Что же касается WM_Paint, то и тут Windows, конечно же, держит всё под контролем и тоже следит за тем, какая область окна должна быть перерисована. Однако, к счастью для полупрозрачных окон, это всё не выливается в прямые запреты, как в случае с WM_EraseBkgnd, здесь Windows ограничивается только выдачей ценных указаний через BeginPaint и TPaintStruct. Ну, а теперь мы отрисовываем окно целиком. И наконец, в-третьих, Windows зачем-то генерирует WM_EraseBkgnd после выполнения ShowWindow, поэтому попытка спрятать окно при обработке этого сообщения приведёт к бесконечной рекурсии. Впрочем, пренебрегать WM_EraseBkgnd тоже не стоит. Дело в том, что во время запуска программы этому процессу, видимо, присваивается повышенный приоритет. Это приводит к тому, что наше окно начинает рисоваться, Windows посылает WM_EraseBkgnd, стандартная процедура обработки этого события закрашивает всю клиентскую часть окна красивым серым цветом (как обычно), затем обрабатывается WM_Paint, в котором окно прячется с экрана, после чего остальные окна должны быстро перерисоваться и, когда пройдёт заданное время, программа посмотрит, что там нарисовано, начнёт наложение светофильтра... А окна-то не успели перерисоваться! Программа увидит своё собственное окно, которое мы не успели стереть. Это нам не надо, поэтому, чтобы не увеличивать время ожидания, нужно заблокировать вызов стандартного обработчика WM_EraseBkgnd. Это, естественно, никак не отразится на скорости перерисовки остальных окон, но ведь и само окно ничего не нарисует на экране, и после ожидания программа увидит то, что надо.

И последний штрих: при перемещении окна Windows, во избежание ненужных действий, не запускает механизм перерисовки, а просто переносит изображение с одного места на другое. Для полупрозрачных окон это недопустимо, изображение должно обновляться при каждом переносе. Для этого надо отслеживать сообщение WM_Move, которое возникает в таких случаях. И, соответственно, запускать перерисовку окна. Если WM_Move вам не подходит , вы можете использовать WM_WindowPosChanged. Я не заметил разницы...

Проблема заключается в том, что в некоторых версиях системы при перемещении окна не рисуется рамка, а каждый раз происходит перерисовка всего окна целиком. То же самое происходит и при изменении размеров окна. Так происходит, например, в Win NT и в Win95 при установленном MS Plus! Ключ к решению проблемы лежит в обработке сообщений WM_EnterSizeMove и WM_ExitSizeMove. Нужно завести переменную типа boolean, которая будет изменяться при начале перетаскивания с False на True и наоборот при его завершении. Соответственно обработчик WM_Paint должен следить за этой переменной и не выполнять задержку. Проблема - как узнать, что должно быть под окном. Если каждый раз запоминать не только нужную часть экрана, а весь экран целиком, то к моменту входа в режим перетаскивания программа будет обладать всей необходимой информацией о том, что там внизу. Теперь надо будет только вырезать нужный кусок. Главный недостаток такого подхода - программа должна быть, как пионер, всегда готова к началу перетаскивания и всегда сохранять экран целиком, что приведёт к дополнительному расходу памяти. Но от этого тоже можно избавиться, храня только нужный кусочек экрана (пока не реализовано).

ПРАКТИКА:
Бросим на форму Button, SpinEdit, ColorDialog.

Потом приводим код к такому состоянию:
Код

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Spin;

type
  TForm1 = class(TForm)
    Button1: TButton;
    ColorDialog1: TColorDialog;
    SpinEdit1: TSpinEdit;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure SpinEdit1Change(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    BM:TBitmap;
    BM2:TBitmap;
    Moving:Boolean;
    procedure WMEraseBkgnd(var Msg:TWMEraseBkgnd);message WM_EraseBkgnd;
    procedure WMPaint(var Msg:TWMPaint);message WM_Paint;
    procedure WMMove(var Msg:TMessage);message WM_Move;


    procedure WMEnterSizeMove(var Msg:TMessage);message WM_EnterSizeMove;
    procedure WMExitSizeMove(var Msg:TMessage);message WM_ExitSizeMove;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  TranspColor: TColor;
   Transparency:Integer=40;
const
      DelayTime:Integer=400;

implementation

{$R *.DFM}

type PRGBArray=^TRGBArray;
     TRGBArray=array[0..1000000] of TRGBTriple;


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);


     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;

   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
      end
    end;

   ShowWindow(Handle,SW_Show);
   DC:=BeginPaint(Handle,PS);

   BitBlt(DC,0,0,BM2.Width,BM2.Height,BM2.Canvas.Handle,0,0,SrcCopy);

   Msg.DC:=DC;
   inherited;

   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);
  BM.PixelFormat:=pf24bit;
  BM2:=TBitmap.Create;
  Moving:=False
 end;

procedure TForm1.Button1Click(Sender: TObject);
 begin
  if ColorDialog1.Execute then
   begin
    TranspColor:=ColorDialog1.Color;
    Invalidate
   end
 end;

procedure TForm1.SpinEdit1Change(Sender: TObject);
 begin
  Transparency:=SpinEdit1.Value;
  Invalidate
 end;

procedure TForm1.FormDestroy(Sender: TObject);
 begin
  BM.Free;
  BM2.Free
 end;

end. 


Приведенный код без комментариев. Они все в присоединенном файле. Дерзайте.

Послесловие:
Тут довольно много некорректного кода (по причине того, что я много еще не знаю).
Просьба все улучшения выкладывать в этой теме (без флейма, плз).
В примере добавлены два label`а, чтобы показать, что их свойство Transparent работает.
И еще- попробуйте в SpinEdit добавить ноликов, чтобы значение выходило за «100», будет красиво!

Помогли- DelphiKingdom

Это сообщение отредактировал(а) SoWa - 4.6.2005, 03:12

Присоединённый файл ( Кол-во скачиваний: 517 )
Присоединённый файл  ColorTransp.zip 4,84 Kb


--------------------
Всем добра smile
PM MAIL ICQ Skype   Вверх
Poseidon
Дата 11.6.2005, 02:20 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Delphi developer
****


Профиль
Группа: Комодератор
Сообщений: 5273
Регистрация: 4.2.2005
Где: Гомель, Беларусь

Репутация: 10
Всего: 133



Еще информация по теме: FAQ - Прозрачность формы


--------------------
Если хочешь, что бы что-то работало - используй написанное, 
если хочешь что-то понять - пиши сам...
PM MAIL ICQ   Вверх
RaIDeR
Дата 27.7.2005, 13:32 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Шустрый
*


Профиль
Группа: Участник
Сообщений: 116
Регистрация: 20.6.2005

Репутация: нет
Всего: 4



Вот ещё кое что по теме:

Код

...
  private
    I: Integer;
    LayeredWndAttr: TSetLayeredWindowAttributes;
...

const
  LWA_ALPHA = $00000002;
  WS_EX_LAYERED = $00080000;

...

procedure TForm1.FormCreate(Sender: TObject);
begin

I := 50; // Устанавлевает уровнь прозрачности от 0 до 100

@LayeredWndAttr := GetProcAddress(GetModuleHandle('user32.dll'),'SetLayeredWindowAttributes');
SetWindowLong(Handle, GWL_EXSTYLE, WS_EX_LAYERED);
LayeredWndAttr(Handle, RGB(0, 0, 0), Round(I * 255 div 100), LWA_ALPHA);

end;


Этот код работает только в Windows 2k/XP .

ps
Не помню где Я этот код нашел smile
PM MAIL   Вверх
MIX55
Дата 18.1.2006, 14:02 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


много работы
*


Профиль
Группа: Awaiting Authorisation
Сообщений: 208
Регистрация: 23.10.2005
Где: Здесь

Репутация: нет
Всего: 4



А вот компонентик тут и прозрачность и полу прозрачность и еще 54 эффекта. Работает без глюков.
вот
--------------------
Hарод, а как в дельфи писать паскалевские проги....?*********************************************Жизнь слишком коротка, чтобы писать на Assembler'e
PM MAIL ICQ   Вверх
tripsin
Дата 21.12.2006, 13:42 (ссылка) |    (голосов:7) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



Профиль
Группа: Участник
Сообщений: 38
Регистрация: 10.4.2005
Где: Талица

Репутация: 3
Всего: 3



Вот моя статья в общую копилку. Написана в основном для начинающих и оформлена в виде "магического свитка" а'ля Гарри Поттер  smile 

Формула Прозрачности или Прозрачная Магия

Ни в заумных фолиантах, ни на просторах 
дикой сети я не нашел достойного свитка, 
вразумительно и доступно рассказывающего 
о создании Полупрозрачных Окон. Хотя 
возможно я плохо искал, или те свитки были 
скрыты невидимой чарой. 
В этом манускрипте я постарался подробно 
рассказать о магии прозрачности окон.


Это знают даже маглы.
Все уже наверное знают, что начиная с Delphi 6 формы умеют поддерживать свою прозрачность. Для этого не требуется абсолютно никаких усилий. Достаточно использовать свойства формы: 
  • AlphaBlend := True – включить прозрачность окна; 
  • AlphaBlendValue := 128 (от 0 до 255) – установить степень прозрачности формы. 255 – полная непрозрачность. 
  • TransparentColor := True – включить прозрачный цвет. 
  • TransparentColorValue – значение прозрачного цвета (по умолчанию 0 – clBlack)
 
Уже на этом этапе новичку требуется дать небольшое пояснение. Существуют 2 режима прозрачности:
  • 1. По цветовому ключу (TransparentColor). То есть какой-то определенный цвет обозначается как прозрачный (TransparentColorValue). Пиксель с этим цветом не прорисовывается, а вместо него появляется пиксел расположенный «под» формой. В форме появится прозрачное окошко. Окошко будет абсолютно прозрачное, то есть через него спокойно можно кликать, например, по иконкам на рабочем столе! 
    user posted image
  • 2. Более продвинутый (AlphaBlend). Здесь  происходит смешивание (blending) цвета пикселя формы и пикселя расположенного «под» формой с учетом установленной степени непрозрачности формы (AlphaBlendValue).
    user posted image
  •  Оба эти режима вполне можно использовать вместе.
    user posted image
В этом манускрипте рассмотрен в основном  второй способ, хотя и для первого тоже нашлось немного места.

Азы: Формула прозрачности
Но нам же мало стандартных свойств! Мы хотим сделать красивый виджет, взять за основу картинку и сделать окно невообразимой формы и различной прозрачности. И вот тут мы вступаем на зыбкую почву слабодокументированных, но очень соблазнительных возможностей. Для непосвященного наши действия будут попахивать магией. Хотя абсолютно все будет досконально разжевано и объяснено на пальцах.
user posted image
Для совершения заклинаний нам понадобится волшебник, и даже все маглы уже знают, что самым лучшим волшебником является профессор Дамблдор. Мы воспользуемся виртуальной личиной профессора, любезно им предоставленной. 
Также им была безвозмездно предоставлена формула прозрачности: 
user posted image

Здесь:
  • ResultColor – суммарный цвет пикселя;
  • SourceColor – цвет источника, накладываемой картинки;
  • DestinationColor – цвет приемника, фона, на который накладываем;
  • Transparency – прозрачность картинки источника. Это значение от 0 до 1. При единице накладываемая картинка совершенно непрозрачна и фона под ней не видно.
Как видишь, формула очень простая. Ты любуйся, а пока про нее расскажу. В цветовой модели RGB, которую мы будем использовать для картинок, цвет пикселя состоит из трех компонентов: красный, зеленый и синий. И для получения суммарного цвета пикселя надо применить эту формулу к каждому цветовому компоненту. 

Transparency  имеет значение от 0 до 1. Но нам по ходу дела будет удобнее использовать для задания прозрачности значения от 0 до 255 (то есть размером в 1 байт). Это связано с тем, что в используемых нами картинках цвет пикселов указан в системе RGB (красный, зеленый, синий) и размер каждого цветового компонента составляет 8 бит или 1 байт. Кроме того мы хотим, чтобы кроме общей прозрачности рисунка мы могли задавать прозрачность каждого пикселя в отдельности. Поэтому Transparency  мы будем вычислять вот так:
user posted image
  • Alpha – Отдельная прозрачность для каждого пикселя, или альфа-канал, или per-pixel прозрачность. Значение от 0 до 255.
  • SCA –  Soutrce Common Alpha. Суммарная прозрачность всей картинки. Значение от 0 до 255.
Теперь можно вывести универсальную формулу прозрачности:
user posted image


Уровень «СОВУ»: Перцеголовая чара.
скачай демо-проект  pepper-head.rar (59,2 кб)

Знания СОВУ (Совершенно Обычный Волшебный Уровень) являются базовыми и без них ты не сможешь разобраться ни в уровне ПАУК, ни, тем более, в боевой магии. Как всегда, чтобы в чем-то хорошо разобраться, надо сделать все своими ручками. И сейчас мы разберем ручное создание эффекта прозрачности изображения. Кроме весьма полезного опыта, сотворенный нами код будет полезен начинающим кодерам графических редакторов.

Итак формула прозрачности у нас уже есть. Сейчас мы с ее помощью для разминки пальцев составим Перцеголовую Чару. Кроме профессора нам для работы потребуется перец, выращенный, конечно, на огороде Хагрида. Заклинание будет заключаться в следующем: на фон нежного пастельного цвета мы сначала наложим полупрозрачного Дамблдора, а затем на получившийся рисунок на место дамблдоровой головы наложим полупрозрачное изображение перца. В приложенном свитке с демонстрацией можно менять степень прозрачности накладываемых изображений. 
user posted image

При наложении мы будем использовать единую прозрачность для всего изображения (без чресписксельной прозрачности).  Поэтому формула немного упростится:
user posted image

Образы волшебника, перца и фон поместим на форму в виде TImage. Изображения у нас окружены яркими цветами. Эти цвета нам нужны в качестве прозрачных ключей, чтобы при наложении убрать фон с исходных картинок. То есть мы применим сразу оба типа прозрачности – и по цветовому ключу, и альфа-смешивание.

Вот основная функция смешивания изображений:
Код

procedure BlendImage(X,Y: Integer;
                     SourceImage, DestinationImage: TImage;
                     Alpha: Byte;
                     TransparentColor: TColor);
var
  xx, yy: Integer;
  Transparency: Byte;
begin
  for xx := 0 to SourceImage.Width - 1 do
  for yy := 0 to SourceImage.Height - 1 do
    begin
      // Устанавливаем полную прозрачность для фона
      if SourceImage.Canvas.Pixels[xx,yy] = TransparentColor then
        Transparency := 0
      else
        Transparency := Alpha;
      // Проводим смешивание
      DestinationImage.Canvas.Pixels[xx + X, yy + Y] :=
        BlendColor(SourceImage.Canvas.Pixels[xx,yy],
                   DestinationImage.Canvas.Pixels[xx + X, yy + Y], Transparency);
    end;
end;

В функцию передаем рисунок-источник и рисунок, на который будем накладывать изображение. X и Y – координаты верхнего левого угла рисунка-источника на целевом рисунке. CommonAlpha – общая прозрачность рисунка (0..255, при 255 – непрозрачный рисунок). TransparentColor – прозрачный цвет. Используем его, чтобы убрать фон с рисунка источника.

Доступ к пикселям рисунков осуществляем с помощью свойства Canvas.Pixels[]. Обходим в цикле все точки рисунка-источника, получаем их цвет. Если цвет соответствует TransparentColor, то устанавливаем полную прозрачность (Transparency) пикселя, иначе она равна CommonAlpha. Дальше проводим смешивание цветов картинок и устанавливаем новый цвет пикселя. Смешивание проводит функция BlendColor:
Код

function BlendColor(SColor, DColor: TColor; CommonAlpha: Byte): TColor;
var
  r, g, b: Byte;
begin
  r := Round((GetRValue(SColor) * CommonAlpha / 256) +
              GetRValue(DColor) * (1 - CommonAlpha /256));
  g := Round((GetGValue(SColor) * CommonAlpha / 256) +
              GetGValue(DColor) * (1 - CommonAlpha/256));
  b := Round((GetBValue(SColor) * CommonAlpha / 256) +
              GetBValue(DColor) * (1 - CommonAlpha /256));
  Result := RGB(r,g,b);
end;

Она получает два цвета и смешивает их с учетом прозрачности. Собственно тут и применяется формула прозрачности.

Поочередно вызовем функцию BlendImage для Дамблдора и перца. Получился перцеголовый Дамлдор. Все! Заклинание готово. Подробности реализации смотри в приложенном демонстрационном свитке.

Сразу надо отметить, что свойство канвы Pixels[] использует функции Windows API – GetPixel и SetPixel. Но эти функции работают просто кошмарно медленно. Перейдя на новый уровень, ты узнаешь как существенно оптимизировать код заклинания и заставить его работать намного быстрее.

Уровень «ПАУК»: Оптимизация и Плащ-невидимка.
скачай демо-проект invisible-coat.rar (56,2 кб)

Уровень ПАУК (Пресложная Аттестация Умений Колдуна) предполагает доскональное знание изучаемого предмета и готовность к реальному применению знаний.  

Как уже говорилось функции GetPixel, SetPixel и использующее их свойство канвы Pixels[] работают бессовестно медленно. А в функции BlendImage свойство Pixels используется  4 раза. Если ты захочешь сделать так, чтобы перец на голове проявлялся постепенно и будешь в цикле рисовать его с постепенно увеличивающейся непрозрачностью, то можешь и не дождаться окончания процесса. Срочно необходима оптимизация ! 

Выкинем API функции GetPixel и SetPixel и напишем свои быстрые. Для этого будем получать цвет пикселя непосредственно из области памяти, в которую записано изображение. К счастью разработчики Delphi предусмотрели такой вариант. Объект TBitmap имеет свойство Scanline[] – массив указателей на начала строк пикселей в изображении. Зная объем памяти занимаемый одним пикселем можно легко вычислить указатель на пиксель, прибавив к указателю на строку (это координата Y)  положение пикселя в строке (координата X) умноженное на объем памяти, занимаемый одним пикселем (для 24-битной картинки  24/8 = 3 байта). Для доступа к цветовым компонентам в системе RGB используем структуру TRGBTriple (описана в Windows.pas).
Код

// Быстрое получение цвета пикселя. Только для 24-битных картинок!
// Нет проверки на ошибки !
function GetPixel(Bitmap: TBitmap; X,Y: Integer): TColor;
var pixel: PRGBTriple;
begin
  if Bitmap.PixelFormat = pf24bit then begin
    DWORD(pixel) := DWORD(Bitmap.ScanLine[Y]) + (X * SizeOf(TRGBTriple));
    Result := RGB(pixel.rgbtRed, pixel.rgbtGreen, pixel.rgbtBlue); 
  end else Result := 0;
end;

// Быстрая установка цвета пикселя. Только для 24-битных картинок!
// Нет проверки на ошибки !
procedure SetPixel(Bitmap: TBitmap; X,Y: Integer; Color: TColor);
var  pixel: PRGBTriple;
begin
  if Bitmap.PixelFormat = pf24bit then begin
    DWORD(pixel) := DWORD(Bitmap.ScanLine[Y]) + (X * SizeOf(TRGBTriple));
    pixel.rgbtRed   := GetRValue(Color);
    pixel.rgbtGreen := GetGValue(Color);
    pixel.rgbtBlue  := GetBValue(Color);
  end;
end;

Кроме того, можно оптимизировать и функцию смешивания цветов BlendColor. Для этого надо преобразовать формулу так, чтобы убрать все математические операции с плавающей запятой. Учтем также, что операция X shr 8 эквивалентна X / 256, но выполняется быстрее:
user posted image

Код

function FastBlendColor(Src, Dest: TColor; CommonAlpha: Byte): TColor;
begin
  Result := RGB(
      GetRValue(Dest)+(GetRValue(Src)-GetRValue(Dest))*CommonAlpha shr 8,
      GetGValue(Dest)+(GetGValue(Src)-GetGValue(Dest))*CommonAlpha shr 8,
      GetBValue(Dest)+(GetBValue(Src)-GetBValue(Dest))*CommonAlpha shr 8);
end;

В результате мы получаем увеличение производительности более, чем в 5 раз! И, как увидим дальше, это далеко не предел.
user posted image

Теперь о плаще-невидимке. Мне не удалось достать хорошего работающего плаща для проведения наших опытов, но кое-что у меня все-таки есть  smile . Как-то, бродя по задворкам Хогварца, я обнаружил на куче мусора старый потрепанный плащ-невидимку. Он не работал. Вернее работал наполовину и добиться полной невидимости в нем не получалось. Наверное поэтому его и выбросили. При осмотре плаща я обнаружил причину поломки. Как раз в области оптического процессора прямо сквозь цепи фотонных нанодатчиков была сделана довольно корявая вышивка: «Harry Potter». Очевидно старый владелец этой вещи, абсолютно не разбирался в ее работе.  Ну что же, приспособим это барахло для наших нужд. Заставим Дамблдора одеть этот плащ и постепенно появляться перед нами. 
user posted image

Плащ-невидимка представляет собой 8-битную серую картинку. Размер каждого пикселя как раз представляет собой значение от 0 до 255. Значения цвета пикселей плаща будут определять прозрачность каждого пикселя на изображении волшебника.  То есть плащ будет альфа-каналом картинки волшебника. В этом примере сразу будем использовать быстрый доступ к пикселям изображения с использованием свойства TBitmap.Scanline[]. Установку значений цветовых компонентов будем делать по полной формуле прозрачности, но оптимизируем ее, чтобы не было операций с плавающей точкой:
user posted image

Код функции откомментирован построчно, поэтому объяснения будут лишними. Смотри код и читай комментарии.
Код

procedure FastBlendImage(Src, Dst, Map: TBitmap; SCA: Byte; X,Y: Integer);
var
  xx, yy: Integer;// Счетчики циклов
  SrcBase, MapBase, DstBase: Pointer; // Указатели на строки пикселей
  SrcInc, MapInc, DstInc: Integer; // Длины строк пикселей
  SrcPixel, DstPixel: PRGBTriple; // Указатели на 24-битные пиксели
  Alpha: PByte; // Указатель на 8-битный пиксель
  Transparency: Byte; // Per-pixel прозрачность. 255 = непрозрачность
begin
  // Получим указатели на начало первой строки во всех картинках
  SrcBase := Src.ScanLine[0];
  MapBase := Map.ScanLine[0];
  DstBase := Dst.ScanLine[Y]; // Первой строкой будет Y-строка
  // Получим длину строки каждой картинки в байтах. Для этого
  // найдем разницу между указателями на 1 и вторую строки
  SrcInc := Integer(Src.ScanLine[1]) - Integer(Src.ScanLine[0]);
  MapInc := Integer(Map.ScanLine[1]) - Integer(Map.ScanLine[0]);
  DstInc := Integer(Dst.ScanLine[1]) - Integer(Dst.ScanLine[0]);

  // цикл yy перебирает все строки в картинке источнике
  for yy := 0 to Src.Height - 1 do begin
    // Получаем указатели на первый пиксель в текущей строке
    DWORD(SrcPixel) := DWORD(SrcBase);
    Alpha := MapBase;
    DWORD(DstPixel) := DWORD(DstBase) + (X * SizeOf(TRGBTriple));
    // цикл xx перебирает все пиксели текущей строки картинки источника
    for xx := 0 to Src.Width - 1 do begin
      // Получаем значение прозрачности из плаща-невидимки
      Transparency := Byte(Alpha^);
      // Смешиваем цветовые компоненты по полной формуле прозрачности 
       DstPixel.rgbtRed   := DstPixel.rgbtRed +
                             (SrcPixel.rgbtRed - DstPixel.rgbtRed) *
                             Transparency * SCA shr 16;
       DstPixel.rgbtGreen := DstPixel.rgbtGreen +
                             (SrcPixel.rgbtGreen - DstPixel.rgbtGreen) *
                             Transparency * SCA shr 16;
       DstPixel.rgbtBlue  := DstPixel.rgbtBlue +
                             (SrcPixel.rgbtBlue - DstPixel.rgbtBlue) *
                             Transparency * SCA shr 16;
       // Получаем указатели на следующие пиксели в текущей строке,
       // увеличивая указатель на пиксель на размер пикселя
       DWORD(SrcPixel) := DWORD(SrcPixel) + SizeOf(TRGBTriple);
       DWORD(DstPixel) := DWORD(DstPixel) + SizeOf(TRGBTriple);
       DWORD(Alpha)    := DWORD(Alpha)    + SizeOf(Byte);
    end;
    // Получаем указаетель на следующую строку, увеличивая указатель
    // на строку на вычисленый ранее размер строки.
    DWORD(SrcBase) := DWORD(SrcBase) + SrcInc;
    DWORD(MapBase) := DWORD(MapBase) + MapInc;
    DWORD(DstBase) := DWORD(DstBase) + DstInc;
  end;
end;

Эта процедура работает очень быстро. В демонстрационном свитке для сравнения используются все рассмотренные методы доступа к пикселям. Так вот эта процедура быстрее доступа с помощью новых GetPixel и SetPixel в 8 раз. А при сравнению с использованием свойства Canvas.Pixels[] производительность возрастает в ≈56 раз !!

Теперь ты готов к реальному применению заклинаний прозрачности и можешь переходить к боевой магии.

Боевая магия: Джинн из файла.
скачай демо-проект jinn_from_file.rar (17,1 кб)

Ничего особенно воинственного мы тут делать не собираемся. Просто сейчас мы применим наши знания на практике, чтобы поразить окружающим красивыми визуальными эффектами. Выпустим джинна из файла! 

Для приготовления джинна  нам пригодится уже знакомый виртуальный образ Дамблдора, а также разработанный на предыдущем уровне плащ-невидимка. Если запустить программу из ярлыка на рабочем  столе или из Explorer’а, то джинн плавненько появится прямо из файла. Предполагается, что взявшись за реализацию боевого заклинания, ты имеешь представление, что из себя представляет окно и контекст устройства.
user posted image

Этот джинн является полноценным окном. Его можно таскать по столу мышкой и заставить исчезнуть по двойному клику. Он даже сможет исполнять твои желания. Правда для этого ты должен сам четко объяснить ему, что ты хочешь. То есть остается  собственно написать функции, которые этот джинн будет выполнять.  smile   Итак, поехали.

Джинна мы сделаем из простой формы путем довольно сложной трансфигурации. 

Перво-наперво обыкновенное окно надо превратить в многослойное. Это делается путем добавления к стилю окна флага WS_EX_LAYERED.
Код

  SetWindowLong(Handle, GWL_EXSTYLE,
                GetWindowLong(Handle, GWL_EXSTYLE) or WS_EX_LAYERED);

Дальше с многослойным окном можно собственно проводить трансфигурацию. Для этого применяется заклинание UpdateLayeredWindow. В Windows Vista добавлено еще одно заклинание – UpdateLayeredWindowIndirect (вызывается похоже)
Код

function UpdateLayeredWindow(
  Handle: THandle; //Дескриптор нашего многослойного окна, то есть HWND.
  hdcDest: HDC;    //Контекст устройства на которое будет проецироваться 
                   //окно. То есть контекст экрана – GetDC(0);
  pptDst: PPoint;  //Новая позиция окна на экране. Верхний левый угол. 
  _psize: PSize;   //Новый размер окна.
  hdcSrc: HDC;     //Контекст с рисунком нового окна. Об этом отдельно.
  pptSrc: PPoint;  //Левый верхний угол выводимого рисунка в hdcSrc.
  crKey: COLORREF; //Прозрачный цвет. Мы не используем. Будет равен 0.
  pblend: PBLENDFUNCTION; //Указатель на структуру с параметрами смешивания
  dwFlags: DWORD   // Одно из следующих значений: 
                   //1. ULW_ALPHA – альфа смешивание, используется 
                   //               BLENDFUNCTION – наш выбор; 
                   //2. ULW_COLORKEY – используется цветовой ключ crKey; 
                   //3. ULW_OPAQUE – непрозрачное окно.
): Boolean; // Если получится - возвратится True.

  BLENDFUNCTION = packed record
    BlendOp: BYTE; // Вид операции смешивания. Пока документирован 
                   // только один - AC_SRC_OVER.
    BlendFlags: BYTE; //Не используется. Должен быть равен нулю.
    SourceConstantAlpha: BYTE;// Общая прозрачность рисунка-источника. 
                              // 0 – полная прозрачность, 
                              // 255 – полная непрозрачность.
    AlphaFormat: BYTE; //Определяет, как интерпретируются целевой рисунок 
                       //и рисунок-источник. В настоящий момент 
                       //документирован только AC_SRC_ALPHA(означает, что 
                       //у рисунка-источника есть альфа-канал), хотя есть 
                       //еще  AC_SRC_NO_PREMULT_ALPHA, AC_SRC_NO_ALPHA,
                       // AC_DST_NO_PREMULT_ALPHA, AC_DST_NO_ALPHA.
  end;

В основном проблем с параметрами тут нет, кроме одного - hdcSrc: HDC;  Это должен быть контекст устройства вывода, совместимый в нашем случае с экраном, и в него должна быть выбрана картинка, которую мы хотим видеть на месте нашего окна. Для того чтобы использовать per-pixel прозрачность эта картинка должна быть 32-битной. То есть должна содержать  альфа-канал. Из всех форматов изображений наиболее универсально поддерживает альфа-канал формат PNG. И в основном именно его для этой цели и используют. Для  его загрузки можно использовать сторонние библиотеки (например PNGlib) или воспользоваться мощностями GDI+ (Пример можешь глянуть здесь ). 

Но мы не пойдем этим путем и создадим 32-битную картинку вручную внутри стандартного TBitmap. В этот нам опять поможет наш любимый профессор. У нас есть 24-битная картинка с образом Дамблдора и 8-битная серая картинка с плащом-невидимкой. 24+8=32. Нам остается только свести эти картинки вместе в одну 32-битную картинку. 

Есть один очень важный момент. Windows при создании полупрозрачного окна руководствуется той же самой формулой прозрачности, что и мы в своих примерах, но одно из действий она не выполняет! Вот это:
user posted image

Это действие  надо сделать самому, перед тем как передать картинку в функцию. То есть мы должны во время соединения волшебника и плаща цветовые компоненты всех пикселей Дамблдора умножить на значение альфа-канала (плаща-невидимки) и разделить на 256. Вот такой подводный камень. Он перегородил дорогу многим, пытавшимся создать Полупрозрачное Окно.

Если ты будешь часто менять изображение в окне, то тебе придется каждый раз заново обрабатывать пиксели изображения  альфа-каналом. Поэтому эту операцию надо оптимизировать еще жестче. Как всегда, чем быстрее работает алгоритм, тем больше он требует памяти. Это я к тому, что мы может рассчитать все возможные значения пикселя только один раз и поместить их  в таблицу (PreMultiplyTable), а потом не выполнять никаких вычислений, а просто брать данные из таблицы. Оптимизации нет предела! При загрузке программы будем заполнять таблицу значениями:
Код

var
 .. 
  PreMultiplyTable: array [0..255,0..255] of Byte;

procedure InitPreMultiplyTable;
var
  Alpha, Color: Byte;
begin
  for Alpha := 0 to 255 do
    for Color := 0 to 255 do
      PreMultiplyTable[Alpha,Color] := Alpha * Color shr 8;
end;

Размер таблицы PreMultiplyTable составляет 256*256=65536 байт. То есть за большую скорость мы расплатились 64 Кб памяти. 

Процедура сведения картинок выполняется по быстрому алгоритму и очень похожа на то, что мы делали на уровне ПАУК. Доступ к цветовым компонентам 32-битной картинки делаем с помощью структуры TRGBQuad (используем ее поле rgbReserved для альфа-канала).
Код

procedure TForm1.FormCreate(Sender: TObject);
var
  src, map: TBitmap; //Для загрузки картинок Дамблдора и плаща
  xx, yy: Integer;  // Счетчики циклов
  SrcBase, MapBase, DstBase: Pointer; // Указатели на строки пикселей
  SrcInc, MapInc, DstInc: Integer; // Размеры строк пикселей
  SrcPixel: PRGBTriple; // пиксель 24-битной картинки
  Alpha: PByte; // пиксель 8-битной картинки
  DstPixel: PRGBQuad; // пиксель 32-битной картинки
begin
  inherited;
  // Получаем координаты мыши (TPoint). Из этой точки появится джинн
  GetCursorPos(mouse);
  // Инициируем предумноженную таблицу
  InitPreMultiplyTable;
  // Загружаем Дамблдора - 24 битный
  src := TBitmap.Create;
  src.LoadFromFile('wizard.bmp');
  // Загружаем плащ невидимку - 8 битный
  map := TBitmap.Create;
  map.LoadFromFile('map.bmp');
  // Создаем 32-битный TBitmap размерами как у Дамблдора
  dst := TBitmap.Create;
  dst.Width := src.Width;
  dst.Height := src.Height;
  dst.PixelFormat := pf32bit;
  // Получаем указатели на первые строки пикселей картинок
  SrcBase := Src.ScanLine[0];
  MapBase := Map.ScanLine[0];
  DstBase := Dst.ScanLine[0];
  // Получаем размеры строк пикселей в картинках
  SrcInc := Integer(Src.ScanLine[1]) - Integer(Src.ScanLine[0]);
  MapInc := Integer(Map.ScanLine[1]) - Integer(Map.ScanLine[0]);
  DstInc := Integer(Dst.ScanLine[1]) - Integer(Dst.ScanLine[0]);
  // Перебираем все строки
  for yy := 0 to Dst.Height - 1 do begin
    // Получаем первый пиксель в строке
    DWORD(SrcPixel) := DWORD(SrcBase);
    Alpha := MapBase;
    DWORD(DstPixel) := DWORD(DstBase);
    // Перебираем все пиксели в строке
    for xx := 0 to Dst.Width - 1 do begin
      // Устанавливаем цветовые компоненты 32-битной картинки, по
      // значениям предумноженной таблицы.
      DstPixel.rgbRed   := PreMultiplyTable[Byte(Alpha^), SrcPixel.rgbtRed];
      DstPixel.rgbGreen := PreMultiplyTable[Byte(Alpha^), SrcPixel.rgbtGreen];
      DstPixel.rgbBlue  := PreMultiplyTable[Byte(Alpha^), SrcPixel.rgbtBlue];
      DstPixel.rgbReserved := Byte(Alpha^); // альфа-канал без изменений
      // Получаем следующий пиксел в картинках
      DWORD(SrcPixel) := DWORD(SrcPixel) + SizeOf(TRGBTriple); 
      DWORD(DstPixel) := DWORD(DstPixel) + SizeOf(TRGBQuad); 
      DWORD(Alpha)    := DWORD(Alpha)    + SizeOf(Byte);
    end;
    // Получаем следующую строку
    DWORD(SrcBase) := DWORD(SrcBase) + SrcInc;
    DWORD(MapBase) := DWORD(MapBase) + MapInc;
    DWORD(DstBase) := DWORD(DstBase) + DstInc;
  end;
  // Освободаем память от ненужных более картинок
  src.Free;
  map.Free;
  // Убираем у окна бордюр и шапку. Без этого ничего не выйдет
  BorderStyle := bsNone;
  // Прквращаем окно в многослойное.
  SetWindowLong(Handle, GWL_EXSTYLE,
                GetWindowLong(Handle, GWL_EXSTYLE) or WS_EX_LAYERED);
end;

Как видишь весь подготовительный код мы поместили в обработчик создания формы. Так как в моем примере картинка окна не изменяется, то 32-битная картинка создается только один раз и в этом примере использование предумноженной таблицы прироста скорости не дает. 

Саму трансфигурацию выполним при активации формы. Контекст устройства для заклинания UpdateLayeredWindow получим из самой картинки: TBitmap.Canvas.Handle. Дальше получим координаты мышки на экране (а она будет как раз над файлом в проводнике, ты же нему кликал для запуска примера). И будем показывать постепенно появляющегося джинна, плавно отъезжающего от мышки, то есть от файла. Создастся впечатление, что джинн появился прямо из файла. Вот так вот smile Всего лишь ловкость рук.
Код

procedure TForm1.FormActivate(Sender: TObject);
var
  screenDC: HDC; // контекст экрана
  pt1, pt2 : TPoint; // точки для UpdateLayeredWindow
  sz : TSize; // размер окна для UpdateLayeredWindow
  bf : TBlendFunction; // структура для UpdateLayeredWindow
  i: Integer; // счетчик цикла
begin
  // Получаем контекст экрана
  screenDC := GetWindowDC(GetDesktopWindow); // или GetDC(0);
  // Крутим цикл
  for i := 2 to 64 do begin
    // Вычисляем новое положение окна от координат мыши
    pt1 := Point(mouse.X + i , mouse.Y + i);
    pt2 := Point(0,0); // Берем для вывода всю 32-битную картинку
    sz.cx := dst.Width;  // Устанавливаем размеры окна равными
    sz.cy := dst.Height; // размерам картинки
    // Заполняем параметры смешивания
    with bf do begin
      BlendOp := AC_SRC_OVER;
      BlendFlags := 0;
      SourceConstantAlpha := i * 4 - 1; // Меняем общую прозрачность джинная
      AlphaFormat := AC_SRC_ALPHA; //используем альфа-канал
    end;
    // Наконец-то вызываем заклинание.
    if not UpdateLayeredWindow(Handle, screendc, @pt1, @sz, dst.Canvas.Handle,
                               @pt2,0, @bf,ULW_ALPHA) then
    ShowMessage('UpdateLayeredWindow: ' + SysErrorMessage(GetLastError));
    // Если оно не получилось, то выведется описание ошибки
    Sleep(1); // Небольшая актерская пауза
  end;
  // Освобождаем контекст экрана
  ReleaseDC(GetDesktopWindow,screenDC);
end;

Остальной код в примере нужен для того, чтобы таскать джинна по столу за тело. С эти разберешся сам. Конечно надо сделать еще так чтобы джинн был всегда поверх всех окон, чтобы его можно было вызвать горячей клавишей, чтобы он не запускался второй раз, но это уже не относится к теме данного манускрипта. Кстати обрати внимание что, хотя окно выводится прямоугольное, прозрачные участки джинна прозрачны также и для кликов  мышью. Этот значит, что теперь ты можешь создать окно самой вычурной формы без использования всяких регионов.

Это положительные моменты. Но есть тут один очень жирный минус. Используя функцию UpdateLayeredWindow, ты сообщаешь операционной системе о том, что берешь на себя полную ответственность за рисования окна и управление им. Windows будет только брать картинку из контекста, который ты указал в hdcSrc и обеспечивать прозрачность в соответствии с параметрами функции и альфа-каналом рисунка. В твое окно перестанет приходить сообщение WM_PAINT и событие OnPaint перестанет работать. Перерисовывать окно ты будешь должен сам по мере надобности. Для этого снова вызываешь UpdateLayeredWindow и передаешь ей обновленную картинку. 

И вот тут и возникает проблема с компонентами на  форме. Если во время разработки ты поместил на форму элементы управления (типа кнопок или полей ввода), то на новом окне они не прорисуются. Ведь выводится только твоя картинка. Но эти элементы будут работать, реагировать на клики (хотя и не всегда). Наиболее разумным решением этой проблемы будет полный отказ от стандартных элементов управления. Вместо этого надо рисовать элементы управления вручную в виде картинок прямо в контексте устройства, но перед его обработкой альфа-каналом. (применительно к коду примера рисовать элементы надо на картинке волшебника перед сведением картинок в 32-битную)
Это все. Теперь ты знаешь заклинание Полупрозрачных Окон и, надеюсь, разобрался с магией прозрачности. Да! Свитки примеров компилировались в Delphi7 и тестировались в WindowsXP.

Орехов Роман also known as tripsin ©  2006

Это сообщение отредактировал(а) tripsin - 26.12.2006, 21:47
PM MAIL WWW ICQ   Вверх
tripsin
Дата 26.12.2006, 21:51 (ссылка) |    (голосов:1) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



Профиль
Группа: Участник
Сообщений: 38
Регистрация: 10.4.2005
Где: Талица

Репутация: 3
Всего: 3



PM MAIL WWW ICQ   Вверх
AlexeyShestchenko
Дата 14.2.2008, 05:00 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Шустрый
*


Профиль
Группа: Участник
Сообщений: 59
Регистрация: 7.2.2008

Репутация: нет
Всего: нет



Очень красивые получаются формы,у меня есть шаблон-картинка,выглядит как форма в висте,эффектно смотриться
Но есть свои проблемы.  Например если засунуть это дело в dll с формой, то при создании их будет две и в деспетчере задач :(
что не очень радует. Но с контролами все будет супер!!! никаких морганий и т.п.
Прежде всего  надо научить delphi "понимать" png. Ищем в нете компонент pngimage.
Потом нам понадобится HSLUtils:
Код

{$X+}
Unit HSLUtils;
Interface
Uses SysUtils, Windows, Graphics, Math;

Const
  MaxHSL: integer = 240;

Type
  TRGB = Record R, G, B: Byte; End;
  LRec = Record Lo, Hi: Word; End;
  WRec = Record Lo, Hi: Byte; End;

Procedure RGBtoHSLRange(RGB: TColor; Var H, S, L: integer);
Function HSLRangeToRGB(H, S, L: integer): TColor;
Function GetRGB(Col: Longint): TRGB;
Function SetRGB(R, G, B: Byte): Longint;


{----------------------------------------------------------------}
{                       }Implementation{                         }
{----------------------------------------------------------------}


{----------------------------------------------------------------}
Function GetRGB(Col: Longint): TRGB;
Begin
  Result.R := 0;
  Result.G := 0;
  Result.B := 0;
  Try
    Result.B := WRec(LRec(Col).Hi).Lo;
    Result.G := WRec(LRec(Col).Lo).Hi;
    Result.R := WRec(LRec(Col).Lo).Lo;
  Except
  End;
End;


{----------------------------------------------------------------}
Function SetRGB(R, G, B: Byte): Longint;
Begin
  Result := 0;
  Try
    Result := (B * $10000) + (G * $100) + R;
  Except
  End;
End;


{----------------------------------------------------------------}
Function HSLtoRGB(H, S, L: double): TColor;
Var
  M1, M2, V: double;
  R, G, B: byte;

  Function HueToColourValue(Hue: double): byte;
  Begin
    Result := 0;
    Try
      If (Hue < 0) Then
        Hue := Hue + 1
      Else If (Hue > 1) Then
        Hue := Hue - 1;
      If (6 * Hue < 1) Then
        V := M1 + (M2 - M1) * Hue * 6
      Else If (2 * Hue < 1) Then
        V := M2
      Else If (3 * Hue < 2) Then
        V := M1 + (M2 - M1) * (2 / 3 - Hue) * 6
      Else
        V := M1;
      Result := round(255 * V);
    Except
    End;
  End;

Begin
  Result := 0;
  Try
    If (S = 0) Then
    Begin
      R := byte(Round(255 * L));
      G := R;
      B := R;
    End
    Else
    Begin
      If (L <= 0.5) Then
        M2 := L * (1 + S)
      Else
        M2 := L + S - L * S;
      M1 := 2 * L - M2;
      R := HueToColourValue(H + 1 / 3);
      G := HueToColourValue(H);
      B := HueToColourValue(H - 1 / 3);
    End;
    Result := SetRGB(R, G, B);
  Except
  End;
End;


{----------------------------------------------------------------}
Procedure RGBtoHSL(Col: TColor; Var H, S, L: double);
Var
  R, G, B, D, Cmax, Cmin: double;
  rgb: TRGB;
Begin
  rgb := GetRGB(Col);
  R := rgb.R / 255;
  G := rgb.G / 255;
  B := rgb.B / 255;
  Cmax := Max(R, Max(G, B));
  Cmin := Min(R, Min(G, B));
  L := (Cmax + Cmin) / 2;
  If (Cmax = Cmin) Then
  Begin
    H := 0;
    S := 0;
  End
  Else
  Begin
    D := Cmax - Cmin;
    If (L < 0.5) Then
      S := D / (Cmax + Cmin)
    Else
      S := D / (2 - Cmax - Cmin);
    If (R = Cmax) Then
      H := (G - B) / D
    Else If (G = Cmax) Then
      H := 2 + (B - R) / D
    Else
      H := 4 + (R - G) / D;
    H := H / 6;
    If (H < 0) Then
      H := H + 1;
  End;
End;


{----------------------------------------------------------------}
Function HSLRangeToRGB(H, S, L: integer): TColor;
Begin
  Result := 0;
  Try
    Result := HSLToRGB(H / MaxHSL, S / MaxHSL, L / MaxHSL);
  Except
  End;
End;


{----------------------------------------------------------------}
Procedure RGBtoHSLRange(RGB: TColor; Var H, S, L: integer);
Var
  Hd, Sd, Ld: double;
Begin
  RGBtoHSL(RGB, Hd, Sd, Ld);
  H := round(Hd * MaxHSL);
  S := round(Sd * MaxHSL);
  L := round(Ld * MaxHSL);
End;
     

{----------------------------------------------------------------}
End.


А вот это самый лакомый кусочек пользуйтесь. Кстати, если кто доработает пишите сюда.

Код

{----------------------------------------------------------------}
{                                                                }
{                       }IMPLEMENTATION{                         }
{                                                                }
{----------------------------------------------------------------}
{$R *.DFM}




Var PNGForm: TForm;
    BmpForm: TBitmap;


    //Делаем все чтобы красиво было....=)
Procedure FusionForm(Var FusBitmap: TBitmap);
Var TmpBitmap: TBitmap;
    pd, pa: pByteArray;
    tcol: TRGB;
    i, j: Integer;
Begin
  TmpBitmap := TBitmap.Create;
  TmpBitmap.Width := Form1.Width;
  TmpBitmap.Height := Form1.Height;
  TmpBitmap.PixelFormat := pf24bit;
  TmpBitmap.Canvas.CopyRect(TmpBitmap.Canvas.ClipRect, Form1.Canvas, Form1.Canvas.ClipRect);
  FusBitmap := Nil;
  FusBitmap := TBitmap.Create;
  FusBitmap.Assign(BmpForm);
  FusBitmap.PixelFormat := pf32bit;
  tcol := GetRGB(Form1.TransparentColorValue);
  For j := 0 To BmpForm.Height - 1 Do Begin
    pd := FusBitmap.ScanLine[j];
    pa := TmpBitmap.ScanLine[j];
    For i := 0 To FusBitmap.Width - 1 Do Begin
      If (pa[i * 3 + 2] <> tcol.R) Or
         (pa[i * 3 + 1] <> tcol.G) Or
         (pa[i * 3 + 0] <> tcol.B) Then Begin
        pd[i * 4 + 0] := pa[i * 3 + 0];
        pd[i * 4 + 1] := pa[i * 3 + 1];
        pd[i * 4 + 2] := pa[i * 3 + 2];
        pd[i * 4 + 3] := $FF;
      End;
    End;
  End;
  TmpBitmap := Nil;
End;

Function UpdateLayeredWindow(hwnd: HWND; hdcDst: HDC; pptDst: PPoint;
  psize: PSize; hdcSrc: HDC; pptSrc: PPoint; crKey: TColor;
  pblend: PBlendFunction; dwFlags: DWORD): BOOL; stdcall; external 'user32.dll';


Procedure UpDateForm(Form: TForm; Bmp: TBitmap; Opacite: Byte = $FF);
Const WS_EX_LAYERED = $80000;
Var Size: PSIZE;
    TopLeft, BmpTopLeft: TPoint;
    Blend: TBlendFunction;
Begin
  With Form Do Begin
    SetWindowLong(Handle, GWL_EXSTYLE,
      GetWindowLong(Handle, GWL_EXSTYLE) Or WS_EX_LAYERED);
    New(Size);
    Size.cx := Width;
    Size.cy := Height;
    TopLeft := BoundsRect.TopLeft;
    BmpTopLeft := Point(0, 0);
    With Blend Do Begin
      BlendOp := 0;
      BlendFlags := 0;
      SourceConstantAlpha := Opacite;
      AlphaFormat := 1;
    End;
    Bmp.PixelFormat := pf32bit;
    UpdateLayeredWindow(Handle, GetDC(0), @TopLeft, Size,
      Bmp.Canvas.handle, @BmpTopLeft, 0, @Blend, 2);
  End;
End;


Procedure FadeOutForm(Delay: Integer = 800);
Const Division = 40;
Var x: Integer;
    opacite: Byte;
    FusBitmap: TBitmap;
Begin
  Form1.BringToFront;
  FusionForm(FusBitmap);
  UpDateForm(PNGForm, Fusbitmap);
  Form1.Hide;
  For x := 1 To Division Do Begin
    opacite := Abs($FF - Round(Max(Min($FF / Division * x, $FF), 0)));
    UpDateForm(PNGForm, Fusbitmap, opacite);
    Sleep(Delay Div Division);
  End;
  UpDateForm(PNGForm, BmpForm, 0);
End;

Procedure FadeInForm(Delay: Integer = 800);
Const Division = 20;
Var x: Integer;
    opacite: Byte;
    FusBitmap: TBitmap;
Begin
  Form1.AlphaBlend := True;
  Form1.AlphaBlendValue := 0;
  PNGForm.Show;
  Form1.Show;
  Application.ProcessMessages;
  FusionForm(FusBitmap);
  UpDateForm(PNGForm, Fusbitmap, 0);
  Form1.Hide;
  Form1.AlphaBlend := False;
  Application.ProcessMessages;
  For x := 1 To Division Do Begin
    opacite := Round(Max(Min($FF / Division * x, $FF), 0));
    UpDateForm(PNGForm, Fusbitmap, opacite);
    Sleep(Delay Div Division);
  End;
  Form1.Show;
  UpDateForm(PNGForm, BmpForm);
End;

Function MyLoadPNG(fn: String; Var FinalBitmap: TBitmap): Boolean;
Var PNG: TPNGObject;
    AlphaBitmap: TBitmap;
    pd, pa: pByteArray;
    i, j, a: Integer;
Begin
  Result := False;
  FinalBitmap := Nil;
  FinalBitmap := TBitmap.Create;
  If (FileExists(fn) = False) Then Begin
    ShowMessage('Image ' + ExtractFilename(fn) + ' introuvable.');
    Exit;
  End;
  PNG := TPNGObject.Create;
  Try PNG.LoadFromFile(fn);
  Except
    ShowMessage('Erreur format PNG (' + ExtractFilename(fn) + ')');
    PNG := Nil;
    Exit;
  End;
  AlphaBitmap := TBitmap.Create;
  AlphaBitmap.Height := PNG.Height;
  AlphaBitmap.Width := PNG.Width;
  AlphaBitmap.PixelFormat := pf24bit;
  FinalBitmap.Assign(PNG);
  FinalBitmap.PixelFormat := pf32bit;
  If (Png.Transparent) Then Begin
    For i := 0 To PNG.Height - 1 Do
      For j := 0 To PNG.Width - 1 Do
        If (PNG.AlphaScanline[i][j] >= 240) Then
          AlphaBitmap.Canvas.Pixels[j, i] := $FFFFFF Else
          AlphaBitmap.Canvas.Pixels[j, i] := HSLRangeToRGB(0, 0, PNG.AlphaScanline[i][j]);
  End Else Begin
    AlphaBitmap.Canvas.Brush.Style := bsSolid;
    AlphaBitmap.Canvas.Brush.Color := $FFFFFF;
    AlphaBitmap.Canvas.FillRect(AlphaBitmap.Canvas.ClipRect);
  End;
  For j := 0 To PNG.Height - 1 Do Begin
    pd := FinalBitmap.ScanLine[j];
    pa := AlphaBitmap.ScanLine[j];
    For i := 0 To PNG.Width - 1 Do Begin
      a := pa[i * 3];
      If (a < 240) Then Begin
        pd[i * 4 + 0] := Round(Max(Min(pd[i * 4 + 0] * a / $FF, $FF), 0));
        pd[i * 4 + 1] := Round(Max(Min(pd[i * 4 + 1] * a / $FF, $FF), 0));
        pd[i * 4 + 2] := Round(Max(Min(pd[i * 4 + 2] * a / $FF, $FF), 0));
      End;
      pd[i * 4 + 3] := a;
    End;
  End;
  AlphaBitmap := Nil;
  PNG := Nil;
  Result := True;
End;

Procedure MyDrawPNG(X, Y: Integer; AlphaBitmap, FinalBitmap: TBitmap);
Var pd, pa: pByteArray;
    i, ix, j, a, b, ad: Integer;
Begin
  If (Assigned(AlphaBitmap) = False) Then Exit;
  If (Assigned(FinalBitmap) = False) Then Exit;
  FinalBitmap.PixelFormat := pf32bit;
  For j := 0 To AlphaBitmap.Height - 1 Do
    If (j + Y <= FinalBitmap.Height - 1) And (j + Y >= 0) Then Begin
      pd := FinalBitmap.ScanLine[j + Y];
      pa := AlphaBitmap.ScanLine[j];
      For i := 0 To AlphaBitmap.Width - 1 Do Begin
        a := pa[i * 4 + 3];
        b := Abs($FF - a);
        ix := Max(Min(i + X, FinalBitmap.Width - 1), 0);
        ad := pd[ix * 4 + 3];
        If (a >= 240) Then Begin
          pd[ix * 4 + 0] := pa[i * 4 + 0];
          pd[ix * 4 + 1] := pa[i * 4 + 1];
          pd[ix * 4 + 2] := pa[i * 4 + 2];
          pd[ix * 4 + 3] := $FF;
        End Else If (a >= 0) Then Begin
          If (ad < 240) Then
            b := Round(Max(Min(a + (ad * b) / $FF, $FF), 0));;
          pd[ix * 4 + 0] := Round(Max(Min(
            pa[i * 4 + 0] + b * pd[ix * 4 + 0] / $FF, $FF), 0));
          pd[ix * 4 + 1] := Round(Max(Min(
            pa[i * 4 + 1] + b * pd[ix * 4 + 1] / $FF, $FF), 0));
          pd[ix * 4 + 2] := Round(Max(Min(
            pa[i * 4 + 2] + b * pd[ix * 4 + 2] / $FF, $FF), 0));
          If (ad < 240) Then pd[ix * 4 + 3] := b;
        End;
      End;
    End;
End;

Procedure TForm1.FormCreate(Sender: TObject);
Var bmp: TBitmap;
Begin
  DoubleBuffered := True;
  Color := clFuchsia;
  TransparentColorValue := Color;
  BorderStyle := bsNone;

  // Это фоновая картинка
  If (MyLoadPNG('form.png', BmpForm)) Then Begin
    Width := BmpForm.Width;
    Height := BmpForm.Height;
  End;

  // Создаешь форму
  PNGForm := TForm.Create(self);
  With PNGForm Do Begin
    Parent := Form1.Parent;
    Name := 'PNGForm';
    Caption := Form1.Caption;
    FormStyle := Form1.FormStyle;
    BorderStyle := Form1.BorderStyle;
    BorderIcons := [];
    Position := Form1.Position;
    Left := Form1.Left;
    Top := Form1.Top;
    Width := Form1.Width;
    Height := Form1.Height;
    OnMouseDown := FormMouseDown;
    DoubleBuffered := True;
    Visible := False;
  End;

 { // Здесь можешь поверх формы еще одну png нарисовать
  MyLoadPNG('6c.png', bmp);
  MyDrawPNG(0, 28, bmp, BmpForm);
  bmp := Nil;  }

  // Показываешь все свою мега красивую форму
  UpDateForm(PNGForm, BmpForm, 0);
  FadeInForm; 
End;


Procedure TForm1.FormDestroy(Sender: TObject);
Begin
  BmpForm := Nil;
End;

{----------------------------------------------------------------}
{ Надо же нам уметь ее передвигать :)                            }
{----------------------------------------------------------------}
Procedure TForm1.FormMouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
Var FusBitmap: TBitmap;
Begin
  Form1.BringToFront;
  If (Button <> mbLeft) Then Exit;

  FusionForm(FusBitmap);
  UpDateForm(PNGForm, FusBitmap);
  Form1.Hide;
  PNGForm.Show;
  FusBitmap := Nil;

  Screen.Cursor := crSizeAll;
  X := PNGForm.Left - PNGForm.ScreenToClient(Mouse.CursorPos).X;
  Y := PNGForm.Top - PNGForm.ScreenToClient(Mouse.CursorPos).Y;
  Repeat
    PNGForm.Left := X + ScreenToClient(Mouse.CursorPos).X;
    PNGForm.Top := Y + ScreenToClient(Mouse.CursorPos).Y;
    Application.ProcessMessages;
    Sleep(10);
  Until ((GetAsyncKeyState(VK_LBUTTON) And $8000) = 0);
  Form1.Left := PNGForm.Left;
  Form1.Top := PNGForm.Top;
  Screen.Cursor := crDefault;

  Form1.Show;
  UpDateForm(PNGForm, BmpForm);
End;


{----------------------------------------------------------------}
{ удаляем                            }
{----------------------------------------------------------------}
Procedure TForm1.Button1Click(Sender: TObject);
Begin
  FadeOutForm;
  Application.Terminate;
End;


{----------------------------------------------------------------}
End.

PM MAIL   Вверх
Poseidon
Дата 15.2.2008, 16:44 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Delphi developer
****


Профиль
Группа: Комодератор
Сообщений: 5273
Регистрация: 4.2.2005
Где: Гомель, Беларусь

Репутация: 10
Всего: 133



Цитата(AlexeyShestchenko @  14.2.2008,  05:00 Найти цитируемый пост)
у меня есть шаблон-картинка,выглядит как форма в висте
Делись



--------------------
Если хочешь, что бы что-то работало - используй написанное, 
если хочешь что-то понять - пиши сам...
PM MAIL ICQ   Вверх
KgCoder
Дата 29.3.2008, 21:41 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Шустрый
*


Профиль
Группа: Участник
Сообщений: 93
Регистрация: 6.3.2008
Где: KGstan

Репутация: нет
Всего: нет



Вчера скачал True Transparency.
Снова возник вопрос как сделать фон полупрозрачным...вернее использовать png в качестве фона. Может кто-нибудь сможет сделать что-то подобное и выложит исходники?

PM MAIL   Вверх
KgCoder
Дата 2.4.2008, 10:02 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Шустрый
*


Профиль
Группа: Участник
Сообщений: 93
Регистрация: 6.3.2008
Где: KGstan

Репутация: нет
Всего: нет



AlexeyShestchenko
Вот собрал ваш вариант: png.rar
После появления выходит вот это:
user posted image
Не могу понять почему...
Помогите кто-знает....
PM MAIL   Вверх
bagos
Дата 21.4.2008, 19:25 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Опытный
**


Профиль
Группа: Участник
Сообщений: 275
Регистрация: 17.6.2006

Репутация: нет
Всего: 1



попробуй form color = yellow, form - transporentcolor = true, transporent color = yellow
PM MAIL   Вверх
Google
  Дата 24.1.2020, 17:39 (ссылка)  





  Вверх
  
Ответ в темуСоздание новой темы Создание опроса
Правила форума "Delphi: WinAPI и системное программирование"
Snowybartram
MetalFanbems
PoseidonRrader
Riply

Запрещено:

1. Публиковать ссылки на вскрытые компоненты

2. Обсуждать взлом компонентов и делиться вскрытыми компонентами

  • Литературу по Delphi обсуждаем здесь
  • Действия модераторов можно обсудить здесь
  • С просьбами о написании курсовой, реферата и т.п. обращаться сюда
  • Вопросы по реализации алгоритмов рассматриваются здесь
  • 90% ответов на свои вопросы можно найти в DRKB (Delphi Russian Knowledge Base) - крупнейшем в рунете сборнике материалов по Дельфи
  • 99% ответов по WinAPI можно найти в MSDN Library, оставшиеся 1% здесь

Если Вам понравилась атмосфера форума, заходите к нам чаще! С уважением, Snowy, bartram, MetalFan, bems, Poseidon, Rrader, Riply.

 
0 Пользователей читают эту тему (0 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема | Delphi: WinAPI и системное программирование | Следующая тема »


 




[ Время генерации скрипта: 0.1679 ]   [ Использовано запросов: 21 ]   [ GZIP включён ]


Реклама на сайте     Информационное спонсорство

 
По вопросам размещения рекламы пишите на vladimir(sobaka)vingrad.ru
Отказ от ответственности     Powered by Invision Power Board(R) 1.3 © 2003  IPS, Inc.