Форма окна по картинке

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Автор: Nikolay

WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****

>> Создание непрямоугольных окон.

Данный пример наглядно показывает как можно создавать прямоугольные окна, по

картинке.

Зависимости: Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms.

Автор: Nikolay, hapnik@mail.ru, Moscow

Copyright: http://delphi.mastak.ru

Дата: 27 апреля 2002 г.

***************************************************** }

// Свойства окна небходимо поставить

//Borders=None

var

regn, tmpRegn: integer; // регион окна и временный регион

x, y: integer; // координаты пикселя

nullClr: TColor; // «прозрачный цвет»

begin

nullClr := image1.picture.Bitmap.Canvas.Pixels[0, 0];

// Image1 это картинка по которой создается форма окна

regn := CreateRectRgn(0, 0, image1.picture.Graphic.Width,

image1.picture.Graphic.Height);

for x := 1 to image1.picture.Graphic.Width do

for y := 1 to image1.picture.Graphic.Height do

if image1.picture.Bitmap.Canvas.Pixels[x — 1, y — 1] = nullClr then

begin

tmpRegn := CreateRectRgn(x — 1, y — 1, x, y);

CombineRgn(regn, regn, tmpRegn, RGN_DIFF);

DeleteObject(tmpRegn);

end;

SetWindowRgn(form1.handle, regn, true);

end;

{/codecitation}

Форма выше всех других форм

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Оформил: DeeCo

Автор: http://www.swissdelphicenter.ch

with Self do {Form1,…}

SetWindowPos(Handle, // handle to window

HWND_TOPMOST, // placement-order handle {*}

Left, // horizontal position

Top, // vertical position

Width,

Height,

// window-positioning options

SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE);

{* Other Values: }

HWND_BOTTOM

Places the window at the bottom of the Z order.

HWND_NOTOPMOST

Places the window above all non-topmost windows

HWND_TOP

Places the window at the top of the Z order.

HWND_TOPMOST

Places the window above all non-topmost windows.

The window maintains its topmost position even when it is deactivated.

{/codecitation}

Универсальный создатель формы

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Обратите внимание на методы FindClass/GetClass и RegisterClass. С помощью их вы можете эффективно перевести строку (имя класса формы) в тип класса этой формы, и затем выполнить такую команду:

MyForm := TForm(FindClass(SomeString)).Create(Self);

{/codecitation}

Удалить кнопки сворачивания и максимизации с формы

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Оформил: DeeCo

Автор: http://www.swissdelphicenter.ch

{

This article shows by example how to suppress the maximize and

minimize buttons on an form at runtime.

To disable an form’s Minimize and Maximize buttons,

you need to use the SetWindowLong Windows API

function to change the style of the window.

}

{ Dieses Beispiel zeigt, wie man die Schaltflachen zur Minimierung,

Maximierung einer Form zur Laufzeit verstecken kann.

Man braucht dafur die SetWindowLong Windows API um den Stil

des Fensters zu andern.

Der Code kann auch fur non-VCL Anwendungen gebraucht werden.

}

// Add the following code to the OnCreate event

// procedure for your form (TForm1):

procedure TForm1.FormCreate(Sender: TObject);

var

l: DWORD;

begin

l := GetWindowLong(Self.Handle, GWL_STYLE);

l := l and not (WS_MINIMIZEBOX);

l := l and not (WS_MAXIMIZEBOX);

l := SetWindowLong(Self.Handle, GWL_STYLE, l);

end;

{/codecitation}

Убирать бордюр формы при перемещении

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Оформил: DeeCo

Автор: http://www.swissdelphicenter.ch

