Создание курсора с процентом выполнения
Материал из DRKB
Создание курсора с процентом выполнения[править | править код]
{ **** UBPFD *********** by kladovka.net.ru ****
>> Создание курсора с процентом выполнения
Функция возвращает хэндл на созданный курсор Windows (hcursor, hicon)
с процентным соотношением, указанным в min,max и pos.
Своего рода ProgressBar, но только зашитый в курсор.
Зависимости: Windows, SysUtils, Graphics, Classes
Copyright: Василенко Роман
Дата: 07 мая 2002 г.
********************************************** }
// Используемые модули
uses Windows, SysUtils, Graphics, Classes;
// Сама функция
function create_prc_cursor(min, max, pos: Integer): hIcon;
var
cWidth, cHeight: Integer;
ii: IconInfo;
bmc, bmm: TBitmap;
Icon: hIcon;
tw: Integer;
tx: string;
function int_percent(umin, umax, upos, uabs: Integer): Integer;
begin
Result := 0;
if umax < umin then exit;
if upos < umin then exit;
if upos > umax then
begin
Result := 100;
exit;
end;
if (umin = upos) and (umax = upos) then
begin
Result := 100;
exit;
end;
Result := Round((upos - umin)/((umax - umin) / uabs));
end;
function create_curspace: TBitmap;
begin
Result := TBitmap.Create;
Result.PixelFormat := pf4bit;
Result.Width := cWidth;
Result.Height := cHeight;
end;
begin
cWidth := GetSystemMetrics(sm_cxcursor);
cHeight := GetSystemMetrics(sm_cycursor);
bmc := create_curspace;
bmm := create_curspace;
with bmm.Canvas do
begin
Brush.Color := clWhite;
FillRect(Rect(0, 0, bmm.Width, bmm.Height));
Brush.Color := clBlack;
FillRect(Rect(0, bmm.Height-8, bmm.Width, bmm.Height));
Brush.Color := clWhite;
FrameRect(Rect(0, bmm.Height-8, bmm.Width, bmm.Height));
end;
with bmc.Canvas do
begin
Brush.Color := clBlack;
FillRect(Rect(0 ,0, bmc.Width, bmc.Height));
Brush.Color := clWhite;
FillRect(Rect(1+int_percent(min, max, pos, bmc.Width-2),
bmm.Height-7, bmc.Width-1, bmc.Height-1));
Brush.Color := clWhite;
FrameRect(Rect(0, bmc.Height-8, bmc.Width, bmc.Height));
end;
tx := IntToStr(int_percent(min, max, pos, 100)) + '%';
with bmm.Canvas do
begin
Font.Size := 8;
Font.Style := [fsBold];
Font.Color := clWhite;
Brush.Color := clWhite;
tw := TextWidth(tx);
TextOut((cWidth - tw) div 2, 8, tx);
end;
with bmc.Canvas do
begin
Font.Size := 8;
Font.Style := [fsBold];
Font.Color := clWhite;
Brush.Color := clBlack;
TextOut((cWidth - tw) div 2, 8, tx);
end;
ii.fIcon := False;
ii.hbmColor := bmc.Handle;
ii.hbmMask := bmm.Handle;
ii.xHotspot := 0;
ii.yHotspot := 0;
Icon := CreateIconIndirect(ii);
Result := CopyIcon(Icon);
DestroyIcon(Icon);
bmc.Free;
bmm.Free;
end;
Пример использования:
Screen.Cursors[1] := create_prc_cursor(0, 100, 25);
Screen.Cursor := crNone;
Screen.Cursor := 1;
Author: Роман Василенко, romix@nm.ru, Пятигорск
ID: 02333