Оригинальный DVD-ROM: eXeL@B DVD !
eXeL@B ВИДЕОКУРС !

ВИДЕОКУРС ВЗЛОМ
обновлён 2 декабря!


УЗНАТЬ БОЛЬШЕ >>
Домой | Статьи | RAR-cтатьи | FAQ | Форум | Скачать | Видеокурс
Новичку | Ссылки | Программирование | Интервью | Архив | Связь

БОЛЬШОЙ 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';
 




Как определить - находится ли приложение в режиме отладки

Автор: Simon Carter

Сидит программист глубоко в отладке. Подходит сынишка:
- Папа, почему солнышко каждый день встает на востоке, а садится на западе?
- Ты это проверял?
- Проверял.
- Хорошо проверял?
- Хорошо.
- Работает?
- Работает.
- Каждый день работает?
- Да, каждый день.
- Тогда ради бога, сынок, ничего не трогай, ничего не меняй.

Обычно господа взломщики, для того, чтобы взломать защиту приложения, запускают его в режиме отладки и анализируют машинный код для определения точки перехвата ввода пароля с клавиатуры.

Обычно таким способом ломаются игрушки :)

Конечно данный способ не сможет полностью защитить Ваш программный продукт от взлома, но прекратить выполнение секретного кода - запросто. Для этого мы будем использовать 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

C: твою FORMATь.

Можно использовать функцию 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.
 




Как определить, из под какой операционной системы запущена программа

Автор: Nomadic

- Чем отличается человек от 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;
 




Здесь был Я

Автор: HuNtEr

Письмо пользователя в группу технической поддержки сетевой игры "Квейк": "Я нашел глюк. Прямо посреди сцены во время игры постоянно зависают пять ботов." Ответ группы поддержки: "Это не глюк. Это не зависают пять ботов, это играет команда финов."

Откуда пошла привычка у людей - везде оставлять свои автографы - остаётся только догадываться. Скорее всего, мы это позаимствовали с наскальных рисунков эпохи неолита. Но это в прошлом, а сейчас мы попытаемся оставить след о себе уже в компьютерном варианте.

  • Добавляем своё имя в 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/



Оригинальный DVD-ROM: eXeL@B DVD !


Вы находитесь на EXELAB.rU
Проект ReactOS