24 совета по программированию в Delphi (Дельфи) часть 2 - Delphi, Pascal, ObjectPascal - Программирование
Навигация по сайту
Сайт:

Дополнительно:

Файловый архив:

Каталог статей:

Форум:


Категории раздела
Delphi, Pascal, ObjectPascal [18]
Программирование на Delphi, Pascal, ObjectPascal
C, C++, C# [7]
Программирование на C, C++, C#
ПХП (PHP) [6]
Все что связано с программированием на PHP.
DirectX [0]
Программирование с использованием графического API DirectX
OpenGL [0]
Программирование с использованием графического API OpenGL
Работа с базами данных (БД) [0]
Работа с базами данных MySQL и т.д. Разработка, теории, алгоритмы.
Сетевое программирование [0]
Сетевое программирование, организация сетей.
Программирование игр [0]
Все что связано с программированием игр, организацией их разработки.
Работа с мультимедиа данными [0]
Загрузка, обработка, воспроизведение и все что связано со звуком и видео.
Работа с устройсвами ввода и вывода [0]
Программирование устройств ввода и вывода. Работа с геймпадом, рулем и многим другим.
Программирование HTML 5 игр [0]
Программирование HTML 5 игр, html верстка, JS (JavaScript)
Остальное [0]
Все остальное, что не попадает ни под одну категорию.

Мини-Опрос
Чему вы отдаете большее предпочтение?
Всего ответов: 426

Партнеры сайта
....

 Главная » Статьи » Программирование » Delphi, Pascal, ObjectPascal » 24 совета по программированию в Delphi (Дельфи) часть 2

24 совета по программированию в Delphi (Дельфи) часть 2

00:49
1. Коды всех виртуальных клавиш
2. Как мне подсчитать занимаемое директорией место?
3. Сохранение параметров шрифта в файле.
4. Изменение шрифта у всплывающих подсказок
5. Как проверить готовность диска a:\
6. Перекодировка текста
7. Открытие и закрытие привода CD-ROM
8. Как подавить реакцию на Ctrl+Alt+Del?
9. Как изменить изображение на кнопке ПУСК?
10. Как изменить обои на рабочем столе?
11. Как узнать имя пользователя версию Windows и т.д.
12. Как скопировать экран в TCanvas?
13. Как извлечь иконку из EXE или DLL?
14. 64 битное кодирование/декодирование
15. Реестр. Свое расширение
16. Преобразование BMP в ICO
17. Преобразование ICO в BMP
18. Как программным путем включить Num Lock?
19. Drag & Drop с TImage
20. Быстрое копирование файлов
21. Вращение изображения
22. Добавление события OnMouseLeave
23. Завершение всех работающих приложений
24. Использование анимированных курсоров

1. Коды всех виртуальных клавиш
vk_LButton = $01;
vk_RButton = $02;
vk_Cancel = $03;
vk_MButton = $04; { генерятся только системой вместе с L & RBUTTON }
vk_Back = $08;
vk_Tab = $09;
vk_Clear = $0C;
vk_Return = $0D;
vk_Shift = $10;
vk_Control = $11;
vk_Menu = $12;
vk_Pause = $13;
vk_Capital = $14;
vk_Escape = $1B;
vk_Space = $20;
vk_Prior = $21;
vk_Next = $22;

vk_End = $23;
vk_Home = $24;
vk_Left = $25;
vk_Up = $26;
vk_Right = $27;
vk_Down = $28;
vk_Select = $29;
vk_Print = $2A;
vk_Execute = $2B;
vk_SnapShot = $2C;
{ vk_Copy = $2C не используется клавиатурой }

vk_Insert = $2D;
vk_Delete = $2E;
vk_Help = $2F;
{ vk_A - vk_Z такие же, как и их ASCII-эквиваленты: 'A' - 'Z' }
{ vk_0 - vk_9 такие же, как и их ASCII-эквиваленты: '0' - '9' }

vk_NumPad0 = $60;
vk_NumPad1 = $61;
vk_NumPad2 = $62;
vk_NumPad3 = $63;
vk_NumPad4 = $64;
vk_NumPad5 = $65;
vk_NumPad6 = $66;
vk_NumPad7 = $67;
vk_NumPad8 = $68;
vk_NumPad9 = $69;
vk_Multiply = $6A;
vk_Add = $6B;
vk_Separator = $6C;
vk_Subtract = $6D;
vk_Decimal = $6E;
vk_Divide = $6F;
vk_F1 = $70;
vk_F2 = $71;
vk_F3 = $72;
vk_F4 = $73;
vk_F5 = $74;

