БОЛЬШОЙ FAQ ПО DELPHI

 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 (recA, 2);
 myFunc (recB, 29);
 

 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';
 

 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');
 

 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;
 

 with TRegistry.create do
 begin
   Rootkey := HKEY_LOCAL_MACHINE;
   OpenKey('SOFTWARE\BORLAND\DATABASE ENGINE', false);
   CFGFile := ReadString('CONFIGFILE01');
   Free;
 end;
 

 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;
 

 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;
 

 ENGINE VERSION=500
 INTERFACE LEVEL=500
 VERSION DATE=09.06.98
 VERSION TIME=17:06:13
 

 RootKey := HKEY_LOCAL_MACHINE;
 OpenKey(`SOFTWARE\Borland\Database Engine`, False);
 try
   s := ReadString(`CONFIGFILE01`);
   //BDE установлена
 finally
   CloseKey;
 end;
 

 IsBDEExist := (dbiInit(nil) = 0)
 

 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!');
 

 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.
 

 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.
 

 If FindWindow('TAppBuilder', nil) <= 0 then
   ShowMessage('Delphi is not running!')
 else
   ShowWindow('Delphi is running!');
 

 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;
 

 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;
 

 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;
 

 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;
 

 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;
 

 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.
 

 type
   TMyPanel=class(TPanel)
   public
     procedure CMMouseEnter (var message: TMessage); message CM_MOUSEENTER;
     procedure CMMouseLeave (var message: TMessage); message CM_MOUSELEAVE;
 end;
 

 var
   Form1: TForm1;
   MyPanel1: TMyPanel;
 

 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;
 

 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;
 

 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;
 

 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.
 

 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;
 

 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;
 

 // так как будем использовать 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;
 

 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;
 

 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
 }
 

 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.
 

 procedure TForm1.Button1Click(Sender: TObject);
 begin
   if GetKeyState(VK_SHIFT) < 0 then
     ShowMessage('Кнопка Shift нажата')
   else
     ShowMessage('Обычное нажатие кнопки');
 end;
 

 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;
 

 Function NotEmptySet(inSet:TDataSet): boolean;
 begin
   Result := Not (inSet.Bof and inSet.eof);
 end;
 

 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;
 

 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;
 

 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}
 

 function InIDE: Boolean;
 begin
   Result := Bool(PrefixSeg) and
     Bool(PWordArray(MemL[DSeg:36])^[8]));
 end;  { InIDE }
 

 {$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;
 

 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;
 

 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;
 

 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;
 

 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.