БОЛЬШОЙ FAQ ПО DELPHI
Проблема передачи записи
Может это не то, что вы ищете, но идея такая:
Определите базовый класс с именем, скажем, allrecs:
tAllrecs = class
function getVal (field: integer): string; virtual;
end;
|
Затем создаем классы для каждой записи:
recA = class (tAllrecs)
this : Integer;
that : String;
the_other : Integer;
function getVal (field: integer): string; virtual;
end;
|
Затем для каждой функции класса определите возвращаемый результат:
function recA.getVal (field: integer); string;
begin
case field of
1: getVal := intToStr (this);
2: getVal := that;
3: getVal := intToStr (the_other);
end;
end;
|
Затем вы можете определить
function myFunc (rec: tAllrecs; field: integer);
begin
label2.caption := allrecs.getVal(field);
end;
|
затем вы можете вызвать myFunc с любым классом, производным от tAllrecs,
например:
myFunc (recA, 2);
myFunc (recB, 29);
|
(getVal предпочтительно должна быть процедурой (а не функцией) с тремя
var-параметрами, возвращающими имя, тип и значение.)
Все это работает, т.к. данный пример я взял из моего рабочего проекта.
[Sid Gudes, cougar@roadrunner.com]
Если вы хотите за один раз передавать целую запись, установите на входе ваших
функций/процедур тип 'array of const' (убедитесь в правильном приведенни типов).
Это идентично 'array of TVarRec'. Для получения дополнительной информации о
системных константах, определяемых для TVarRec, смотри электронную справку по
Delphi.
Как проверить, включён ли ActiveDesktop
function IsActiveDeskTopOn: Boolean;
var
h: hWnd;
begin
h := FindWindow('Progman', nil);
h := FindWindowEx(h, 0, 'SHELLDLL_DefView', nil);
h := FindWindowEx(h, 0, 'Internet Explorer_Server', nil);
Result := h <> 0;
end;
|
Как проверить, имеем ли мы административные привилегии в системе
|
Интернетчика спросили:
- Что такое "Червона Рута"?
- Это женщина-админ на сервере Компартии.
|
type
PTOKEN_GROUPS = TOKEN_GROUPS^;
function RunningAsAdministrator (): Boolean;
var
SystemSidAuthority: SID_IDENTIFIER_AUTHORITY = SECURITY_NT_AUTHORITY;
psidAdmin: PSID;
ptg: PTOKEN_GROUPS = nil;
htkThread: Integer; { HANDLE }
cbTokenGroups: Longint; { DWORD }
iGroup: Longint; { DWORD }
bAdmin: Boolean;
begin
Result := false;
if not OpenThreadToken(GetCurrentThread(), // get security token
TOKEN_QUERY, FALSE, htkThread) then
if GetLastError() = ERROR_NO_TOKEN then
begin
if not OpenProcessToken(GetCurrentProcess(),
TOKEN_QUERY, htkThread) then
Exit;
end
else
Exit;
if GetTokenInformation(htkThread, // get #of groups
TokenGroups, nil, 0, cbTokenGroups) then
Exit;
if GetLastError() <> ERROR_INSUFFICIENT_BUFFER then
Exit;
ptg := PTOKEN_GROUPS( getmem( cbTokenGroups ) );
if not Assigned(ptg) then
Exit;
if not GetTokenInformation(htkThread, // get groups
TokenGroups, ptg, cbTokenGroups, cbTokenGroups) then
Exit;
if not AllocateAndInitializeSid(SystemSidAuthority,
2, SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_ADMINS,
0, 0, 0, 0, 0, 0, psidAdmin) then
Exit;
iGroup := 0;
while iGroup < ptg^.GroupCount do // check administrator group
begin
if EqualSid(ptg^.Groups[iGroup].Sid, psidAdmin) then
begin
Result := TRUE;
break;
end;
Inc( iGroup );
end;
FreeSid(psidAdmin);
end;
|
Как узнать активно ли приложение
|
Вчера в Сиэтле после упоминания Биллом Гейтсом бета-версии новой программы Майкрософта произошло землетрясение. Пользователи с ужасом ждут объявления о выходе финальной версии продукта.
|
if Application.Active then
form1.Caption := 'active'
else
form1.Caption := 'not active';
|
Как определить - находится ли приложение в режиме отладки
|
Сидит программист глубоко в отладке. Подходит сынишка:
- Папа, почему солнышко каждый день встает на востоке, а садится на западе?
- Ты это проверял?
- Проверял.
- Хорошо проверял?
- Хорошо.
- Работает?
- Работает.
- Каждый день работает?
- Да, каждый день.
- Тогда ради бога, сынок, ничего не трогай, ничего не меняй.
|
Обычно господа взломщики, для того, чтобы взломать защиту приложения, запускают его в режиме отладки и анализируют машинный код для определения точки перехвата ввода пароля с клавиатуры.
Обычно таким способом ломаются игрушки :)
Конечно данный способ не сможет полностью защитить Ваш программный продукт от взлома, но прекратить выполнение секретного кода - запросто. Для этого мы будем использовать API функцию IsDebuggerPresent. Единственный недостаток этой функции, заключается в том, что она не работет под Windows 95.
Теперь посмотрим как эту функцию реализовать в Delphi:
function DebuggerPresent: boolean;
type
TDebugProc = function: boolean; stdcall;
var
Kernel32: HMODULE;
DebugProc: TDebugProc;
begin
Result := False;
Kernel32 := GetModuleHandle('kernel32.dll');
if Kernel32 <> 0 then
begin
@DebugProc := GetProcAddress(Kernel32, 'IsDebuggerPresent');
if Assigned(DebugProc) then
Result := DebugProc;
end;
end;
|
А это окончательный пример вызова нашей функции:
if DebuggerPresent then
ShowMessage('debugging')
else
ShowMessage('NOT debugging');
|
Как узнать есть ли в заданном CD-ROMе Audio CD
Можно использовать функцию Windows API GetDriveType() чтобы определить является ли дисковод CD-ROM'мом. И функцию API GetVolumeInformation() чтобы проверить VolumeName на равенство 'Audio CD'.
function IsAudioCD(Drive : char) : bool;
var
DrivePath : string;
MaximumComponentLength : DWORD;
FileSystemFlags : DWORD;
VolumeName : string;
begin
sult := false;
DrivePath := Drive + ':\';
if GetDriveType(PChar(DrivePath)) <> DRIVE_CDROM then
exit;
SetLength(VolumeName, 64);
GetVolumeInformation(PChar(DrivePath),PChar(VolumeName),
Length(VolumeName),nil,MaximumComponentLength,FileSystemFlags,nil,0);
if lStrCmp(PChar(VolumeName),'Audio CD') = 0 then
result := true;
end;
function PlayAudioCD(Drive : char) : bool;
var
mp : TMediaPlayer;
begin
result := false;
Application.ProcessMessages;
if not IsAudioCD(Drive) then
exit;
mp := TMediaPlayer.Create(nil);
mp.Visible := false;
mp.Parent := Application.MainForm;
mp.Shareable := true;
mp.DeviceType := dtCDAudio;
mp.FileName := Drive + ':';
mp.Shareable := true;
mp.Open;
Application.ProcessMessages;
mp.Play;
Application.ProcessMessages;
mp.Close;
Application.ProcessMessages;
mp.free;
result := true;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if not PlayAudioCD('D') then
ShowMessage('Not an Audio CD');
end;
|
Как проверить инсталлирована ли BDE
|
Виртуальная любовь.
Любимая! Я инсталлировался в тебя по уши. Ты переформатировала все мои мозги. В моей оперативной памяти еще не было ничего подобного. Моя винда глючит. При виде тебя у меня повышается тактовая частота, и винт увеличивается в объеме. Давай создадим с тобой директорию. Но сначала - романтический ужин при зажженных экранах. Можешь сама вызвать меню. Лично я предпочитаю CD-ром, но обещаю не перезагружаться. А потом мы отправимся на твой сайт. Или на мой. Мы откроем друг другу свои файлы. Я войду и выйду, войду и выйду. Без всяких зависаний. Вот увидишь, тебе понравится мой драйвер. И не беспокойся за свою материнскую плату, у меня есть антивирусы. Главное - не забывай вовремя сохраняться. Тебе нужно подумать? Хорошо. Когда будешь готова, кликни два раза, и я тут как тут. Только пожалуйста, как можно реже используй свою саундкарту. Тогда у нас с тобой будет полный и взаимный апгрейд.
|
Проверить реестр:
with TRegistry.create do
begin
Rootkey := HKEY_LOCAL_MACHINE;
OpenKey('SOFTWARE\BORLAND\DATABASE ENGINE', false);
CFGFile := ReadString('CONFIGFILE01');
Free;
end;
|
Проверяем установлена ли BDE
uses Bde;
function BDEInstalled: Boolean;
begin
Result := (dbiInit(nil) = 0)
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if BDEInstalled then
ShowMessage('BDE is installed.')
else
ShowMessage('BDE is not installed.')
end;
|
Как узнать - установлена ли BDE
Следующая функция получает структуру SysVersion и записывает результаты в stringlist.
uses dbierrs, DBTables;
function fDbiGetSysVersion(SysVerList: TStringList): SYSVersion;
var
Month, Day, iHour, iMin, iSec: Word;
Year: SmallInt;
begin
Check(DbiGetSysVersion(Result));
if (SysVerList <> nil) then
begin
with SysVerList do
begin
Clear;
Add(Format('ENGINE VERSION=%d', [Result.iVersion]));
Add(Format('INTERFACE LEVEL=%d', [Result.iIntfLevel]));
Check(DbiDateDecode(Result.dateVer, Month, Day, Year));
Add(Format('VERSION DATE=%s', [DateToStr(EncodeDate
(Year, Month, Day))]));
Check(DbiTimeDecode(Result.timeVer, iHour, iMin, iSec));
Add(Format('VERSION TIME=%s', [TimeToStr(EncodeTime
(iHour, iMin, iSec div 1000, iSec div 100))]));
end;
end;
end;
|
Вызов этой функции выглядит следующим образом:
var
hStrList: TStringList;
Ver: SYSVersion;
begin
hStrList:= TStringList.Create;
try
Ver := fDbiGetSysVersion(hStrList);
except
ShowMessage('BDE not installed !');
end;
ShowMessage(IntToStr(Ver.iVersion));
Memo1.Lines.Assign(hStrList);
hStrList.Destroy;
end;
|
Возможные резултаты (отображаемые в memo-поле):
ENGINE VERSION=500
INTERFACE LEVEL=500
VERSION DATE=09.06.98
VERSION TIME=17:06:13
|
Как узнать - установлена ли BDE 2
|
Компания Microsoft выпустила новую игру под названием Windows 2001. Цель игры - как можно за меньшее количество попыток установить её!
|
Читаем ключ в реестре:
RootKey := HKEY_LOCAL_MACHINE;
OpenKey(`SOFTWARE\Borland\Database Engine`, False);
try
s := ReadString(`CONFIGFILE01`);
//BDE установлена
finally
CloseKey;
end;
|
Как узнать - установлена ли BDE 3
IsBDEExist := (dbiInit(nil) = 0)
|
Как проверить соединение с Интернетом
|
Сидят два инетчика.
Один читает вслух объявление в газете:
- Красивая девушка. 90х60х90. Выполнит все твои желания. Плата - 1000р. за ночь!
Второй, заглядывая в газету:
- А со скольки у нее ночь?
|
Для работы Вам необходимо импортировать функцию InetIsOffline из URL.DLL:
function InetIsOffline(Flag: Integer): Boolean;
stdcall; external 'URL.DLL';
|
а затем поместить в программу простой вызов функции для проверки статуса соединения:
if InetIsOffline(0) then
ShowMessage('This computer is not connected to Internet!')
else
ShowMessage('You are connected to Internet!');
|
но ещё нужно учитывать, что функция эта выдает false не только, когда комп подключен к Интернету, но и когда ЕЩЕ НЕ БЫЛО ПОПЫТОК подключения (or if no attempt has yet been made to connect to the Internet), как сказано в официальной документации Microsoft по MSDN...
Да, умом Microsoft не понять!
Считываем информацию из реестра о наличии соединения с интернетом
|
Звонит любовник любовнице:
- Давай встретимся.
- Давай.
- А где?
- Давай у меня дома.
- А муж?
- А его сейчас нет, он в интернете.
|
Информация о том, есть ли в данный момент соединение с Интернетом, лежит в реестре. Если каждую секунду считывать это значение, то можно определить, когда соединение было установлено и разорвано. При этом чтение их реестра не будет сильно загружать компьютер - весь HKEY_LOCAL_MACHINE лежит в памяти и обращение к диску не понадобится. Естественно, здесь опять понадобится резидентная программа.
Для работы с реестром здесь используются непосредственно функции WinAPI. Это позволяет сэкономить память и ускорить проверку соединения. При изменении соединения вызывается процедура InetConnectionChange. Таким образом, чтобы изменить действия программы, достаточно переписать эту процедуру. Эта программа при соединении с Интернетом создает tray. В его меню включены пункты открыть страницу http://program.dax.ru и послать письмо на program@dax.ru с темой subscribe. При выходе из Интернета tray исчезае
program Project1;
uses
Windows, ShellAPI, Messages;
const
ClassName = 'MyResident'; // Имя класса
{ Это сообщение будет генерироваться при событиях с tray }
WM_NOTIFYTRAYICON = WM_USER + 1;
var
menu: hMenu = 0; // Всплывающее меню
mywnd: hWnd; // Окно программы
reg: HKEY;
connection: longint;
// Создание всплывающего меню:
function CreateMyMenu: hMenu;
begin
result := CreatePopupMenu;
if result = 0 then
Exit;
AppendMenu(result, MF_STRING, 0, 'site');
AppendMenu(result, MF_STRING, 1, 'letter');
AppendMenu(result, MF_SEPARATOR, 2, nil);
AppendMenu(result, MF_STRING, 3, 'Exit');
end;
// Создание Tray:
procedure CreateTray;
var
tray: TNotifyIconData;
begin
with tray do
begin
cbSize := sizeof(TNotifyIconData);
wnd := mywnd;
uID := 0;
uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
uCallBackMessage := WM_NOTIFYTRAYICON;
hIcon := LoadIcon(0, IDI_ASTERISK);
szTip := ('My Resident');
end;
Shell_NotifyIcon(NIM_ADD, @tray);
end;
// Удаление tray:
procedure DeleteTray;
var
tray: TNotifyIconData;
begin
with tray do
begin
cbSize := sizeof(TNotifyIconData);
wnd := mywnd;
uID := 0;
end;
Shell_NotifyIcon(NIM_DELETE, @tray);
end;
// Изменение соединения
procedure InetConnectionChange(connecting: boolean);
begin
if connecting then
begin
CreateTray; // Создание tray
menu := CreateMyMenu; // Создание муню
end
else
begin
DestroyMenu(menu); // удалить мнею
DeleteTray; // удалить tray
menu := 0;
end;
end;
// Главная оконная процедура:
function MyWndProc(wnd: hWnd; msg, wParam,
lParam: longint): longint; stdcall;
var
p: TPoint;
DataType, DataSize: cardinal;
begin
case msg of
WM_TIMER:
begin
// проверка соединения:
DataSize := 4;
if RegQueryValueEx(reg, 'Remote Connection', nil, @DataType,
@connection, @DataSize) <> ERROR_SUCCESS then
MessageBeep(0);
if (connection = 0) <> (menu = 0) then
InetConnectionChange(connection > 0);
result := 0;
end;
WM_NOTIFYTRAYICON:
begin // Событие tray
// Если нажата правая кнопка, показать меню:
if lparam = WM_RBUTTONUP then
begin
SetForegroundWindow(mywnd);
GetCursorPos(p);
TrackPopupMenu(menu, TPM_LEFTALIGN, p.x, p.x, 0, wnd, nil);
end;
result := 0;
end;
WM_COMMAND:
begin // Выбран пункт меню
{ В зависимости от выбранного пункта меню открывается
program.dax.ru в браузере или создается письмо или
закрывается программа: }
case loword(wparam) of
0: ShellExecute(hinstance, nil, 'http://program.dax.ru/',
nil, nil, SW_SHOWNORMAL);
1: ShellExecute(hinstance, nil,
'mailto:program@dax.ru?subject=subscribe',
nil, nil, SW_SHOWNORMAL);
else
SendMessage(mywnd, WM_CLOSE, 0, 0);
end;
result := 0;
end;
WM_DESTROY:
begin // Закрытие программы
DeleteTray; // Удаление Tray
PostQuitMessage(0);
result := 0;
end;
else
result := DefWindowProc(wnd, msg, WParam, LParam);
end;
end;
// Создание окна:
function CreateMyWnd: hWnd;
var
wc: WndClass;
begin
// Регистрация класса:
wc.style := CS_HREDRAW or CS_VREDRAW;
wc.lpfnWndProc := @MyWndProc;
wc.cbClsExtra := 0;
wc.cbWndExtra := 0;
wc.hInstance := hInstance;
wc.hIcon := LoadIcon(hinstance, IDI_ASTERISK);
wc.hCursor := LoadCursor(hinstance, IDC_ARROW);
wc.hbrBackground := COLOR_INACTIVECAPTION;
wc.lpszMenuName := nil;
wc.lpszClassName := ClassName;
if RegisterClass(wc) = 0 then
halt(0);
// Создание окна:
result := CreateWindowEx(WS_EX_APPWINDOW, ClassName,
'My Window', WS_POPUP, 100, 100, 200, 200, 0, 0, hInstance, nil);
if result = 0 then
halt(0);
end;
var
msg: TMsg;
begin
mywnd := CreateMyWnd; // Создание окна
// Установка низкого приоритета:
SetThreadPriority(GetCurrentThread, THREAD_PRIORITY_IDLE);
if RegOpenKeyEx(HKEY_LOCAL_MACHINE,
'System\CurrentControlSet\Services\RemoteAccess', 0,
KEY_NOTIFY, reg) <> ERROR_SUCCESS then
halt(0);
SetTimer(mywnd, 0, 1000, nil); // Создание таймера
// Распределение сообщений:
while (GetMessage(msg, 0, 0, 0)) do
begin
TranslateMessage(msg);
DispatchMessage(msg);
end;
KillTimer(mywnd, 0); // Удаление таймера
RegCloseKey(reg); // Закрытие раздела реестра
end.
|
Проверить соединение с Интернетом и узнать тип соединения
|
Директору пивзавода от группы программистов. Заявление:
"Просим Вас предоставить выделенную линию со скоростью 0,5 л/сек."
|
По нажатию на кнопку в появляется сообщение. Если не 0 - есть соединения с Интернетом. А в заголовке формы показывается тип соединения.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Registry, WinSock, WinInet, StdCtrls;
type
TConnectionType = (ctNone, ctProxy, ctDialup);
function ConnectedToInternet : TConnectionType;
function RasConnectionCount : Integer;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
//For RasConnectionCount =======================
const
cERROR_BUFFER_TOO_SMALL = 603;
cRAS_MaxEntryName = 256;
cRAS_MaxDeviceName = 128;
cRAS_MaxDeviceType = 16;
type
ERasError = class(Exception);
HRASConn = DWord;
PRASConn = ^TRASConn;
TRASConn = record
dwSize: DWORD;
rasConn: HRASConn;
szEntryName: array[0..cRAS_MaxEntryName] of Char;
szDeviceType : array[0..cRAS_MaxDeviceType] of Char;
szDeviceName : array [0..cRAS_MaxDeviceName] of char;
end;
TRasEnumConnections =
function (RASConn: PrasConn; { buffer to receive Connections data }
var BufSize: DWord; { size in bytes of buffer }
var Connections: DWord { number of Connections written to buffer }
): LongInt; stdcall;
//End RasConnectionCount =======================
function ConnectedToInternet: TConnectionType;
var
Reg : TRegistry;
bUseProxy : Boolean;
UseProxy : LongWord;
begin
Result := ctNone;
Reg := TRegistry.Create;
with REG do
try
try
RootKey := HKEY_CURRENT_USER;
if OpenKey('\Software\Microsoft\Windows\CurrentVersion\Internet settings',False) then
begin
//I just try to read it, and trap an exception
if GetDataType('ProxyEnable') = rdBinary then
ReadBinaryData('ProxyEnable', UseProxy, SizeOf(LongWord) )
else
begin
bUseProxy := ReadBool('ProxyEnable');
if bUseProxy then
UseProxy := 1
else
UseProxy := 0;
end;
if (UseProxy <> 0) and ( ReadString('ProxyServer') <> '' ) then
Result := ctProxy;
end;
except
//Obviously not connected through a proxy
end;
finally
Free;
end;
//We can check RasConnectionCount even if dialup networking is not installed
//simply because it will return 0 if the DLL is not found.
if Result = ctNone then
begin
if RasConnectionCount > 0 then
Result := ctDialup;
end;
end;
function RasConnectionCount : Integer;
var
RasDLL : HInst;
Conns : array[1..4] of TRasConn;
RasEnums : TRasEnumConnections;
BufSize : DWord;
NumConns : DWord;
RasResult : Longint;
begin
Result := 0;
//Load the RAS DLL
RasDLL := LoadLibrary('rasapi32.dll');
if RasDLL = 0 then
exit;
try
RasEnums := GetProcAddress(RasDLL,'RasEnumConnectionsA');
if @RasEnums = nil then
raise ERasError.Create('RasEnumConnectionsA not found in rasapi32.dll');
Conns[1].dwSize := Sizeof (Conns[1]);
BufSize := SizeOf(Conns);
RasResult := RasEnums(@Conns, BufSize, NumConns);
if (RasResult = 0) or (Result = cERROR_BUFFER_TOO_SMALL) then
Result := NumConns;
finally
FreeLibrary(RasDLL);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(IntToStr(RasConnectionCount));
if ConnectedToInternet=ctNone then
Form1.Caption:='ctNone';
if ConnectedToInternet=ctProxy then
Form1.Caption:='ctProxy';
if ConnectedToInternet=ctDialup then
Form1.Caption:='ctDialup';
end;
end.
|
Как определить закрытие командного окна в консольном приложении
|
Молодая привлекательная женщина на пляже. Одна. Подходит молодой человек:
- Девушка, вы такая красивая, неужели не скучно одной?
- Молодой человек, вы кем работаете?
- Программистом...
- Представьте. Приезжаете на отдых, а кругом компьютеры, компьютеры...
- КАЙФ!
- 286-е... и без модемов... - !!!!!!!!
|
Консольные приложения Win32 запускаются в командном окне. Для того, чтобы консольное приложение могло определить когда консоль закрывается, надо зарегистрировать консольный обработчик управления и в выражении case искать следующие значения:
- CTRL_CLOSE_EVENT Пользователь закрывает консоль
- CTRL_LOGOFF_EVENT Пользователь завершает сеанс работы (log off)
- CTRL_SHUTDOWN_EVENT Пользователь выключает систему (shut down)
Как это делается, можно посмотреть в примере CONSOLE. Более подробную информацию можно посмотреть в руководстве Win32 application programming interface (API) в разделе SetConsoleCtrlhandler().
Как определить, запущена ли Delphi
Иногда, особенно при создании компонент, бывает необходимо получить доступ к
компоненту только когда запущена Delphi IDE.
If FindWindow('TAppBuilder', nil) <= 0 then
ShowMessage('Delphi is not running!')
else
ShowWindow('Delphi is running!');
|
Проверить, вставлен ли диск
|
Сын звонит отцу на работу:
- Папа, что значит "HDD format completed".
- А это, сынок значит, что к вечеру ты - труп!!!
|
function DiskInDrive(Drive: Char): Boolean;
// Disk can be a floppy, CD-ROM,...
var
ErrorMode: Word;
begin
{ make it upper case }
if Drive in ['a'..'z'] then Dec(Drive, $20);
{ make sure it's a letter }
if not (Drive in ['A'..'Z']) then
raise EConvertError.Create('Not a valid drive ID');
{ turn off critical errors }
ErrorMode := SetErrorMode(SEM_FailCriticalErrors);
try
{ drive 1 = a, 2 = b, 3 = c, etc. }
if DiskSize(Ord(Drive) - $40) = -1 then
Result := False
else
Result := True;
finally
{ Restore old error mode }
SetErrorMode(ErrorMode);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if DiskInDrive('a') = False then
ShowMessage('Drive not ready');
end;
|
Проверить готовность диска без появления окна ошибки Windows
|
Игра "О счастливчик"
Игрок - Прошу убрать два неверных варианта.
Ведущий - Итак, дорогой компютер, уберите пожалуста два неверных варианта.
Надпись на мониторах - "Программа выполнила недопустимую ошибку и будет закрыта"
Ведущий - Что-ж по просьбе компании Microsoft - реклама....
|
Вы можете использовать функцию Windows API SetErrorMode() для отключения диалога Window's critical Error.
Сначала определяем нужную функцию:
function IsDriveReady(DriveLetter: char): bool;
var
OldErrorMode: Word;
OldDirectory: string;
begin
OldErrorMode := SetErrorMode(SEM_NOOPENFILEERRORBOX);
GetDir(0, OldDirectory);
{$I-}
ChDir(DriveLetter + ':\');
{$I+}
if IoResult <> 0 then
Result := False
else
Result := True;
ChDir(OldDirectory);
SetErrorMode(OldErrorMode);
end;
|
затем используем её:
if not IsDriveReady('A') then
ShowMessage('Drive Not Ready')
else
ShowMessage('Drive is Ready');
|
Как узнать, используется ли файл в данный момент другим приложением
function E9FileStatus(const Origin: string): boolean;
var
F: TFileStream;
begin
{
Значение Описание
fmCreate Созда¸т файл с данным именем. Если файл существует, то открыть его в
режиме записи.
fmOpenRead Открыть файл только для чтения.
fmOpenWrite Открыть файл только на запись. При этом запись в файл заменит вс¸ его
содержимое.
fmOpenReadWrite Открыть файл скорее для изменения содержимого чем для замены его.
Режим доступа должен иметь одно из следующих значений:
Значение Описание
fmShareCompat Доступ к файлу совместим с FCB.
fmShareExclusive Другое приложение не может открыть файл для различных целей.
fmShareDenyWrite Другое приложение может открыть файл для чтения, но не для записи.
fmShareDenyRead Другое приложение может открыть файл для записи, но не для чтения.
fmShareDenyNone Разрешить другим файлам делать с файлом и чтени и запись.
Если файл невозможно открыть, то Create сгенерирует исключение.
Возвращает true если файл не заблокирован
}
try
F := TFileStream.Create(Origin, fmOpenReadWrite or fmShareExclusive);
try
Result := true;
finally
F.Free;
end;
except
Result := false;
end;
end;
|
Как узнать, используется ли файл в данный момент другим приложением 2
function ApplicationUse(fName: string): boolean;
var
HFileRes: HFILE;
begin
Result := false;
if not FileExists(fName) then exit;
HFileRes := CreateFile(pchar(fName), GENERIC_READ or GENERIC_WRITE, 0, nil,
OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
Result := (HFileRes = INVALID_HANDLE_VALUE);
if not Result then CloseHandle(HFileRes);
end;
// Далее следует пример использования этой функции:
procedure TForm1.Button1Click(Sender: TObject);
begin
if ApplicationUse('c:\project1.exe') then
ShowMessage('Application in use')
else
ShowMessage('Application not in use');
end;
|
Если форма не существует - создать
IF frmNewForm = NIL THEN
frmNewForm := TNewForm.Create( owner );
frmNewForm.Show;
|
Как определить - подключен ли компьютер к сети
|
Летит компьютеp с 9-го этажа, и дyмает: "Вот бы щас зависнyть..."
|
Воспользуемся функцией GetSystemMetrics(), переслав ей флаг SM_NETWORK:
procedure TForm1.Button2Click(Sender: TObject);
begin
if GetSystemMetrics(SM_NETWORK) and $01 = $01 then
ShowMessage('Machine is attached to network')
else
ShowMessage('Machine is not attached to network');
end;
|
Как определить нажаты ли клавиши Shift, Alt или Ctrl в какой-либо момент времени
|
Пpиходит пpогpаммист к пианистy - посмотpеть на новый pояль.
Долго ходит вокpyг, хмыкает, потом заявляет:
- Клава неyдобная - всего 84 клавиши, половина фyнкциональных,
ни одна не подписана, хотя... шифт нажимать ногой - оpигинально.
|
В приведенном примере показано как определить нажата ли клавиша Shift при выборе строчки меню. Пример также содержит функции проверки состояния клавиш Alt, Ctrl.
function CtrlDown : Boolean;
var
State : TKeyboardState;
begin
GetKeyboardState(State);
Result := ((State[vk_Control] and 128) <> 0);
end;
function ShiftDown : Boolean;
var
State : TKeyboardState;
begin
GetKeyboardState(State);
Result := ((State[vk_Shift] and 128) <> 0);
end;
function AltDown : Boolean;
var
State : TKeyboardState;
begin
GetKeyboardState(State);
Result := ((State[vk_Menu] and 128) <> 0);
end;
procedure TForm1.MenuItem12Click(Sender: TObject);
begin
if ShiftDown then
Form1.Caption := 'Shift'
else
Form1.Caption := '';
end;
|
Как проверить правильность E-mail адреса
|
Я мылю, следовательно, существую!
|
Если пользователю Вашего приложения необходимо вводить почтовый адрес, то возникает потребность в проверке адреса на правильность. Конечно способов сделать это существует множество, но этот, на мой взгляд, самый короткий и доступный для понимания.
function IsValidEmail(const Value:string):boolean;
function CheckAllowed(const s:string):boolean;
var
i: integer;
begin
Result:= false;
for i:= 1 to Length(s) do
begin
if not (s[i] in ['a'..'z', 'A'..'Z', '0'..'9', '_', '-', '.']) then
Exit;
end;
Result:= true;
end;
var
i: integer;
namePart, serverPart: string;
begin
Result:= false;
i:= Pos('@', Value);
if i = 0 then
Exit;
namePart:= Copy(Value, 1, i - 1);
serverPart:= Copy(Value, i + 1, Length(Value));
if (Length(namePart) = 0) or ((Length(serverPart) < 5)) then
Exit;
i:= Pos('.', serverPart);
if (i = 0) or (i > (Length(serverPart) - 2)) then
Exit;
Result:= CheckAllowed(namePart) and CheckAllowed(serverPart);
end;
|
Каким образом узнать, открыто меню или нет
type
TForm1 = class(TForm)
MainMenu1: TMainMenu;
Item01: TMenuItem;
Item11: TMenuItem;
Item21: TMenuItem;
private
{ Private declarations }
public
procedure WMMenuSelect(var M: TWMMenuSelect); message
WM_MENUSELECT;
end;
implementation
{$R *.RES}
procedure TForm1.WMMenuSelect(var M: TWMMenuSelect);
begin
inherited;
{ Этот Beep сигнализирует вообще об открытии меню }
MessageBeep(MB_ICONASTERISK);
{ А зтот Beep - только о выборе в меню нового Item }
if M.Menu = MainMenu1.Handle then
MessageBeep(MB_ICONASTERISK);
end;
end.
|
Определить когда мышь над компонентом, а когда она ушла с него
|
Купил мужик мышь для компа оптическую. Круто! В руководстве написано - работает на любой поверхности. Повозил по столу - работает! ...по бумаге - работает! ...по линолеуму - работает! Что бы ещё попробовать? По ЗЕРКАЛУ!!! - "Обнаружено новое устройство..."
|
Для того, чтобы определить когда мышь над компонентом, в данном примере это будет панель, мы создадим новый класс, который будет являться потомком класса TPanel, и будет обрабатывать некоторые необходимые нам для данной задачи сообщения Windows.
Для этого определим следующим образом новый тип:
type
TMyPanel=class(TPanel)
public
procedure CMMouseEnter (var message: TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave (var message: TMessage); message CM_MOUSELEAVE;
end;
|
Называться наш новый класс будет TMyPanel. Определить его можете до определение класса формы, т.е. сразу после директивы uses.
После объявления экземпляра формы нужно объявить экземпляр нашего нового класса:
var
Form1: TForm1;
MyPanel1: TMyPanel;
|
В разделе implemetation обрабатываем несколько сообщения, именно этими обработчиками наш класс и будет отличаться от класса стандартной панели.
procedure TMyPanel.CMMouseEnter (var message: TMessage);
begin
Form1.Label1.Caption:='Мышь на панели';
end;
procedure TMyPanel.CMMouseLEAVE (var message: TMessage);
begin
Form1.Label1.Caption:='Мышь вне панели';
end;
|
По созданию окна создаём экземпляр нашего класса:
procedure TForm1.FormCreate(Sender: TObject);
begin
MyPanel1 := TMyPanel.Create(self);
with MyPanel1 do
begin
Parent := Form1;
Visible := True;
Left := 100;
Top := 100;
end;
end;
|
По уничтожению окна, соответственно, - уничтожаем:
procedure TForm1.FormDestroy(Sender: TObject);
begin
MyPanel1.Destroy;
end;
|
Как узнать, находится ли мышка на форме
Для этого можно воспользоваться API функцией GetCapture().
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;
|
Как узнать, доступен ли в сети сервер MS SQL
|
Два программиста:
- Ко мне вчера чувак приходил, сервак сломал.
- Он что хакер?
- Нет, мудак!
|
function CheckMSSQLServer(fServerName, fUserName, fPsw : string) : Bool;
var
wDb : TDatabase;
begin
// Check if MS SQL Server is reachable
// Важно! BDE Должна быть установлена
Result := False;
wDb := TDatabase.Create(nil);
with wDb do
begin
DatabaseName := 'wDbDatabaseName'; // arbitrary name, must be unique
// in current Session
Params.Values['SERVER Name'] := fServerName;
Params.Values['USER Name'] := fUserName;
Params.Values['PASSWORD'] := fPsw;
LoginPrompt := False;
end;
try
wDb.DriverName := 'MSSQL';
try
wDb.Connected := True;
wDb.Connected := False;
except
ShowMessage('Server is not reachable');
end;
Result := True;
finally
wDb.Free;
end;
end;
|
Как узнать о нажатии NON-MENU клавиши в момент когда меню показано
|
Человека посылают на три буквы, а компьютер - на три клавиши...
|
Создайте обработчик сообщения WM_MENUCHAR.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, Menus;
type
TForm1 = class(TForm)
MainMenu1: TMainMenu;
One1: TMenuItem;
Two1: TMenuItem;
THree1: TMenuItem;
private
{Private declarations}
procedure WmMenuChar(var m : TMessage); message WM_MENUCHAR;
public
{Public declarations}
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.WmMenuChar(var m: TMessage);
begin
Form1.Caption := 'Non standard menu key pressed';
m.Result := 1;
end;
end.
|
Как определить, из под какой операционной системы запущена программа
|
- Чем отличается человек от Windows?
- Когда нам надоедает человек - мы говорим ему "Shut up!". A когда нам надоедает Windows- "Shut down!"
|
If (GetVersion() and $80000000)<>0 then
// ...'Windows 95/98'...
else
// ... 'Windows NT'...
end;
|
Как узнать, подключен ли компьютер к сети
procedure TForm1.Button1Click(Sender: TObject);
begin
if GetSystemMetrics(SM_NETWORK) and $01 = $01 then
ShowMessage('Computer is attached to a network!')
else
ShowMessage('Computer is not attached to a network!');
end;
|
Находится ли точка внутри фигуры
|
Лучше быть бесПОЙHТовым нодом,чем безHОДежным пойнтом
|
Rgn := CreatePolygonRgn(Points, PointsCount,...);
Result := PtInRgn(Point,Rgn);
CloseHandle(Rgn);
|
Определить, занят ли порт сокета
|
- Смайлик видишь?
- Нет.
- И я не вижу. А он есть.
|
var SockAddrIn : TSockAddrIn;
FSocket : TSocket;
...
If bind(FSocket, SockAddrIn, SizeOf(SockAddrIn)) <> 0 Then
begin
обрабатываем WSAGetLastError
end;
|
Проверить, печатает ли текущий принтер в цвете
uses
Printers, WinSpool;
procedure TForm1.Button1Click(Sender: TObject);
var
Dev, Drv, Prt: array[0..255] of Char;
DM1: PDeviceMode;
DM2: PDeviceMode;
Sz: Integer;
DevM: THandle;
begin
Printer.PrinterIndex := -1;
Printer.GetPrinter(Dev, Drv, Prt, DevM);
DM1 := nil;
DM2 := nil;
Sz := DocumentProperties(0, 0, Dev, DM1^, DM2^, 0);
GetMem(DM1, Sz);
DocumentProperties(0, 0, Dev, DM1^, DM2^, DM_OUT_BUFFER);
if DM1^.dmColor > 1 then
label1.Caption := Dev + ': Color'
else
label1.Caption := Dev + ': Black and White';
if DM1^.dmFields and DM_Color <> 0 then
Label2.Caption := 'Printer supports color printing'
else
Label2.Caption := 'Printer does not support color printing';
FreeMem(DM1);
end;
|
Поддерживает ли процессор технологию 3DNow
|
Разработали новый процессор на женской логике, обрабатывающий четыре логических значения: "Ни да, ни нет", "И да, и нет", "Три раза нет!" и "Нет, и не проси!!!"
|
// так как будем использовать 32-битный регистр
{$ifndef ver80}
function 3DNowSupport: Boolean; assembler;
asm
push ebx
mov @Result, True
mov eax, $80000000
dw $A20F
cmp eax, $80000000
jbe @NOEXTENDED // 3DNow не поддерживается
mov eax, $80000001
dw $A20F
test edx, $80000000
jnz @EXIT // 3DNow поддерживается
@NOEXTENDED:
mov @Result, False
@EXIT:
pop ebx
end;
{$endif}
|
Проверка на существование свойства
{Вероятно, вы захотите заменить "is TButton.."
на что-то другое, что вы определили в родителе..
напишите просто if Components[i] in myset ...
в моем примере я перебираю около 40 объектов,
чтобы найти свойство TFont и изменить его свойство
TPitch ... может быть существует путь легче?}
procedure TForm1.FormCreate(Sender: TObject);
var
i: Integer;
begin
for i := 0 to ComponentCount -1 do
if Components[i] is TButton then
TButton(Components[I]).Font.Pitch :=fpFixed ;
end;
|
Функция определяющая запущен ли сервер удаленного доступа (RAS)
|
Включает Webmaster свой компьютер:
- Вот блин, что-то со счетчиком, уже третий раз "166"!
(Смотрит на системный блок).
|
function CheckRAS: boolean;
const
MaxEntries = 100;
var
BufSize : Integer;
NumEntries : Integer;
Entries : array [1..MaxEntries] of TRasConn;
begin
Entries[1].dwSize := SizeOf(TRasConn);
Bufsize:=SizeOf(TRasConn)*MaxEntries;
FillChar(Stat, Sizeof(TRasConnStatus), 0);
RasEnumConnections(@Entries[1], BufSize, NumEntries);
if numentries > 0 then
result := true
else
result := false;
end;
|
Приверить, запущен ли сервис
|
Падает комп с 16-го этажа и думает: "Вот бы сейчас зависнуть".
|
uses
WinSvc;
function ServiceGetStatus(sMachine, sService: PChar): DWORD;
{******************************************}
{*** Parameters: ***}
{*** sService: specifies the name of the service to open
{*** sMachine: specifies the name of the target computer
{*** ***}
{*** Return Values: ***}
{*** -1 = Error opening service ***}
{*** 1 = SERVICE_STOPPED ***}
{*** 2 = SERVICE_START_PENDING ***}
{*** 3 = SERVICE_STOP_PENDING ***}
{*** 4 = SERVICE_RUNNING ***}
{*** 5 = SERVICE_CONTINUE_PENDING ***}
{*** 6 = SERVICE_PAUSE_PENDING ***}
{*** 7 = SERVICE_PAUSED ***}
{******************************************}
var
SCManHandle, SvcHandle: SC_Handle;
SS: TServiceStatus;
dwStat: DWORD;
begin
dwStat := 0;
// Open service manager handle.
SCManHandle := OpenSCManager(sMachine, nil, SC_MANAGER_CONNECT);
if (SCManHandle > 0) then
begin
SvcHandle := OpenService(SCManHandle, sService, SERVICE_QUERY_STATUS);
// if Service installed
if (SvcHandle > 0) then
begin
// SS structure holds the service status (TServiceStatus);
if (QueryServiceStatus(SvcHandle, SS)) then
dwStat := ss.dwCurrentState;
CloseServiceHandle(SvcHandle);
end;
CloseServiceHandle(SCManHandle);
end;
Result := dwStat;
end;
function ServiceRunning(sMachine, sService: PChar): Boolean;
begin
Result := SERVICE_RUNNING = ServiceGetStatus(sMachine, sService);
end;
// Check if Eventlog Service is running
procedure TForm1.Button1Click(Sender: TObject);
begin
if ServiceRunning(nil, 'Eventlog') then
ShowMessage('Eventlog Service Running')
else
ShowMessage('Eventlog Service not Running')
end;
{
Windows 2000 and earlier: All processes are granted the SC_MANAGER_CONNECT,
SC_MANAGER_ENUMERATE_SERVICE, and SC_MANAGER_QUERY_LOCK_STATUS access rights.
Windows XP: Only authenticated users are granted the SC_MANAGER_CONNECT,
SC_MANAGER_ENUMERATE_SERVICE,
and SC_MANAGER_QUERY_LOCK_STATUS access rights.
}
{
Do not use the service display name (as displayed in the services
control panel applet.) You must use the real service name, as
referenced in the registry under
HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services
}
|
Определить, нажат ли Shift при старте приложения
program Project1;
uses
Forms,
Windows,
Dialogs,
Unit1 in 'Unit1.pas' {Form1};
var
KeyState: TKeyBoardState;
{$R *.RES}
begin
Application.Initialize;
GetKeyboardState(KeyState);
if ((KeyState[vk_Shift] and 128) <> 0) then
begin
{ here you could put some code to show the app as tray icon, ie
hier kann z.B ein Code eingefugt werden, um die Applikation als
Tray Icon anzuzeigen}
end;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
|
Как выполнять другую команду по нажатию на кнопку, если зажата клавиша Shift
|
Shift влево, Shift вправо считается Escape-ом и карается Reboot-ом!
|
procedure TForm1.Button1Click(Sender: TObject);
begin
if GetKeyState(VK_SHIFT) < 0 then
ShowMessage('Кнопка Shift нажата')
else
ShowMessage('Обычное нажатие кнопки');
end;
|
Проверить, выделена ли ячейка в StringGrid
function IsCellSelected(StringGrid: TStringGrid; X, Y: Longint): Boolean;
begin
Result := False;
try
if (X >= StringGrid.Selection.Left) and (X <= StringGrid.Selection.Right) and
(Y >= StringGrid.Selection.Top) and (Y <= StringGrid.Selection.Bottom) then
Result := True;
except
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if IsCellSelected(stringgrid1, 2, 2) then
ShowMessage('Cell (2,2) is selected.');
end;
|
Текущая TTable пуста
Автоп статьи: Галимарзанов Фанис
Проверить таблицу - имеет она записи или нет, можно с помощью простой
функции
Function NotEmptySet(inSet:TDataSet): boolean;
begin
Result := Not (inSet.Bof and inSet.eof);
end;
|
Проще некуда, используются известные свойства DataSet.Bof и DataSet.Eof
Удалить все записи из таблицы (вместо EmptyTable)
while NotEmptySet(dm.taAb) do
dm.taAb.Delete;
|
Как определить, включено ли автоскрытие у панели задач
uses ShellAPI;
function IsTaskbarAutoHideOn: boolean;
var
ABData: TAppBarData;
begin
ABData.cbSize := sizeof(ABData);
Result := (SHAppBarMessage(ABM_GETSTATE, ABData) and ABS_AUTOHIDE) > 0;
end;
|
Как узнать, установлен ли на компьютере TCP-IP
|
Молодой спец спрашивает у хакера:
- А почему у меня Internet не работает?
- А у тебя Ти-Си-Пи-Ай-Пи (TCP-IP) стоит?
- Конечно стоит! Но как ты его назвал!
|
uses Registry;
function TCPIPInstalled: boolean;
var
Reg: TRegistry;
RKeys: TStrings;
begin
Result:=False;
try
Reg := TRegistry.Create;
RKeys := TStringList.Create;
Reg.RootKey:=HKEY_LOCAL_MACHINE;
if Reg.OpenKey('\Enum\Network\MSTCP', False) then
begin
reg.GetKeyNames(RKeys);
Result := RKeys.Count > 0;
end;
finally
Reg.free;
RKeys.free;
end;
end;
|
Определение работы в Delphi IDE
function DelphiLoaded: boolean;
{ Определение работающей Delphi. Во всяком случае, дает
правильный результат если Delphi минимизирован, или имеет о
ткрытый проект. Также, правильный результат получается,
если вызывающее приложение автономно, или запущено из-под
IDE. Код написан на основе идей Wade Tatman
wtatman@onramp.net - Mike O'Hanlon, The Pascal Factory,
найденных в Delphi-Talk List. }
function WindowExists(ClassName, WindowName: string): boolean;
{ Проверяем наличие определенного окна Window, используя
для этого паскалевские строки вместо PChars. }
var
PClassName, PWindowName: PChar;
AClassName, AWindowName: array[0..63] of char;
begin
if ClassName = '' then
PClassName := nil
else
PClassName := StrPCopy(@AClassName[0], ClassName);
if WindowName = '' then
PWindowName := nil
else
PWindowName := StrPCopy(@AWindowName[0], WindowName);
if FindWindow(PClassName, PWindowName) <> 0 then
WindowExists := true
else
WindowExists := false;
end; {WindowExists}
begin {DelphiLoaded}
DelphiLoaded := false;
if WindowExists('TPropertyInspector', 'Object Inspector') then
if WindowExists('TMenuBuilder', 'Menu Designer') then
if WindowExists('TApplication', 'Delphi') then
if WindowExists('TAlignPalette', 'Align') then
if WindowExists('TAppBuilder', '') then
DelphiLoaded := true;
end; {DelphiLoaded}
|
Следующая программа возвращает TRUE при запуске в Delphi IDE (ПРИМЕЧАНИЕ: это
_не_ сработает, если подпрограмма в DLL).
function InIDE: Boolean;
begin
Result := Bool(PrefixSeg) and
Bool(PWordArray(MemL[DSeg:36])^[8]));
end; { InIDE }
|
Как определить, запущено ли приложение?
|
Умирает Питер Нортон. На том свете ему за многочисленные заслуги перед компьтерщиками всего мира предлагают выбрать место жительства - Рай или Ад.
Походил Нортон по Раю, посмотрел - Ангелы на лирах играют, нектар пьют - скучно. Пошел на Ад посмотреть. Заходит, а там Билл Гейтс за компом сидит - клавиши топчет. Глянул на это дело Питер и пулей к Богу: "Все - говорит - хочу в Аду жить!". Бог начинает выяснять причину такого выбора, Нортон объясняет про скуку в Раю и что в Аду Билл Гейтс за компом развлекается. На что Бог отвечает Нортону:
- Он не развлекается - это у него Адское наказание.
- Какое ?!
- Он пишет MicrosoftOffice, чтоб работал по OS/2 на ЕС-1840.
|
Следующий кодкомпилируется как на 16-ти, так и на 32-битных платформах.
{$IFNDEF WIN32}
const
WF_WINNT = $4000;
{$ENDIF}
function IsNT : bool;
{$IFDEF WIN32}
var
osv : TOSVERSIONINFO;
{$ENDIF}
begin
result := true;
{$IFDEF WIN32}
GetVersionEx(osv);
if osv.dwPlatformId = VER_PLATFORM_WIN32_NT then
exit;
{$ELSE}
if ((GetWinFlags and WF_WINNT) = WF_WINNT ) then
exit;
{$ENDIF}
result := false;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if IsNt then
ShowMessage('Running on NT')
else
ShowMessage('Not Running on NT');
end;
|
Как обнаружить активность юзера
|
Сынишка системного администратора вечером просит папу:
- Па. Почитай на ночь сказку про умного, толкового, доброго, смелого юзерa...
|
Application.OnMessage := DoMessageEvent;
procedure TForm1.DoMessageEvent(var Msg: TMsg; var Handled: Boolean);
begin
case Msg.message of
WM_KEYFIRST..WM_KEYLAST,
WM_MOUSEFIRST..WM_MOUSELAST:
{ Произошли события клавиатуры и мыши };
...
end;
end;
|
Проверить, установлен ли Word
uses
Registry;
function IsWordInstalled: Boolean;
var
Reg: TRegistry;
s: string;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CLASSES_ROOT;
Result := Reg.KeyExists('Word.Application');
finally
Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if IsWordInstalled then
ShowMessage('MS Word is installed.');
end;
|
Итерация элементов управления компонента Notebook
Вот две малениких процедурки, присваивающие заголовкам всех компонентов Label
на всех страницах компонента NoteBook значение 'Foo'. (Я вам не говорил, что это
будет ПОЛЕЗНЫМ примером!)
procedure TForm1.Button1Click(Sender: TObject);
var
M, N: Word;
begin
for N := 0 to TabbedNotebook1.Pages.Count - 1 do
with TabbedNotebook1.pages.Objects[N] as TTabPage do
for M := 0 to ControlCount - 1 do
if Controls[M] is TLabel then
with Controls[M] as TLabel do
Caption := 'Foo';
end;
procedure TForm1.TabSet1Change(Sender: TObject; NewTab: Integer;
var AllowChange: Boolean);
begin
Notebook1.PageIndex := TabSet1.TabIndex;
end;
procedure TForm1.Button2Click(Sender: TObject);
var
M, N: Word;
begin
for N := 0 to TabbedNotebook1.Pages.Count - 1 do
with Notebook1.pages.Objects[N] as TPage do
for M := 0 to ControlCount - 1 do
if Controls[M] is TLabel then
with Controls[M] as TLabel do
Caption := 'Foo';
end;
|
Здесь был Я
|
Письмо пользователя в группу технической поддержки сетевой игры "Квейк":
"Я нашел глюк. Прямо посреди сцены во время игры постоянно зависают пять ботов."
Ответ группы поддержки:
"Это не глюк. Это не зависают пять ботов, это играет команда финов."
|
Откуда пошла привычка у людей - везде оставлять свои автографы - остаётся только догадываться. Скорее всего, мы это позаимствовали с наскальных рисунков эпохи неолита. Но это в прошлом, а сейчас мы попытаемся оставить след о себе уже в компьютерном варианте.
- Добавляем своё имя в System Tray (рядом с часами)
program Name_in_tray;
{$APPTYPE CONSOLE}
uses
registry, windows;
procedure name_in_tray;
const
name = 'Delphi World'; // Указываем своё имя или какое-либо слово
var
reg: tregistry;
begin
reg:=tregistry.Create;
reg.RootKey:=HKEY_CURRENT_USER;
reg.OpenKey('Control Panel\International',true);
reg.WriteString('s1159',name);
reg.WriteString('s2359',name);
reg.WriteString('sTimeFormat','HH:mm:ss tt');
reg.CloseKey;
end;
begin
name_in_tray;
end.
|
program Name_on_pusk;
{$APPTYPE CONSOLE}
uses
windows;
procedure name_on_pusk;
const
name='Delphi World';
var
h, h1: hwnd;
begin
h := findwindow('Shell_TrayWnd', nil);
h1 := findwindowex(h, 0, 'Button', nil);
setwindowtext(h1, name);
end;
begin
name_on_pusk;
end.
|
- Рисуем прямо по экрану (поверх всех окон)
program Name_on_screen;
{$APPTYPE CONSOLE}
uses
windows, graphics;
procedure Name_on_screen;
const
name='Delphi World';
var
ScreenDC: hDC;
begin
ScreenDC := GetDC(0);
settextcolor(screendc,clred); // Устанавливаем цвет текста, в данном случае
// clRed - красный.
SetBkMode(screendc, TRANSPARENT); // Рисуем на прозрачном фоне,
// без этой строчки фон - белый.
textout(screendc,0,0,name,6); // Устанавливаем координаты вывода и длину
// строки (в нашем случае - 6 символов)
ReleaseDC(0,ScreenDC);
end;
begin
name_on_screen;
end.
|
Надеюсь, кому-то это пригодиться, хотя бы ради развлечения =). Но смотрите - не перетрудитесь!
<< ВЕРНУТЬСЯ В ОГЛАВЛЕНИЕ
Материалы находятся на сайте
https://exelab.ru/pro/
|