Форма без рамок

[dmitriegorovih]

function CreateRgnFromBitmap(rgnBitmap: TBitmap): HRGN;
var
TransColor: TColor;
i, j: Integer;
i_width, i_height: Integer;
i_left, i_right: Integer;
rectRgn: HRGN;
begin
Result := 0;
//Запоминаем размеры окна
i_width := rgnBitmap.Width;
i_height := rgnBitmap.Height;
//Определяем прозрачный цвет
transColor := rgnBitmap.Canvas.Pixels[0, 0];
//Запускаем цикл перебора строк картинки
//для определения области окна без фона
for i := 0 to i_height - 1 do
begin
i_left := -1;
//Запускаем цикл перебора столбцов картинки
for j := 0 to i_width - 1 do
begin
if i_left < 0 then
begin
if rgnBitmap.Canvas.Pixels[j, i] <> transColor then
i_left := j;
end
else
if rgnBitmap.Canvas.Pixels[j, i] = transColor then
begin
i_right := j;
rectRgn := CreateRectRgn(i_left, i, i_right, i + 1) ;
if Result = 0 then
Result := rectRgn
else
begin
CombineRgn(Result, Result, rectRgn, RGN_OR);
DeleteObject(rectRgn);
end;
i_left := -1;
end;
end;
if i_left >= 0 then
begin
rectRgn := CreateRectRgn(i_left, i, i_width, i + 1);
if Result = 0 then
Result := rectRgn
else
begin
CombineRgn(Result, Result, rectRgn, RGN_OR);
DeleteObject(rectRgn);
end;
end;

end ;
end;

Помогите пожалуйста как сделать так чтоб сюда запихивалась PNG или у кавото есть исходник или функция

Я так понял это функция по битмапу определяет где белый цвет и там обрезает форму но когда я закидываю PNG то там где полу прозрачный цвет остаёться просто фон

[Alex Cones]

А с чего вдруг они станут полупрозрачными?

Вот, держите:
http://forum.vingrad.ru/forum/topic-54390.html

Особенно почитайте статью о Гарри Поттере.

[dmitriegorovih]

Спасибо буду разбирать.

Очень красивые получаются формы,у меня есть шаблон-картинка,выглядит как форма в висте,эффектно смотриться
Но есть свои проблемы. Например если засунуть это дело в 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}

...----->>>>>

[dmitriegorovih]

...------>>>>>>

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,

...------>>>>>>>

[dmitriegorovih]

...------->>>>>>>

PNG.AlphaScanline[i][j]);
End Else Begin
AlphaBitmap.Canvas.Brush.Style := bsSolid;
AlphaBitmap.Canvas.Brush.Color := $FFFFFF;
AlphaBitmap.Canvas.FillRect(AlphaBi tmap.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.Cursor Pos).X;
Y := PNGForm.Top - PNGForm.ScreenToClient(Mouse.Cursor Pos).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.

Мне вот вотетаба стотейка, я нашёл компонент тока он всё просит какието обьекты вот ссылка на компонент
http://delphi-coder.ru/files/Compone...e/pngimage.rar

[dmitriegorovih]

P.S. А HSLutils это надо компонент делать?

[.Phoenix]

Вообще его "делать" не надо. =) Возможно необходимо его просто установить в Delphi как компонент. А он уже написан.

[dmitriegorovih]

Возможно необходимо его просто установить в Delphi как компонент

Да я его поставил но всё равно не получаеться использовать вот эту статью показывает в некоторых местах о том что незнает что это такое

http://www.prog.org.ru/topic_13278_0...prev_next=prev

Вот надыбал форум тока я не понял развязки а вот вопрос точто для меня

Я так понял здесь надо со слоями работать?

вот проект нашёл токо image перересовываеться долговато, подзадержки видны помогите пожалуйста их убрать

[DomiNick]

Ну во-первых для чего делать 2 разных архива? То что в "компоненты.rar" лежит надо просто положить в папку с проектом (оно чтоб прога могла png загрузить)...

Я так понял здесь надо со слоями работать?

"Слои" - это просто название... Работать надо с одним битмапом и рисовать всё на нём вручную...

Aero_in_XP.rar

Хм... Знакомый как-то делал такое же... Надо будет его разочаровать что его прогу кто-то уже "повторил"... =(
В XP практически нереально сделать без такого подёргивания... А оно вам надо? Просто полупрозрачное делайте и всё... Так уж необходимо Aero? =\\


P.S. Так не понял... А зачем там вообще компонент для загрузки png? Он же не используется вообще никак... Или это недоделанный исходник просто?

Aero в XP - это вообще садомазохизм, особенно для компьютеров "в возрасте".

Вообще реально... Но нерационально...

[W0LF]

Aero в XP - это вообще садомазохизм, особенно для компьютеров "в возрасте".