vk_F6 = $75;
vk_F7 = $76;
vk_F8 = $77;
vk_F9 = $78;
vk_F10 = $79;
vk_F11 = $7A;
vk_F12 = $7B;
vk_F13 = $7C;
vk_F14 = $7D;
vk_F15 = $7E;
vk_F16 = $7F;
vk_F17 = $80;
vk_F18 = $81;
vk_F19 = $82;
vk_F20 = $83;
vk_F21 = $84;
vk_F22 = $85;
vk_F23 = $86;
vk_F24 = $87;
vk_NumLock = $90;
vk_Scroll = $91;

2. Как подсчитать занимаемое директорией место. Возвращаемая размерность - байты.):
var
DirBytes : integer;

function TFileBrowser.DirSize(Dir:string):integer;
var
SearchRec : TSearchRec;
Separator : string;
begin
if Copy(Dir,Length(Dir),1)='\' then
Separator := ''
else
Separator := '\';
if FindFirst(Dir+Separator+'*.*',faAnyFile,SearchRec) = 0 then begin
if FileExists(Dir+Separator+SearchRec.Name) then begin
DirBytes := DirBytes + SearchRec.Size;
{Memo1.Lines.Add(Dir+Separator+SearchRec.Name);}
end else if DirectoryExists(Dir+Separator+SearchRec.Name) then begin
if (SearchRec.Name<>'.') and (SearchRec.Name<>'..') then begin
DirSize(Dir+Separator+SearchRec.Name);
end;
end;
while FindNext(SearchRec) = 0 do begin
if FileExists(Dir+Separator+SearchRec.Name) then begin
DirBytes := DirBytes + SearchRec.Size;
{Memo1.Lines.Add(Dir+Separator+SearchRec.Name);}
end else if DirectoryExists(Dir+Separator+SearchRec.Name) then
begin
if (SearchRec.Name<>'.') and (SearchRec.Name<>'..') then begin
DirSize(Dir+Separator+SearchRec.Name);
end;
end;
end;
end;
FindClose(SearchRec);
end;

3. Сохранение параметров шрифта в файле.
function FontToStr(font: TFont): string;
procedure yes(var str:string);
begin
str := str + 'y';
end;
procedure no(var str:string);
begin
str := str + 'n';
end;
begin
{кодируем все атрибуты TFont в строку}
Result := '';
Result := Result + IntToStr(font.Color) + '|';
Result := Result + IntToStr(font.Height) + '|';
Result := Result + font.Name + '|';
Result := Result + IntToStr(Ord(font.Pitch)) + '|';
Result := Result + IntToStr(font.PixelsPerInch) + '|';
Result := Result + IntToStr(font.size) + '|';
if fsBold in font.style then yes(Result) else no(Result);
if fsItalic in font.style then yes(Result) else no(Result);
if fsUnderline in font.style then yes(Result) else no(Result);
if fsStrikeout in font.style then yes(Result) else no(Result);
end;

procedure StrToFont(str: string; font: TFont);
begin
if str = '' then Exit;
font.Color := StrToInt(tok('|', str));
font.Height := StrToInt(tok('|', str));
font.Name := tok('|', str);
font.Pitch := TFontPitch(StrToInt(tok('|', str)));
font.PixelsPerInch := StrToInt(tok('|', str));
font.Size := StrToInt(tok('|', str));
font.Style := [];
if str[0] = 'y' then font.Style := font.Style + [fsBold];
if str[1] = 'y' then font.Style := font.Style + [fsItalic];
if str[2] = 'y' then font.Style := font.Style + [fsUnderline];
if str[3] = 'y' then font.Style := font.Style + [fsStrikeout];
end;

function tok(sep: string; var s: string): string;
function isoneof(c, s: string): Boolean;
var
iTmp: integer;
begin
Result := False;
for iTmp := 1 to Length(s) do
begin
if c = Copy(s, iTmp, 1) then
begin
Result := True;
Exit;
end;
end;
end;
var
c, t: string;
begin
if s = '' then
begin
Result := s;
Exit;
end;
c := Copy(s, 1, 1);
while isoneof(c, sep) do
begin
s := Copy(s, 2, Length(s) - 1);
c := Copy(s, 1, 1);
end;
t := '';
while (not isoneof(c, sep)) and (s <> '') do
begin
t := t + c;
s := Copy(s, 2, length(s)-1);
c := Copy(s, 1, 1);
end;
Result := t;
end;