procedure TForm1.PanelTopMouseDown(Sender: TObject;

Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

const

SC_DRAGMOVE = $F012;

begin

if (Button = mbLeft) then

begin

ReleaseCapture;

(Self as TControl).Perform(WM_SYSCOMMAND, SC_DRAGMOVE, 0);

end;

end;

{/codecitation}

Создать форму с закругленными краями

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Оформил: DeeCo

Автор: http://www.swissdelphicenter.ch

{

Die CreateRoundRectRgn lasst eine Form mit abgerundeten Ecken erscheinen.

The CreateRoundRectRgn function creates a rectangular

region with rounded corners

}

procedure TForm1.FormCreate(Sender: TObject);

var

rgn: HRGN;

begin

Form1.Borderstyle := bsNone;

rgn := CreateRoundRectRgn(0,// x-coordinate of the region’s upper-left corner

0, // y-coordinate of the region’s upper-left corner

ClientWidth, // x-coordinate of the region’s lower-right corner

ClientHeight, // y-coordinate of the region’s lower-right corner

40, // height of ellipse for rounded corners

40); // width of ellipse for rounded corners

SetWindowRgn(Handle, rgn, True);

end

{ The CreatePolygonRgn function creates a polygonal region. }

procedure TForm1.FormCreate(Sender: TObject);

const

C = 20;

var

Points: array [0..7] of TPoint;

h, w: Integer;

begin

h := Form1.Height;

w := Form1.Width;

Points[0].X := C; Points[0].Y := 0;

Points[1].X := 0; Points[1].Y := C;

Points[2].X := 0; Points[2].Y := h — c;

Points[3].X := C; Points[3].Y := h;

Points[4].X := w — c; Points[4].Y := h;

Points[5].X := w; Points[5].Y := h — c;

Points[6].X := w; Points[6].Y := C;

Points[7].X := w — C; Points[7].Y := 0;

SetWindowRgn(Form1.Handle, CreatePolygonRgn(Points, 8, WINDING), True);

end;

{/codecitation}

Создание формы переменного типа

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Автор: Mike Orriss

Как насчет этого? (допустим что str содержит ‘TForm2’ и т.п.)?

procedure TForm1.Button1Click(Sender: TObject);

begin

with TFormClass(FindClass(str)).Create(Application) do

try

ShowModal;

finally

Free;

end;

end;

initialization

RegisterClasses([TForm2,TForm3,TForm4]);

end.

{/codecitation}

Создание формы на основе строки

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Обзор

В данном документе рассказывается о том, как в Delрhi можно создать экземпляр формы на основе строки, содержащей имя типа. Код примера прилагается.

На кого расчитан данный документ?

На любого программиста, имеющего начальные знания для работы с Delphi. Имеет отношение к любой версии Delphi.

Создание формы на основе строки

Чтобы можно было создать экземпляр формы на основе строки, содержащей имя типа, вы должны в первую очередь зарегистрировать данный тип в Delphi. Это выполняется функцией «RegisterClass». RegisterClass описан следующим образом:

procedure RegisterClass(AClass: TPersistentClass);

AClass — класс TPersistent. Другими словами, класс, который вы хотите регистрировать, в какой-то точке должен наследоваться от TPersistent. Поскольку все элементы управления Delphi, включая формы, соблюдают это требование, то проблем быть не должно. Но такой способ не пройдет, если регистрируемые классы наследуются непосредственно от TObject.

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

procedure TForm1.Button2Click(Sender: TObject);

var

b : TForm;

f : TFormClass;

begin

f := TFormClass(findClass(‘Tform2’));

b := f.create(self);

b.show;

end;

Данный код создаст тип TForm2, который мы зарегистрировали с помощью RegisterClass.

Демонстрационный проект

Создайте новый проект, затем добавьте 4 формы так, чтобы в общей сложности получилось 5. В реальном проекте вы можете заполнить их необходимыми элементами управления, для данного же примера это не важно.

В первой форме разместите поле редактирования и кнопку. Удалите все формы, кроме главной, из списка AutoCreate. Наконец, скопируйте приведенный ниже код в unit1, он позволит вам создавать форму по имени типа класса, введенному в поле редактирования.

unit Unit1;

interface

uses

Unit2, Unit3, Unit4, Unit5, Windows, Messages,

SysUtils, Classes, Graphics, Controls, Forms,

Dialogs, StdCtrls;

type

TForm1 = class(TForm)

Edit1: TEdit;

Button1: TButton;

procedure FormCreate(Sender: TObject);

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);

begin

RegisterClass(Tform2);

RegisterClass(Tform3);

RegisterClass(Tform4);

