Вращение изображения
procedure rotateright(bitmap : timage);
var firstc, lastc, c, r : integer;
procedure fixpixels(c,r : integer);
var savepix, savepix2 : tcolor;
i, newc, newr : integer;
begin
savepix := bitmap.canvas.pixels[c,r];
for i := 1 to 4 do begin
newc := bitmap.height-r+1;
newr := c;
savepix2 := bitmap.canvas.pixels[newc,newr];
bitmap.canvas.pixels[newc,newr] := savepix;
savepix := savepix2;
c := newc;
r := newr;
end;
end;
begin
if bitmap.width <> bitmap.height then exit;
bitmap.visible := false;
with bitmap.canvas do begin
firstc := 0;
lastc := bitmap.width;
for r := 0 to bitmap.height div 2 do begin
for c := firstc to lastc do begin
fixpixels(c,r);
end;
inc(firstc);
dec(lastc);
end;
end;
bitmap.visible := true;
end;
Добавление события onmouseleave
unit bs_label;
interface
uses
windows, messages, sysutils, classes, graphics, controls, forms, dialogs,
stdctrls;
type
tbs_label = class(tlabel)
private
{ private declarations }
fonmouseleave: tnotifyevent;
fonmouseenter: tnotifyevent;
procedure cmmouseenter(var message: tmessage); message cm_mouseenter;
procedure cmmouseleave(var message: tmessage); message cm_mouseleave;
protected
{ protected declarations }
public
{ public declarations }
published
{ published declarations }
property onmouseleave: tnotifyevent read fonmouseleave write fonmouseleave;
property onmouseenter: tnotifyevent read fonmouseenter write fonmouseenter;
end;
procedure register;
implementation
procedure register;
begin
registercomponents('custom', [tbs_label]);
end;
{ tbs_label }
procedure tbs_label.cmmouseenter(var message: tmessage);
begin
if assigned(fonmouseenter) then fonmouseenter(self);
end;
procedure tbs_label.cmmouseleave(var message: tmessage);
begin
if assigned(fonmouseleave) then fonmouseleave(self);
end;
end.
Завершение всех работающий приложений
Ниже приведен код, который поможет вам завершить ВСЕ задачи без всяких уведомлений о необходимости сохранения данных.
Поэтому, прежде чем запустить этот код, убедитесь в наличии сохраненных данных и в том, что пользователь осведомлен об этой операции.
procedure tform1.buttonkillallclick(sender: tobject);
var
ptask : ptaskentry;
task : bool;
thistask: thandle;
begin
getmem (ptask, sizeof (ttaskentry));
ptask^.dwsize := sizeof (ttaskentry);
task := taskfirst (ptask);
while task do
begin
if ptask^.hinst = hinstance then
thistask := ptask^.htask
else
terminateapp (ptask^.htask, no_uae_box);
task := tasknext (ptask);
end;
terminateapp (thistask, no_uae_box);
end;
Использование анимированных курсоров
const crmycursor = 1;
procedure tform1.formcreate(sender: tobject);
begin
// Загружаем курсор. Единственный способ для этого
screen.cursors[crmycursor] :=
loadcursorfromfile('c:\mystuff\mycursor.ani');
// Используем курсор на форме
cursor := crmycursor;
end;