Общие вопросы

Выводим цветной текст на форме под любым углом

2017-08-10T14:16:22+07:00

Автор: Lutfi Baran

Пример демонстрирует вывод теста случайным образом на форме под определённым углом. Добавляем в форму компонент TButton и в событие OnClick следующий код:

Code:

procedure TForm1.Button1Click(Sender: TObject);

var

logfont: TLogFont;

font: Thandle;

count: integer;

begin

LogFont.lfheight := 20;

logfont.lfwidth := 20;

logfont.lfweight := 750;

LogFont.lfEscapement := -200;

logfont.lfcharset := 1;

logfont.lfoutprecision := out_tt_precis;

logfont.lfquality := draft_quality;

logfont.lfpitchandfamily := FF_Modern;

font := createfontindirect(logfont);

Selectobject(Form1.canvas.handle, font);

SetTextColor(Form1.canvas.handle, rgb(0, 0, 200));

SetBKmode(Form1.canvas.handle, transparent);

for count := 1 to 100 do

begin

canvas.textout(Random(form1.width), Random(form1.height), 'Hello');

SetTextColor(form1.canvas.handle, rgb(Random(255), Random(255), Random

(255)));

end;

Deleteobject(font);

end;

Как изменить оконную процедуру для TForm?

2017-08-10T14:16:53+07:00

Переопределите в подклассе TForm оконную процедуру WinProc класса. В примере оконная процедура переопределяется для того чтобы реагировать на сообщение WM_CANCELMODE, показывающее, что выполняется messagebox или какой-либо еще диалог.

Code:

type

TForm1 = class(TForm)

Button1: TButton;

procedure WndProc(var Message: TMessage); override;

procedure Button1Click(Sender: TObject);

private

{Private declarations}

public

{Public declarations}

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WndProc(var Message: TMessage);

begin

if Message.Msg = WM_CANCELMODE then

begin

Form1.Caption := 'A dialog or message box has popped up';

end

else

inherited // <- остальное сделает родительская процедура

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

ShowMessage('Test Message');

end;

Как иммитировать появление формы как нового приложения?

2017-08-10T14:15:29+07:00

How i can create a form and this form stay in another icon in task bar ? (Looks like a new aplication).

Как я могу создать форму, и эта форма пребывания в другой значок в панель задач ? (Выглядит как новый применение).

In private clause:

Code:

type

TForm1 = class(TForm)

private

{ Private declarations }

procedure CreateParams(var Params: TCreateParams); override;

Подробнее...

Как поместить курсор мышки в нужное место на форме?

2017-08-10T14:15:56+07:00

Code:

uses

Windows;

procedure PlaceMyMouse(Sender: TForm; X, Y: word);

var

MyPoint: TPoint;

begin

MyPoint := Sender.ClientToScreen(Point(X, Y));

SetCursorPos(MyPoint.X, MyPoint.Y);

end;

Как сделать анимацию минимизации формы?

2017-08-10T14:13:59+07:00

In FormShow:

Code:

var

RecS, RecL: TRect;

begin

RecS := Rect(Screen.Width, Screen.Height, Screen.Width, Screen.Height);

RecL := ThisForm.BoundsRect;

DrawAnimatedRects(GetDesktopWindow, IDANI_CAPTION, RecS, RecL);

{ ... }

end;

Подробнее...

Как сделать форму всегда позади всех окон?

2017-08-10T14:19:01+07:00

Code:

protected

procedure CreateParams(var Params: TCreateParams); override;

//...

procedure TForm.CreateParams(var Params: TCreateParams);

begin

inherited CreateParams(Params);

if Assigned(Application.MainForm) then

begin

Params.WndParent := GetDesktopWindow;

Params.Style := WS_CHILD;

end;

Как среагировать на минимизацию-максимизацию формы перед тем как произойдет изменение?

2017-08-10T14:17:21+07:00

Перехватывать сообщение WM_SYSCOMMAND. Если это сообщение говорит о

минимизации или максимизации формы - пищит динамик.

Code:

type

TForm1 = class(TForm)

private

{Private declarations}

procedure WMSysCommand(var Msg: TWMSysCommand);

message WM_SYSCOMMAND;

public

{Public declarations}

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMSysCommand;

begin

if (Msg.CmdType = SC_MINIMIZE) or (Msg.CmdType = SC_MAXIMIZE) then

MessageBeep(0)

else

inherited;

end;

Как узнать форма активна или нет?

2017-08-10T14:18:37+07:00

Code:

type

//...

private

{ Private declarations }