RegisterClass(Tform5);

end;

procedure TForm1.Button1Click(Sender: TObject);

var

f: Tformclass;

begin

f := tformclass(findClass(edit1.text));

with f.create(self) do

show;

end;

{/codecitation}

Создание окна в виде бублика

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Автор: Danillo

WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****

>> Создание Окна ВВиде Бублика

Зависимости: нет

Автор: Danillo, dve2@inbox.ru

Copyright: я

Дата: 16 марта 2003 г.

***************************************************** }

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

Buttons, Menus, StdCtrls;

type

TForm1 = class(TForm)

procedure FormCreate(Sender: TObject);

procedure Button1Click(Sender: TObject);

procedure FormPaint(Sender: TObject);

private

{ Private declarations }

rTitleBar: THandle;

Center: TPoint;

CapY: Integer;

Circum: Double;

SB1: TSpeedButton;

RL, RR: Double;

procedure TitleBar(Act: Boolean);

procedure WMNCHITTEST(var Msg: TWMNCHitTest);

message WM_NCHITTEST;

procedure WMNCACTIVATE(var Msg: TWMNCACTIVATE);

message WM_NCACTIVATE;

procedure WMSetText(var Msg: TWMSetText);

message WM_SETTEXT;

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

const

TitlColors: array[Boolean] of TColor =

(clInactiveCaption, clActiveCaption);

TxtColors: array[Boolean] of TColor =

(clInactiveCaptionText, clCaptionText);

procedure TForm1.FormCreate(Sender: TObject);

var

rTemp, rTemp2: THandle;

Vertices: array[0..2] of TPoint;

X, Y: INteger;

begin

Caption := ‘Oy?ei iaiaei!!!’;

BorderStyle := bsNone; {required}

if Width > Height then

Width := Height

else

Height := Width; {harder to calc if width height}

Center := Point(Width div 2, Height div 2);

CapY := GetSystemMetrics(SM_CYCAPTION) 10;

rTemp := CreateEllipticRgn(0, 0, Width, Height);

rTemp2 := CreateEllipticRgn((Width div 4), (Height div 4),

3 * (Width div 4), 3 * (Height div 4));

CombineRgn(rTemp, rTemp, rTemp2, RGN_DIFF);

SetWindowRgn(Handle, rTemp, True);

DeleteObject(rTemp2);

rTitleBar := CreateEllipticRgn(4, 4, Width — 4, Height — 4);

rTemp := CreateEllipticRgn(CapY, CapY, Width — CapY, Height — CapY);

CombineRgn(rTitleBar, rTitleBar, rTemp, RGN_DIFF);

Vertices[0] := Point(0, 0);

Vertices[1] := Point(Width, 0);

Vertices[2] := Point(Width div 2, Height div 2);

rTemp := CreatePolygonRgn(Vertices, 3, ALTERNATE);

CombineRgn(rTitleBar, rTitleBar, rTemp, RGN_AND);

DeleteObject(rTemp);

RL := ArcTan(Width / Height);

RR := -RL (22 / Center.X);

X := Center.X — Round((Center.X — 1 — (CapY div 2)) * Sin(RR));

Y := Center.Y — Round((Center.Y — 1 — (CapY div 2)) * Cos(RR));

SB1 := TSpeedButton.Create(Self);

with SB1 do

begin

Parent := Self;

Left := X;

Top := Y;

Width := 14;

Height := 14;

OnClick := Button1Click;

Caption := ‘X’;

Font.Style := [fsBold];

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

Close;

end;

procedure TForm1.WMNCHITTEST(var Msg: TWMNCHitTest);

begin

inherited;

with Msg do

with ScreenToClient(Point(XPos, YPos)) do

if PtInRegion(rTitleBar, X, Y) and

(not PtInRect(SB1.BoundsRect, Point(X, Y))) then

Result := htCaption;

end;

procedure TForm1.WMNCActivate(var Msg: TWMncActivate);

begin

inherited;

TitleBar(Msg.Active);

end;

procedure TForm1.WMSetText(var Msg: TWMSetText);

begin

inherited;

TitleBar(Active);

end;