4. Изменение шрифта у всплывающих подсказок
unit Unit1;

interface

uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls;

type
TForm1 = class(TForm)
Edit1: TEdit;
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

Type
TMyHintWindow = Class (THintWindow)
Constructor Create (AOwner: TComponent); override;
end;

Constructor TMyHintWindow.Create (AOwner: TComponent);
Begin
Inherited Create (Aowner);
Canvas.Font.Name := 'Times New Roman';
Canvas.Font.Size := 14;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
Application.ShowHint := False;
HintWindowClass := TMyHintWindow;
Application.ShowHint := True;
end;

end.

5. Как проверить готовность диска a:\
function DiskInDrive(const Drive: char): Boolean;
var
DrvNum: byte;
EMode: Word;
begin
result := true; // было false
DrvNum := ord(Drive);
if DrvNum >= ord('a') then dec(DrvNum,$20);
EMode := SetErrorMode(SEM_FAILCRITICALERRORS);
try
while DiskSize(DrvNum-$40) = -1 do begin // при неудаче выводим
диалог
if (Application.MessageBox('Диск не готов...'+chr(13)+chr(10)+
'Повторить?',PChar('Диск '+UpperCase(Drive)),mb_OKCANCEL+
mb_iconexclamation{IconQuestion})=idcancel) then begin
Result:=false;
Break;
end;
end;
finally
SetErrorMode(EMode);
end;
end;

6. Перекодировка текста
procedure WinToDos;
var Src, Str:PChar;//Src-строка для перевода Str-конечная
begin
Src := Memo1.Lines.GetText; //Берем текст из TMemo как тип PChar
CharToOem(Src, Str); //API функция для перевода текста
Memo2.Lines.Text := StrPas(Str);//Записываем назад
end;

procedure DosToWin;
var Src, Str:PChar;
begin
Src := Memo1.Lines.GetText; //Берем текст из TMemo как тип PChar
OemToChar(Src, Str); //API функция для перевода текста
Memo2.Lines.Text := StrPas(Str);//Записываем назад
end;

7. Открытие и закрытие привода CD-ROM
unit DriveTools;
interface
uses
Windows, SysUtils, MMSystem;
function CloseCD(Drive : Char) : Boolean;
function OpenCD(Drive : Char) : Boolean;
implementation
function OpenCD(Drive : Char) : Boolean;
Var
Res MciError;
OpenParm: TMCI_Open_Parms;
Flags : DWord;
S : String;
DeviceID : Word;
begin
Result:=false;
S:=Drive+':';
Flags:=mci_Open_Type or mci_Open_Element;
With OpenParm do begin
dwCallback := 0;
lpstrDeviceType := 'CDAudio';
lpstrElementName := PChar(S);
end;
Res := mciSendCommand(0, mci_Open, Flags, Longint(@OpenParm));
IF Res<>0 Then exit;
DeviceID:=OpenParm.wDeviceID;
try
Res:=mciSendCommand(DeviceID, MCI_SET, MCI_SET_DOOR_OPEN, 0);
IF Res=0 Then exit;
Result:=True;
finally
mciSendCommand(DeviceID, mci_Close, Flags, Longint(@OpenParm));
end;
end;
function CloseCD(Drive : Char) : Boolean;
Var
Res : MciError;
OpenParm: TMCI_Open_Parms;
Flags : DWord;
S : String;
DeviceID : Word;
begin
Result:=false;
S:=Drive+':';
Flags:=mci_Open_Type or mci_Open_Element;
With OpenParm do begin
dwCallback := 0;
lpstrDeviceType := 'CDAudio';
lpstrElementName := PChar(S);
end;
Res := mciSendCommand(0, mci_Open, Flags, Longint(@OpenParm));
IF Res<>0 Then exit;
DeviceID:=OpenParm.wDeviceID;
try
Res:=mciSendCommand(DeviceID, MCI_SET, MCI_SET_DOOR_CLOSED, 0);
IF Res=0 Then exit;
Result:=True;
finally
mciSendCommand(DeviceID, mci_Close, Flags, Longint(@OpenParm));
end;
end;
end.