procedure WMNCACTIVATE(var M: TWMNCACTIVATE); message WM_NCACTIVATE;

end;

implementation

//...

procedure TForm1.WMNCACTIVATE(var M: TWMNCACTIVATE);

begin

inherited;

if M.Active then

caption:='Form active'

else caption:='Form not active' ;

end;

Как узнать, находится ли мышка на форме?

2017-08-10T14:12:07+07:00

Для этого можно воспользоваться API функцией GetCapture().

Code:

procedure TForm1.FormDeactivate(Sender: TObject);

begin

ReleaseCapture;

end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,

Y: Integer);

begin

If GetCapture = 0 then

SetCapture(Form1.Handle);

if PtInRect(Rect(Form1.Left,

Form1.Top,

Form1.Left + Form1.Width,

Form1.Top + Form1.Height),

ClientToScreen(Point(x, y))) then

Form1.Caption := 'Мышка на форме' else

Form1.Caption := 'Мышка за пределами формы';

end;

Взято из https://forum.sources.ru

Как установить минимальный размер окна?

2017-08-10T14:11:24+07:00

Необходимо объявить обработчик события для WM_GETMINMAXINFO:

Code:

...

private

{©Drkb v.3(2007): www.drkb.ru}

procedure WMGetMinMaxInfo(var Message : TWMGetMinMaxInfo);

message WM_GETMINMAXINFO;

А вот как выглядит сам обработчик:

procedure TForm1.WMGetMinMaxInfo(var Message : TWMGetMinMaxInfo);

begin

Message.MinMaxInfo^.ptMinTrackSize := Point(Width, Height);

Message.MinMaxInfo^.ptMaxTrackSize := Point(Width, Height);

end;

Взято из https://forum.sources.ru

Примечание от Vit:

Начиная с Дельфи 5 появилось удобное свойство Constrains - специально для ограничесния минимальных и максимальных размеров...

Масштабирование формы под разрешение экрана

2017-08-10T14:24:31+07:00

Эта подпрограмма сделает жизнь программиста намного легче. Она делает так, чтобы ваша программа корректно масштабировалась при ЛЮБОМ разрешении экрана. Обратите внимание на число 640. Дело в том, что я разрабатываю свои приложения при разрешении 640x480. Вы можете настроить подпрограмму на ваше экранное разрешение при разработке программ и больше не беспокоиться о всевозможных низких и больших разрешений ваших пользователей. Разместите в обработчике события формы (которую вы хотите автомасштабировать) OnCreate следующую строку:

Подробнее...

Мерцание формы

2017-08-10T14:17:50+07:00

Как бы это осуществить рисование в окне без его дурацкого мерцания и без помощи создания виртуального изображения в памяти? WM_SETREDRAW здесь поможет?

Попробуйте этот код. Даже если некоторые компоненты имеют пару BeginUpdate / EndUpdate, то для таких компонентов, как TTreeView, интенсивное рисование может послужить причиной перемещения полосы прокрутки и появления других "барабашек". В таких ситуаций вместо дескриптора элемента управления используйте родительский дескриптор.

Подробнее...

Наполовину активное окно

2017-08-10T14:19:22+07:00

Как сделать так, чтобы окно было неактивно? Вы скажите: "Ничего сложного. Нужно только свойство окна Enabled установить в false"... но, так как окно является владельцем компонентов, находящихся на нём, то и все компоненты станут неактивными! Но был найден способ избежать этого!

Code:

private

{ Private declarations }

procedure WMNCHitTest (var M: TWMNCHitTest); message wm_NCHitTest;

implementation

{$R *.DFM}

procedure TForm1.WMNCHitTest (var M:TWMNCHitTest);

begin

if M.Result = htClient then

M.Result := htCaption;

end;

Полноэкранный режим

2017-08-10T14:23:59+07:00

Code:

function SetFullscreenMode: Boolean;

var

DeviceMode: TDevMode;

begin

with DeviceMode do

begin

dmSize := SizeOf(DeviceMode);

dmBitsPerPel := 16;

dmPelsWidth := 640;

dmPelsHeight := 480;

dmFields := DM_BITSPERPEL or DM_PELSWIDTH or DM_PELSHEIGHT;

result := False;

if ChangeDisplaySettings(DeviceMode, CDS_TEST or CDS_FULLSCREEN) <>

DISP_CHANGE_SUCCESSFUL then

Exit;

Result := ChangeDisplaySettings(DeviceMode, CDS_FULLSCREEN) =

DISP_CHANGE_SUCCESSFUL;

end;

procedure RestoreDefaultMode;