procedure TForm1.TitleBar(Act: Boolean);

var

TF: TLogFont;

R: Double;

N, X, Y: Integer;

begin

if Center.X = 0 then

Exit;

with Canvas do

begin

Brush.Style := bsSolid;

Brush.Color := TitlColors[Act];

PaintRgn(Handle, rTitleBar);

R := RL;

Brush.Color := TitlColors[Act];

Font.Name := ‘Arial’;

Font.Size := 12;

Font.Color := TxtColors[Act];

Font.Style := [fsBold];

GetObject(Font.Handle, SizeOf(TLogFont), @TF);

for N := 1 to Length(Caption) do

begin

X := Center.X — Round((Center.X — 6) * Sin(R));

Y := Center.Y — Round((Center.Y — 6) * Cos(R));

TF.lfEscapement := Round(R * 1800 / pi);

Font.Handle := CreateFontIndirect(TF);

TextOut(X, Y, Caption[N]);

R := R — (((TextWidth(Caption[N])) 2) / Center.X);

if R < RR then

Break;

end;

Font.Name := ‘MS Sans Serif’;

Font.Size := 8;

Font.Color := clWindowText;

Font.Style := [];

end;

end;

procedure TForm1.FormPaint(Sender: TObject);

begin

with Canvas do

begin

Pen.Color := clBlack;

Brush.Style := bsClear;

Pen.Width := 1;

Pen.Color := clWhite;

Arc(1, 1, Width — 1, Height — 1, Width, 0, 0, Height);

Arc((Width div 4) — 1, (Height div 4) — 1,

3 * (Width div 4) 1, 3 * (Height div 4) 1, 0, Height, Width, 0);

Pen.Color := clBlack;

Arc(1, 1, Width — 1, Height — 1, 0, Height, Width, 0);

Arc((Width div 4) — 1, (Height div 4) — 1,

3 * (Width div 4) 1, 3 * (Height div 4) 1, Width, 0, 0, Height);

TitleBar(Active);

end;

end;

end.

{/codecitation}

Создание заставки

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Перед появлением главного окна во всех серьёзных приложениях сначала появляется заставка. Теперь и у Вас есть возможность повыёживаться! Для создания заставки выполняем следующую последовательность действий:

Начинаем создание нового приложение командой “New Application” (“Новое приложение”) из меню “File” (“Файл”)

Добавьте ещё одну форму: “New Form”(“Новая форма”) из меню “File” (“Файл”). Это окно и будет заставкой. У него нужно убрать рамку с полосой заголовка, установив свойство “BorderStyle” в “bsNone”. Теперь можно смело разработать дизайн окна заставки.

Из меню “Project” (“Проект”) выбрать команду “Options”(“Опции”). Зайти на закладку “Forms”(“Формы”) и Form2 из списка автоматически создаваемых форм (Auto-Create forms) перенести в список доступных форм (Available forms)

На форму-заставку с закладки System вынести компонент Timer. В его свойстве Interval установить значение 5000, а в событии OnTimer написать:

Timer1.Enabled := false;

Это сделано для того, чтобы заставка была видна в период указанного времени – 5000 миллисекунд, т.е. 5 секунд.

Перейти в файл проекта, нажав Ctrl F12 и выбрав Project1. Исходный код должен выглядеть так:

program Project1;

uses

Forms,

Unit1 in ‘Unit1.pas’ {Form1},

Unit2 in ‘Unit2.pas’ {Form2};

{$R *.RES}

begin

Application.Initialize;

Application.CreateForm(TForm1, Form1);

Application.Run;

end.

Теперь мы внесём сюда немного изменений и код должен стать таким:

program Project1;

uses

Forms,

Unit1 in ‘Unit1.pas’ {Form1},

Unit2 in ‘Unit2.pas’ {Form2};

{$R *.RES}

begin

Application.Initialize;

Form2 := TForm2.Create(Application);

Form2.Show;

Form2.Update;

while Form2.Timer1.Enabled do

Application.ProcessMessages;

Application.CreateForm(TForm1, Form1);

Form2.Hide;

Form2.Free;

Application.Run;

end.

{/codecitation}