8. Как подавить реакцию на Ctrl+Alt+Del?
В некоторых случаях (например, при работе в полноэкранном режиме, показе своей презентации или экранной заставки ...) бывает полезно заблокировать перечисленные комбинации клавиш. Они блокируются при работе системы в режиме "экранная заставка" , который в свою очередь несложно включить и выключить:
// Включение режима
SystemParametersInfo(SPI_SCREENSAVERRUNNING, 1, 0, 0);
// Выключение режима
SystemParametersInfo(SPI_SCREENSAVERRUNNING, 0, 0, 0);
Кстати, SystemParametersInfo имеет еще кучу полезных ключей SPI_****, подробности см. в win32.hlp

9. Как изменить изображение на кнопке ПУСК?
{ объявляем глобальные переменные }
var
Form1: TForm1;
StartButton: hWnd;
OldBitmap: THandle;
NewImage: TPicture;
{ добавляем следующий код в событие формы OnCreate }
procedure TForm1.FormCreate(Sender: TObject);
begin
NewImage := TPicture.create;
NewImage.LoadFromFile('C:\Windows\Circles.BMP');
StartButton := FindWindowEx
(FindWindow('Shell_TrayWnd',nil),0,'Button', nil);
OldBitmap := SendMessage(StartButton,
BM_SetImage, 0,
NewImage.Bitmap.Handle);
end;
{ Событие OnDestroy }
procedure TForm1.FormDestroy(Sender: TObject);
begin
SendMessage(StartButton,BM_SetImage,0,OldBitmap);
NewImage.Free;
end;

10. Как изменить обои на рабочем столе?
program wallpapr;
uses Registry, WinProcs;
procedure SetWallpaper(sWallpaperBMPPath:String;bTile:boolean);
var
reg : TRegIniFile;
begin
// Изменяем ключи реестра
// HKEY_CURRENT_USER
// Control Panel\Desktop
// TileWallpaper (REG_SZ)
// Wallpaper (REG_SZ)
reg := TRegIniFile.Create('Control Panel\Desktop' );
with reg do begin
WriteString( '', 'Wallpaper',
sWallpaperBMPPath );
if( bTile )then
begin
WriteString('', 'TileWallpaper', '1' );
end else begin
WriteString('', 'TileWallpaper', '0' );
end;
end;
reg.Free;
// Оповещаем всех о том, что мы изменили системные настройки
SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, Nil,
{Эта строка - продолжение предыдущей}SPIF_SENDWININICHANGE );
end;
// пример установки WallPaper по центру рабочего стола
SetWallpaper('c:\winnt\winnt.bmp', False );
//Эту строчку надо написать где-то в программе.

11. Как узнать имя пользователя, версию Windows и т.д.
В uses пpописываешь модуль Registry и дальше так:
var
R:TRegistry;
No:String;
begin
R:=TRegistry.Create;
R.RootKey:=HKEY_LOCAL_MACHINE;
R.OpenKey('\SOFTWARE\Microsoft\Windows\CurrentVersion', False) {если false то пытается откpыть не создавая}
No:=R.ReadString('VersionNumber');
if No=..... then ...... else ......
end;
Кроме того, обязательно посмотрите на список функций WinAPI, имена которых начинаются с Get.... Например, GetComputerName, GetVersionEx, GetSystemInfo, SystemParametersInfo.

12. Как скопировать экран в TCanvas?
var
bmp: TBitmap;
DC: HDC;
begin
bmp:=TBitmap.Create;
bmp.Height:=Screen.Height;
bmp.Width:=Screen.Width;
DC:=GetDC(0); //Дескpиптоp экpана
bitblt(bmp.Canvas.Handle, 0, 0, Screen.Width, Screen.Height,
DC, 0, 0, SRCCOPY);
bmp.SaveToFile('Screen.bmp');
ReleaseDC(0, DC);
end;

13. Как извлечь иконку из EXE или DLL
Процесс получения иконок из .EXE, .DLL или .ICO файлов полностью идентичен.
Различие только в том, что в .ICO файле может храниться только одна иконка, а в
.EXE и .DLL несколько. Для получения иконок из файлов, в модуле ShellAPI, есть
функция:
function ExtractIcon(Inst: THandle; FileName: PChar; IconIndex: Word): HIcon;
где
Inst - указатель на приложение вызвавшее функцию, FileName - имя файла
из которого необходимо получить иконку, IconIndex - номер необходимой иконки.
Если функция возвращает значение не равное нулю, то в файле есть следующая иконка.
В данном примере в компонент Image1 выводится иконка запущенного файла.
USES ShellAPI;
procedure TForm1.FormCreate(Sender: TObject);
VAR A: ARRAY [0..78] OF Char;
begin