var

T: TDevMode absolute 0;

begin

ChangeDisplaySettings(T, CDS_FULLSCREEN);

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

if setFullScreenMode then

begin

sleep(7000);

RestoreDefaultMode;

end;

Привлечение внимания к окну

2017-08-10T14:18:15+07:00

Часто возникает проблема - в многооконном приложении необходимо обратить внимание пользователя на то, что какое-то из окон требует внимания (например, к нему пришло сообщение по DDE, в нем завершился какой-либо процесс, произошла ошибка ...). Это легко сделать, используя команду API FlashWindow:

Code:

procedure TForm1.Timer1Timer(Sender: TObject);

begin

FlashWindow(Handle,true);

end;

Пример градиентной заливки формы

2017-08-10T14:22:24+07:00

Иногда бывает нужно сложить два или более цветов для получения что-то типа переходного цвета. Делается это весьма просто. Координаты получаемого цвета будут равны среднему значению соответствующих координат всех цветов.

Например, нужно сложить красный и синий. Получаем

(255,0,0)+(0,0,255)=((255+0) div 2,(0+0) div 2,(0+255) div 2)=(127,0,127).

В результате получаем сиреневый цвет. Также надо поступать, если цветов более чем 2: сложить соответствующие координаты, потом каждую сумму разделить нацело на количество цветов.

Поговорим теперь о градиентной заливке. Градиентная заливка - это заливка цветом с плавным переходом от одного цвета к другому.

Итак, пусть заданы 2 цвета своими координатами ((A1, A2, A3) и (B1, B2, B3)) и линия (длиной h пикселов), по которой нужно залить. Тогда каждый цвет каждого пиксела, находящегося на расстоянии x пикселов от начала будет равен (A1-(A1-B1)/h*x, A2-(A2-B2)/h*x, A3-(A3-B3)/h*x). Теперь, имея линию с градиентной заливкой, можно таким образом залить совершенно любую фигуру: будь то прямоугольник, круг или просто произвольная фигура.

Подробнее...

Узнать класс формы

2017-08-10T14:22:46+07:00

Code:

type

PFieldClassTable = ^TFieldClassTable;

TFieldClassTable = packed record

Count: Smallint;

Classes: array[0..8191] of ^TPersistentClass;

end;

function GetFieldClassTable(AClass: TClass): PFieldClassTable; assembler;

asm

MOV EAX,[EAX].vmtFieldTable

OR EAX,EAX

JE @@1

MOV EAX,[EAX+2].Integer

@@1:

end;

procedure TForm1.Button1Click(Sender: TObject);

procedure Display( const S: String );

begin

memo1.lines.add( S );

end;

var

pFCT: PFieldClassTable;

aClass: TClass;

i: SmallInt;

begin

memo1.clear;

aClass:= Classtype;

While aClass <> TPersistent Do Begin

Display('Registered classes for class '+aClass.Classname );

pFCT := GetFieldClasstable( aClass );

If not Assigned( pFCT ) Then

Display(' No classes registered')

Else Begin

Display( format(' %d classes registered', [pFCT^.Count]));

for i:= 0 to pFCT^.Count -1 do

Display( ' '+pFCT^.Classes[i]^.ClassName );

End;

aClass := aClass.ClassParent;

End

end;

Функция, которая нарисует на форме сетку и сделает форму похожей на дизайнер форм Delphi

2017-08-10T14:23:28+07:00

Функция, которая нарисует на форме сетку и сделает форму похожей на дизайнер форм Delphi. По умолчанию в дизайнере Delphi отступы равны 8 пикселям

Code:

Procedure TForm1.DrawGrid;

Var

TmpBmp: TBitmap;

Begin

TmpBmp := TBitmap.Create;

Try

With TmpBmp Do

Begin

Width := 8;

Height := 8;

Canvas.Brush.Color := clBtnFace;

Canvas.FillRect(TmpBmp.Canvas.ClipRect);

Canvas.Pixels[0, 0] := clBlack;

Canvas.Pixels[0, Height] := clBlack;

Canvas.Pixels[Width, 0] := clBlack;

Canvas.Pixels[Width, Height] := clBlack;

End;

With Canvas, Brush Do

Begin

Bitmap := TBitmap.Create;

Try

Bitmap.Assign(TmpBmp);

Canvas.FillRect(Canvas.ClipRect);

Finally

Bitmap.Free;

End;

Finally

TmpBmp.Free;

End;

{ Использование }

Procedure TForm1.FormPaint(Sender: TObject);

Begin

DrawGrid;

End;

Подробнее...