{Получение имени запущенного файла}
StrPCopy(A, ParamStr(0));
{Вывод на экран нулевой иконки из файла}
Image1.Picture.Icon.Handle := ExtractIcon(HInstance, A, 0);
end;

14. 64-битное кодирование/декодирование
Const
Base64Table='ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';

function Base64Decode(cStr:string):string;
var ResStr:string;
DecStr:string;
RecodeLine : array [1..76] of byte;
f1,f2 : word;
l:integer;
begin
l :=length(cStr);
ResStr:='';
for f1:=1 to l do
if cStr[f1]='=' then RecodeLine[f1]:=0
else RecodeLine[f1]:=pos(cStr[f1],Base64Table)-1;
f1:=1;
while f1 begin
DecStr:=chr(byte(RecodeLine[f1] shl 2)+RecodeLine[f1+1] shr 4)+
chr(byte(RecodeLine[f1+1] shl 4)+RecodeLine[f1+2] shr 2)+
chr(byte(RecodeLine[f1+2] shl 6)+RecodeLine[f1+3]);
ResStr:=ResStr+DecStr;
inc(f1,4);
end;
Base64Decode:=ResStr;
end;

15. Реестр. Свое расширение
//Use the registry to register your own filetype. uses registry;

procedure TForm1.RegisterFileType(prefix:String; exepfad:String);
var reg:TRegistry;
begin
reg:=TRegistry.Create;
reg.RootKey:=HKEY_CLASSES_ROOT;
//create a new key --> .pci
reg.OpenKey('.'+prefix,True);
//create a new value for this key --> pcifile
reg.WriteString('',prefix+'file');
reg.CloseKey; //create a new key --> pcifile
reg.CreateKey(prefix+'file');
//create a new key pcifile\DefaultIcon
reg.OpenKey(prefix+'file\DefaultIcon',True);
//and create a value where the icon is stored --> c:\project1.exe,0 reg.WriteString('',exepfad+',0');
reg.CloseKey;
reg.OpenKey(prefix+'file\shell\open\command',True);
//create value where exefile is stored --> c:\project1.exe "%1"
reg.WriteString('',exepfad+' "%1"'); reg.CloseKey;
reg.Free;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
RegisterFileType('pci','c:\project1.exe');
end;

16. Как преобразовать BMP (32x32) в ICO?
unit main;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms,Dialogs,ExtCtrls, StdCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
Image1: TImage;
Image2: TImage;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var winDC, srcdc, destdc : HDC;
oldBitmap : HBitmap;
iinfo : TICONINFO;
begin
GetIconInfo(Image1.Picture.Icon.Handle, iinfo);

WinDC := getDC(handle);
srcDC := CreateCompatibleDC(WinDC);
destDC := CreateCompatibleDC(WinDC);
oldBitmap := SelectObject(destDC, iinfo.hbmColor);
oldBitmap := SelectObject(srcDC, iinfo.hbmMask);

BitBlt(destdc, 0, 0, Image1.picture.icon.width,
Image1.picture.icon.height,
srcdc, 0, 0, SRCPAINT);
Image2.picture.bitmap.handle := SelectObject(destDC, oldBitmap);
DeleteDC(destDC);
DeleteDC(srcDC);
DeleteDC(WinDC);

image2.Picture.Bitmap.savetofile(ExtractFilePath(Application.ExeName)
+ 'myfile.bmp');
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
image1.picture.icon.loadfromfile('c:\myicon.ico');
end;

end.

17. Как преобразовать ICO в BMP?
var
Icon : TIcon;
Bitmap : TBitmap;
begin
Icon := TIcon.Create;
Bitmap := TBitmap.Create;
Icon.LoadFromFile('c:\picture.ico');
Bitmap.Width := Icon.Width;
Bitmap.Height := Icon.Height;
Bitmap.Canvas.Draw(0, 0, Icon );
Bitmap.SaveToFile('c:\picture.bmp');
Icon.Free;
Bitmap.Free;
end;

18. Как программным путем включить Num Lock?
procedure TMyForm.Button1Click(Sender: TObject);
Var
KeyState : TKeyboardState;
begin
GetKeyboardState(KeyState);
if (KeyState[VK_NUMLOCK] = 0) then
KeyState[VK_NUMLOCK] := 1
else
KeyState[VK_NUMLOCK] := 0;
SetKeyboardState(KeyState);
end;
Для Caps Lock замените VK_NUMLOCK на VK_CAPITAL.

19. Drag & Drop с TImage
procedure TForm1.Panel1DragDrop(Sender, Source: TObject; X, Y: Integer);
begin
WITH Source AS TImage DO
BEGIN
Left := X;
Top := Y;
END;
end;
procedure TForm1.Panel1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
Accept := Source IS TImage;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
WITH TImage.Create(Self) DO
BEGIN
Parent := Panel1;
AutoSize := True;
Picture.LoadFromFile('...');
DragMode := dmAutomatic;
OnDragOver := Panel1DragOver;
OnDragDrop := Panel1DragDrop;
END;
end;

20. Быстрое копирование файлов
procedure CopyFile( Source, Dest : string );
var
SrcFile : Integer;
DestFile : Integer;
S : string;
RetCode : Longint;
OpenFileBuf : TOFStruct;
FName : array[ 0..255 ] of Char;
begin
StrPCopy( FName, Source );
SrcFile := LZOpenFile( FName, OpenFileBuf, of_Read );
StrPCopy( FName, Dest );
DestFile := LZOpenFile( FName, OpenFileBuf, of_Create );

RetCode := LZCopy( SrcFile, DestFile );
if RetCode >= 0 then
begin
LZClose( SrcFile );
LZClose( DestFile );
end
else
begin
Str( RetCode, S );
MessageDlg( 'Не могу скопировать ' + Source + ' в ' +
Dest + #13 + 'Код ошибки = ' + S, mtError, [mbOk], 0 );
end;
end;

21. Вращение изображения
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;

22. Добавление события 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.

23. Завершение всех работающий приложений
Ниже приведен код, который поможет вам завершить ВСЕ задачи без всяких уведомлений о необходимости сохранения данных.
Поэтому, прежде чем запустить этот код, убедитесь в наличии сохраненных данных и в том, что пользователь осведомлен об этой операции.
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;

24. Использование анимированных курсоров
const crMyCursor = 1;

procedure TForm1.FormCreate(Sender: TObject);
begin
// Загружаем курсор. Единственный способ для этого
Screen.Cursors[crMyCursor] :=
LoadCursorFromFile('c:\mystuff\mycursor.ani');
// Используем курсор на форме
Cursor := crMyCursor;
end;


Категория: Delphi, Pascal, ObjectPascal | Просмотров: 1911 | Добавил: ДядяВолк (11.08.2010) | Рейтинг: 0.0/0
Источник: http://quadrathell.cn.ua/ | Автор: Михаил Христосенко |
HTML ссылка на материал:
BB ссылка на материал:
Похожие материалы :
Возможно вам будет интересно:
Создание многопользовательской(online) игры на Game Maker. (часть 2) (0)
[Статья] Создаем дополнительное оружие (2)
Инветарь на Game Maker (0)
Знакомство с Движком! (0)
Полный туториал по использованию Radimp (2)
Серия уроков по 3d Rad (0)
Циклы (0)
Создание многопользовательской(online) игры на Game Maker. (часть 3) (0)
Пишем игровой сюжет (10)
Поиск файлов на винчестере в Delphi (0)
Уроки по C/C++ (Части с 21 по 40) (0)
Создание наземного врага в платформере (2)
PHP и MySQL – Теоретический курс. Введение. (2)
Физика (Blitz 3D) (0)
Уроки Scirra Construct (0)
Всего комментариев: 0
Добавлять комментарии могут только зарегистрированные пользователи.
[ Регистрация | Вход ]
Мы в социальных сетях

Поиск
Поиск по всему сайту:
Поиск по разделу:

Панель пользователя
Здравствуйте, Гость


Ник:
Пароль:
Запомнить :

Ваш IP: 54.166.130.22

Случайные конструкторы

Случайные движки

Случайные статьи

Статистика
Онлайн всего: 2
Гостей: 2
Пользователей: 0

На сайте были:
FireOfSteel

При полном или частичном копировании материалов сайта ссылка на Make-Games.ru обязательна. Make-Games.ru © 2008 - 2017 Хостинг от uWeb
Топ Разработка игр Рейтинг@Mail.ru