Как запретить перемещение формы?

type
TyourForm = class(TForm)
  private
    { Private declarations }
    procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
  end;

procedure TyourForm.WMNCHitTest(var Message: TWMNCHitTest);
begin

  inherited;

  with Message do
    if Result = HTCAPTION then
      Result := HTNOWHERE;
end;

Взято с

Delphi Knowledge Base

Как запретить всплывающее меню при нажатии правой книпки мыши?

Взято из FAQ:
Перевод материала с сайта members.home.com/hfournier/webbrowser.htm

Вам необходимо включить интерфейс IDocHostUIHandler.
Для этого Вам понадобятся два файла: ieConst.pas и IEDocHostUIHandler.pas.
В методе ShowContextMenu интерфейса IDocHostUIHandler,
необходимо изменить возвращаемое значение с E_NOTIMPL на S_OK.
После этого меню перестанет реагировать на правое нажатие кнопки мыши.
Добавьте два модуля, упомянутые выше в секцию Uses и добавьте следующий код:

... var
Form1: TForm1;
FDocHostUIHandler: TDocHostUIHandler;
...
implementation
...
procedure TForm1.FormCreate(Sender: TObject);
begin
  FDocHostUIHandler := TDocHostUIHandler.Create;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  FDocHostUIHandler.Free;
end;
procedure TForm1.WebBrowser1NavigateComplete2(Sender: TObject;
pDisp: IDispatch; var URL: OleVariant);
var
  hr: HResult;
  CustDoc: ICustomDoc;
begin
  hr := WebBrowser1.Document.QueryInterface(ICustomDoc, CustDoc);
  if hr = S_OK then CustDoc.SetUIHandler(FDocHostUIHandler);
end;

Как запросить страницу с сайта?

Это можно сделать с помощью TClientSocket.

unit Unit1;

interface

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

const Request: AnsiString = 'GET / HTTP/1.1' + #$D#$A +
  'Accept: application/vnd.ms-excel, application/msword, */*' + #$D#$A +
    'Accept-Language: en-us' + #$D#$A +
    'Accept-Encoding: gzip, deflate' + #$D#$A +
    'User-Agent: Mozilla/4.0 (compatible; MSIE 4.01; Windows 98)' + #$D#$A +
    'Host: vingrad.com' + #$D#$A +
    'Connection: Keep-Alive' + #$D#$A + #$D#$A;

type
  TForm1 = class(TForm)
    Skt: TClientSocket;
    Button1: TButton;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);
    procedure SktRead(Sender: TObject; Socket: TCustomWinSocket);
    procedure SktConnect(Sender: TObject; Socket: TCustomWinSocket);
  private
{ Private declarations }
  public
{ Public declarations }
  end;

var Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
  Skt.Host := 'vingrad.ru';
  Skt.Port := 80;
  Skt.Open;
end;

procedure TForm1.SktRead(Sender: TObject; Socket: TCustomWinSocket);
begin
  Memo1.Lines.Text := Memo1.Lines.Text + Socket.ReceiveText;
end;

procedure TForm1.SktConnect(Sender: TObject; Socket: TCustomWinSocket);
begin
  Socket.SendText(Request);
end;
end.

Request - это запрос который посылает мой IE5.
В принципе, по протоколу HTTP он может ограничиваться:
'GET / HTTP/1.1'+#13+#13. Если хотите запросить оределенный документ: 'GET /<полный путь> HTTP/1.1'+#13+#13.
Конечно, всегда можно воспользоваться готовыми компонентами.

Автор: Fantasist

{
Присоедините следующий обработчик к Вашему TClientSocket.
Он получает файл с сервера и помещает его в строковую переменную FText string variable. Однако он не убирает заголовок, который так же посылается вебсервером.

Не забудьте задать правильный адрес сервера в объекте Socket. Установите порт 80. А затем откройте его при помощи команды "Socket.Open;".

Автор: E.J.Molendijk
}

Const
  WebPage = '/index.html';
Var
  FText   : String;

procedure TForm1.SocketWrite(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  Socket.SendText('GET '+Webpage+' HTTP/1.0'#10#10);
end;

procedure TForm1.SocketRead(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  FText := FText +  Socket.ReceiveText
end;

procedure TForm1.SocketConnecting(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  FText := '';
end;

procedure TForm1.SocketDisconnect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
{ --- }
{ ЗДЕСЬ ВЫ МОЖЕТЕ ОБРАБАТЫВАТЬ ВАШ FText !!! }
{ --- }
end;

procedure TForm1.SocketError(Sender: TObject;
  Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  var ErrorCode: Integer);
begin
  ErrorCode:=0; { Ошибки игнорируем }
end;

Взято с Исходников.ru

Как запустить другое приложение?

uses
  libc;

procedure TForm1.Button1Click(Sender: TObject);
var
  iPrg: Integer;
begin
  //Execute kcalc - A calculator for KDE
  iPrg := libc.system('kcalc');
  if iPrg = -1 then
    ShowMessage('Error executing your program');
end;

Взято с сайта

Как запустить и остановить сервис (или получить его статус)?

Здесь представлены две функции ServiceStart и ServiceStop, которые показывают, как пользоваться API функциями OpenSCManager, OpenService и т.д.:

function ServiceStart(aMachine, aServiceName : string ) : boolean;
// aMachine это UNC путь, либо локальный компьютер если пусто
var
  h_manager,h_svc: SC_Handle;
  svc_status: TServiceStatus;
  Temp: PChar;
  dwCheckPoint: DWord;
begin
  svc_status.dwCurrentState := 1;
  h_manager := OpenSCManager(PChar(aMachine), Nil,
                             SC_MANAGER_CONNECT);
  if h_manager > 0 then
  begin
    h_svc := OpenService(h_manager, PChar(aServiceName),
                         SERVICE_START or SERVICE_QUERY_STATUS);
    if h_svc > 0 then
    begin
      temp := nil;
      if (StartService(h_svc,0,temp)) then
        if (QueryServiceStatus(h_svc,svc_status)) then
        begin
          while (SERVICE_RUNNING <> svc_status.dwCurrentState) do
          begin
            dwCheckPoint := svc_status.dwCheckPoint;

            Sleep(svc_status.dwWaitHint);

            if (not QueryServiceStatus(h_svc,svc_status)) then
              break;

            if (svc_status.dwCheckPoint < dwCheckPoint) then
            begin
              // QueryServiceStatus не увеличивает dwCheckPoint
              break;
            end;
          end;
        end;
      CloseServiceHandle(h_svc);
    end;
    CloseServiceHandle(h_manager);
  end;
  Result := SERVICE_RUNNING = svc_status.dwCurrentState;
end;

function ServiceStop(aMachine,aServiceName : string ) : boolean;
// aMachine это UNC путь, либо локальный компьютер если пусто
var
  h_manager,h_svc   : SC_Handle;
  svc_status     : TServiceStatus;
  dwCheckPoint : DWord;
begin
  h_manager:=OpenSCManager(PChar(aMachine),nil,
                           SC_MANAGER_CONNECT);
  if h_manager > 0 then
  begin
    h_svc := OpenService(h_manager,PChar(aServiceName),
                         SERVICE_STOP or SERVICE_QUERY_STATUS);

    if h_svc > 0 then
    begin
      if(ControlService(h_svc,SERVICE_CONTROL_STOP,
                        svc_status))then
      begin
        if(QueryServiceStatus(h_svc,svc_status))then
        begin
          while(SERVICE_STOPPED <> svc_status.dwCurrentState)do
          begin
            dwCheckPoint := svc_status.dwCheckPoint;
            Sleep(svc_status.dwWaitHint);

            if(not QueryServiceStatus(h_svc,svc_status))then
            begin
              // couldn't check status
              break;
            end;

            if(svc_status.dwCheckPoint < dwCheckPoint)then
              break;

          end;
        end;
      end;
      CloseServiceHandle(h_svc);
    end;
    CloseServiceHandle(h_manager);
  end;

  Result := SERVICE_STOPPED = svc_status.dwCurrentState;
end;

Чтобы узнать состояние сервиса, используйте следующую функцию:

function ServiceGetStatus(sMachine, sService: string ): DWord;
var
  h_manager,h_service: SC_Handle;
  service_status     : TServiceStatus;
  hStat : DWord;
begin
  hStat := 1;
  h_manager := OpenSCManager(PChar(sMachine) ,Nil,
                             SC_MANAGER_CONNECT);

  if h_manager > 0 then
  begin
    h_svc := OpenService(h_manager,PChar(sService),
                      SERVICE_QUERY_STATUS);

    if h_svc > 0 then
    begin
      if(QueryServiceStatus(h_svc, service_status)) then
        hStat := service_status.dwCurrentState;

      CloseServiceHandle(h_svc);
    end;
    CloseServiceHandle(h_manager);
  end;

  Result := hStat;
end;

Она возвращает одну из следующих констант:

SERVICE_STOPPED
SERVICE_RUNNING
SERVICE_PAUSED
SERVICE_START_PENDING
SERVICE_STOP_PENDING
SERVICE_CONTINUE_PENDING
или
SERVICE_PAUSE_PENDING

Всё что, что Вам нужно, это unit WinSvc !

Взято с Исходников.ru

Как запустить и подождать завершения 2х процессов?

procedure HzChe;
var
hProcess : array [0..1] of Cardinal;
struc1 : PSTARTUPINFO;
struc2 : PROCESS_INFORMATION;
begin
  if not CreateProcess ( PChar('c:\PSTOLD.EXE') ,
nil,
nil,
nil,
False,
NORMAL_PRIORITY_CLASS,
nil,
nil,
struc1^,
struc2 ) then ShowMessage ( 'Zhopa kakaya-to');
  hProcess[0] := struc2.hProcess;
if not CreateProcess ( PChar('c:\PSTOLD1.EXE') ,
nil,
nil,
nil,
False,
NORMAL_PRIORITY_CLASS,
nil,
nil,
struc1^,
struc2 ) then ShowMessage ( 'Zhopa kakaya-to');
hProcess[1] := struc2.hProcess;
  if WaitForMultipleObjects ( 2, @hProcess, True, INFINITE ) = 1 then
    ShowMessage ('    vce, priehali' );
end;

P.S.
То, что я понаписал нельзя считать цивильным кодом...просто демонстрация работы функции WaitForMultipleObjects ( код позорный...просто жуть...)

Автор ответа: Baa
Взято с Vingrad.ru

Как запустить любой апплет панели управления?

Апплеты в панели управления можно запускать при помощи функции WinExec, запуская control.exe и передав ей в качестве параметра имя апплета. Файлы апплетов (.cpl) обычно находятся в системной директории Windows.

Некоторые из апплетов могут располагаться за пределами системной директории, поэтому их прийдётся запускать просто по имени.

procedure TForm1.Button1Click(Sender: TObject);
begin
  WinExec('C:\WINDOWS\CONTROL.EXE TIMEDATE.CPL',
       sw_ShowNormal);
  WinExec('C:\WINDOWS\CONTROL.EXE MOUSE',
       sw_ShowNormal);
  WinExec('C:\WINDOWS\CONTROL.EXE PRINTERS',
       sw_ShowNormal);
end;

Взято с Исходников.ru

Как запустить программу и подождать ее завершения?

var
pi : TProcessInformation;
si : TStartupInfo;
begin
ZeroMemory(@si,sizeof(si));
si.cb:=SizeOf(si);
if not CreateProcess(
PChar(lpApplicationName), //pointer to name of executable module
PChar(lpCommandLine), // Command line.
nil, // Process handle not inheritable.
nil, // Thread handle not inheritable.
False, // Set handle inheritance to FALSE.
0, // No creation flags.
nil, // Use parent's environment block.
nil, // Use parent's starting directory.
si, // Pointer to STARTUPINFO structure.
pi ) // Pointer to PROCESS_INFORMATION structure.
then begin
Result:=false;
RaiseLastWin32Error;
Exit;
end;
WaitForSingleObject(pi.hProcess,INFINITE);
CloseHandle(pi.hProcess);
CloseHandle(pi.hThread);
// ... здесь твой код
end;

Автор ответа: TAPAKAH

Примечание Vit:

Если заменить

WaitForSingleObject(pi.hProcess,INFINITE);

на

while WaitforSingleObject(PI.hProcess,200)=WAIT_TIMEOUT do   application.ProcessMessages;

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

Примечание Mikel: В RxLib есть функция для этого: FileExecuteWait

Взято с Vingrad.ru

Здесь представлена функция, которая вызывается таким же образом как и WinExec, однако она ждёт, пока запущенная задача завершится.

function WinExecAndWait(Path: PChar; Visibility: Word): Word;
var
  InstanceID: THandle;
  Msg: TMsg;
begin
  InstanceID := WinExec(Path, Visibility);
  if InstanceID < 32 then { значение меньше чем 32 указывает на ошибку }
    WinExecAndWait := InstanceID
  else
    repeat
       while PeekMessage(Msg, 0, 0, 0, pm_Remove) do
       begin
         if Msg.Message = wm_Quit then Halt(Msg.WParam);
         TranslateMessage(Msg);
         DispatchMessage(Msg);
       end;
    until GetModuleUsage(InstanceID) = 0;
  WinExecAndWait := 0;
end;

Взято с Исходников.ru

Автор: Fabrнcio Fadel Kammer

Пример показывает как из Вашей программы запустить внешнее приложение и подождать его завершения.

function ExecAndWait(const FileName, Params: ShortString; const WinState: Word): boolean; export;
var
  StartInfo: TStartupInfo;
  ProcInfo: TProcessInformation;
  CmdLine: ShortString;
begin
  { Помещаем имя файла между кавычками, с соблюдением всех пробелов в именах Win9x }
  CmdLine := '"' + Filename + '" ' + Params;
  FillChar(StartInfo, SizeOf(StartInfo), #0);
  with StartInfo do
  begin
    cb := SizeOf(SUInfo);
    dwFlags := STARTF_USESHOWWINDOW;
    wShowWindow := WinState;
  end;
  Result := CreateProcess(nil, PChar( String( CmdLine ) ), nil, nil, false,
                          CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, nil,
                          PChar(ExtractFilePath(Filename)),StartInfo,ProcInfo);
  { Ожидаем завершения приложения }
  if Result then
  begin
    WaitForSingleObject(ProcInfo.hProcess, INFINITE);
    { Free the Handles }
    CloseHandle(ProcInfo.hProcess);
    CloseHandle(ProcInfo.hThread);
  end;
end;

А вот пример вызова этой функции:

ExecAndWait( 'C:\windows\calc.exe', '', SH_SHOWNORMAL)

Параметр FileName = Имя внешней программы.
Параметр Params = Параметры, необходимые для запуска внешней программы
Параметр WinState = Указывает - как будет показано окно:
Для этого параметра мы можем так же использовать следующие константы:
SW_HIDE, SW_MAXIMIZE, SW_MINIMIZE, SW_SHOWNORMAL

Взято с Исходников.ru

Как запустить текущий ScreenSaver

SendMessage(Application.Handle,WM_SYSCOMMAND, SC_SCREENSAVE, 0);

Взято из

Как зарегистрировать базу данных (BDE)?

Session.AddAlias(AliasName,AliasDriver, Params);
Session.SaveConfigFile;

Автор Vit
Взято с Vingrad.ru

uses
  DBIProcs, DBITypes;

procedure AddBDEAlias(sAliasName, sAliasPath, sDBDriver: string);
var
  h: hDBISes;
begin
  DBIInit(nil);
  DBIStartSession('dummy', h, '');
  DBIAddAlias(nil, PChar(sAliasName), PChar(sDBDriver),
    PChar('PATH:' + sAliasPath), True);
  DBICloseSession(h);
  DBIExit;
end;

{ Sample call to create an alias called WORK_DATA that }
{ points to the C:\WORK\DATA directory and uses the    }
{ DBASE driver as the default database driver:         }

AddBDEAlias('WORK_DATA', 'C:\WORK\DATA', 'DBASE');

Взято с

Delphi Knowledge Base

Как зарегистрировать свой пункт в меню для моего типа файлов?

uses
  Registry;

procedure AddFileMenue(FilePrefix, Menue, Command: string);
var
  reg: TRegistry;
  typ: string;
begin
  reg := TRegistry.Create;
  with reg do
  begin
    RootKey := HKEY_CLASSES_ROOT;
    OpenKey('.' + FilePrefix, True);
    typ := ReadString('');
    if typ = '' then
    begin
      typ := Fileprefix + 'file';
      WriteString('', typ);
    end;
    CloseKey;
    OpenKey(typ + '\shell\' + Menue + '\command', True);
    WriteString('', command + ' "%1"');
    CloseKey;
    Free;
  end;
end;

procedure DeleteFileMenue(Fileprefix, Menue: string);
var
  reg: TRegistry;
  typ: string;
begin
  reg := TRegistry.Create;
  with reg do
  begin
    RootKey := HKEY_CLASSES_ROOT;
    OpenKey('.' + Fileprefix, True);
    typ := ReadString('');
    CloseKey;
    OpenKey(typ + '\shell', True);
    DeleteKey(Menue);
    CloseKey;
    Free;
  end;
end;

{ Example / Beispiel:}

procedure TForm1.Button1Click(Sender: TObject);
begin
  { Register the Menuepoint: }

  AddFileMenue('rtf', 'Edit with Notepad', 'C:\Windows\system\notepad.exe');

  {
    If you now click with the right mousebutton on a *.rtf-file then
    you can see a Menuepoint: "Edit with Notepad".
    When Click on that point Notepad opens the file.

    Wenn man nun mit der rechten Maustaste im Explorer auf eine *.rtf-Datei Clickt,
    dann erscheint dort der Menuepunkt "Edit with Notepad".
    Beim Clicken darauf, цffnet Notepad diese Datei.
  }
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  {
   Unregister the Menuepoint / Undo your changes in the Registry:
   Lцscht den Menuepunkt wieder aus der Registry:
  }

  DeleteFileMenue('rtf', 'Edit with Notepad');
end;

Взято с сайта

Как зарегистрировать своё расширение?

Uses Registry;

procedure RegisterFileType(FileType,FileTypeName, Description,ExecCommand:string);
begin
if (FileType='') or (FileTypeName='') or (ExecCommand='') then exit;
if FileType[1]<>'.' then FileType:='.'+FileType;
if Description='' then Description:=FileTypeName;
with Treginifile.create do
try
rootkey := hkey_classes_root;
writestring(FileType,'',FileTypeName);
writestring(FileTypeName,'',Description);
writestring(FileTypeName+'\shell\open\command','',ExecCommand+' "%1"');
finally
free;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
RegisterFileType('txt','TxtFile', 'Plain text','notepad.exe');
end;

Автор Vit
Взято с Vingrad.ru

Как зарегистрировать в компонент ActiveX?

запустить "Regsvr32.exe имя_файла" из каталога c:\windows\system(32)

Автор Vit
Взято с Vingrad.ru

1. Регистрация ActiveX:

function RegActiveX(FileName:string):HRESULT;
var
hMod:Integer;
RegProc:function:HRESULT; //HRESULT = Longint
begin
hMod:=LoadLibrary(FileName);
if hMod=0 then
raise Exception.Create('Unable to load library"'+FileName+'". GetLastError = '+IntToStr(GetLastError));
RegProc:=GetProcAddress(hMod,'DllRegisterServer');
if RegProc=nil then
raise Exception.Create('Unable to load "DllRegisterServer" function from "'+FileName+'". GetLastError = '+IntToStr(GetLastError));
Result:=RegProc;
end;

2. Регистрация Type Library:

procedure RegisterTypeLibrary(FileName:string);
var
Name: WideString;
HelpPath: WideString;
TypeLib: ITypeLib;
begin
if LoadTypeLib(PWideChar(WideString(FileName)), TypeLib)=S_OK then
begin
Name := FileName;
HelpPath := ExtractFilePath(ModuleName);
RegisterTypeLib(TypeLib, PWideChar(Name), PWideChar(HelpPath));
end;
end;

Здесь используется интерфейс ITypeLib и API функция RegisterTypeLib. И то и другое объявленно в модуле ActiveX, если я не ошибаюсь.

Hint: если вы регистрируете библиотеку типов изнутри модулчя, то его имя можно получить с помощью следующей функции:

function GetModuleFileName: string;
var Buffer: array[0..261] of Char;
begin
SetString(Result, Buffer, Windows.GetModuleFileName(HInstance,
Buffer, SizeOf(Buffer)));
end;

Автор Fantasist
Взято с Vingrad.ru

Как защитить запись в DBGrid от удаления?

Поместите следующий код в событие OnKeyDown в DBGrid.

procedure TForm1.DBGrid1KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if (ssctrl in shift) and (key=vk_delete) then key:=0;
end;

Взято с Исходников.ru

Как заставить BDE сохранять в БД поле времени с сотыми долями секунды

Если руками, то в BDE Administrator (BDE Configuration Utility).

Если при инсталляции твоей программы, то -
В пункте Make Registry Changes InstallShield'а создай ключ

HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Database Engine\Settings\SYSTEM\FORMATS\TIME\MILSECONDS=TRUE

Взято из

Как заставить дополнительную клавиатуру всегда работать в режиме цифр?

Для этого необходимо написать процедуру-обработчик для Application.OnMessage:

procedure TForm1.FormCreate(Sender: TObject);
begin
  Application.OnMessage := AppOnMessage;
end;

procedure TForm1.AppOnMessage(var Msg: TMsg; var Handled: Boolean);
var  ccode: Word;
begin
  case Msg.Message of
    WM_KEYDOWN, WM_KEYUP:
    begin
      If (GetKeyState( VK_NUMLOCK ) >= 0)  //NumLock не включён
          and ((Msg.lparam and  $1000000) = 0)
      then
      begin
        ccode := 0;
        case Msg.wparam of
          VK_HOME:  ccode := VK_NUMPAD7;
          VK_UP  :  ccode := VK_NUMPAD8;
          VK_PRIOR: ccode := VK_NUMPAD9;
          VK_LEFT:  ccode := VK_NUMPAD4;
          VK_CLEAR: ccode := VK_NUMPAD5;
          VK_RIGHT: ccode := VK_NUMPAD6;
          VK_END  : ccode := VK_NUMPAD1;
          VK_DOWN : ccode := VK_NUMPAD2;
          VK_NEXT : ccode := VK_NUMPAD3;
          VK_INSERT:ccode := VK_NUMPAD0;
          VK_DELETE:ccode := VK_DECIMAL;
        end;
        If ccode <> 0 then Msg.Wparam := ccode;
      end;
    end;
  end;
end;

Взято с Исходников.ru

Как заставить кнопку Enter работать наподобие Tab?

Автор: Khaled Shagrouni

Как-то бухгалтер, который пользовался моей программой, заявил, что ему не удобно перескакивать пустые поля в форме кнопкой Tab, и что намного удобнее это делать обычным Enter-ом. Предлагаю посмотреть, как я решил эту проблемму.

Совместимость: Все версии Delphi

Пример обработчика события:

procedure Tform1.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
var
  ACtrl: TWinControl;
begin
  if key = 13 then
    begin
      ACtrl := ActiveControl;
      if ACtrl is TCustomMemo then exit;
      repeat
        ACtrl:= FindNextControl(ACtrl,true,true,false);
      until (ACtrl is TCustomEdit) or
      (ACtrl is TCustomComboBox) or
      (ACtrl is TCustomListBox) or
      (ACtrl is TCustomCheckBox) or
      (ACtrl is TRadioButton);
      ACtrl.SetFocus ;
    end;
end;

Не забудьте установить свойство формы KeyPreview в true.

Как Вы можете видеть; этот код использует функцию FindNextControl, которая ищет следующий свободный контрол.

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

Взято с Исходников.ru

Существует множество методов решения этой проблемы, но самый быстрый способ, это перехват нажатия клавиш, перед тем как их получит форма:

В секции формы PRIVATE добавьте:

Procedure CMDialogKey(Var Msg:TWMKey); message CM_DIALOGKEY;

В секции IMPLEMENTATION добавьте:

Procedure TForm1.CMDialogKey(Var Msg: TWMKey);
Begin
If NOT (ActiveControl Is TButton) Then
If Msg.Charcode = 13 Then
Msg.Charcode := 9;
inherited;
End;

Тем самым мы исключаем срабатывания нашей подмены, если фокус находится на кнопке.

Чтобы ускорить работу приложения, не надо активизировать свойство формы KEYPREVIEW

Взято с Исходников.ru

Как заставить код компонента работать только в дизайне?

ifcsDesigning in ComponentState then
begin
... код, работающий только в дизайне ...
end;

Взято из

Советов по Delphi от

Сборник Kuliba

в модификации Vit

Как заставить появиться окошко подсказки когда курсор мышки находится над определённым контролом?

var  hintWnd: THintWindow;

procedure TForm1.ActivateHintNOW( x,y: Integer);
var rect: TRect;
begin
  HintTxt := 'qq';
  if hintTxt <> '' then
  begin
    rect := hintWnd.CalcHintRect( Screen.Width, hinttxt, nil);
    rect.Left := rect.Left + x;
    rect.Right := rect.Right + x;
    rect.Top := rect.Top + y;
    rect.Bottom := rect.Bottom + y;
    hintWnd.ActivateHint( rect, hinttxt);
  end;
end;

Замечание: Не забудьте каждый раз создавать hintWnd:

     hintwnd:= THintWindow.create(self);

а затем освобождать его

    hintwnd.releasehandle;

Взято с Исходников.ru

Как заставить приложение Delphi отвечать на сообщения Windows?

Используем WM_WININICHANGED в качестве примера :

Объявление метода в TForm позволит вам обрабатывать сообщение WM_WININICHANGED:

procedureWMWinIniChange(var Message: TMessage); message WM_WININICHANGE;

Код в implementation может выглядеть так:

procedure TForm1.WMWinIniChange(var Message: TMessage);
   begin
     inherited;
   { ... ваша реакция на событие ... }
   end;

Вызов inherited метода очень важен. Обратите внимание также на то, что для функций, объявленных с директивой message (обработчиков событий Windows) после inherited нет имени наследуемой процедуры, потому что она может быть неизвестна или вообще отсутствовать (в этом случае вы в действительности вызываете процедуру DefaultHandler).

Copyright © 1996 Epsylon Technologies

Взято из

FAQ Epsylon Technologies (095)-913-5608; (095)-913-2934; (095)-535-5349

Как заставить приложение показывать различные иконки при различных разрешениях дисплея?

Для этого достаточно текущее разрешение экрана и в соответствии с ним изменить дескриптор иконки приложения. Естевственно, что Вам прийдётся создать в ресурсах новые иконки.

Поместите следующий код в файл проекта (.DPR) Вашего приложения:

Application.Initialize;
Application.CreateForm(TForm1, Form1);
case GetDeviceCaps(GetDC(Form1.Handle), HORZRES) of
  640: Application.Icon.Handle := LoadIcon(hInstance, 'ICON640');
  800: Application.Icon.Handle := LoadIcon(hInstance, 'ICON800');
  1024: Application.Icon.Handle := LoadIcon(hInstance, 'ICON1024');
  1280: Application.Icon.Handle := LoadIcon(hInstance, 'ICON1280');
end;
Application.Run;

Взято с Исходников.ru

Как заставить работать COM объекты в потоке?

Если вы используете многопоточное приложение то ActiveX(например ADO компоненты) даже созданные в отдельном потоке могут не хотеть работать корректно, из-за неправильной инициализации. Надо чуть-чуть видоизменить DPR файл - в uses добавить модуль ComObj, а самой первой строкой кода в проэкте должно идти:

CoInitFlags:=0;
Application.Initialize;

Что означает инициализацию COM в каждом потоке

Автор ответа Vit
Взято с Vingrad.ru

Как заставить работать DB2 через протокол IPX

Связь Win-клиента c DB2 в сети Netware
Hастройка доступа к DB2

1. Связь с использованием протокола IPX/SPX.

Возможны два варианта доступа:

через сервер NETWARE;
прямая адресация.
1.1. Конфигурация для доступа через сервер.
Замечание: Проверялся доступ через сервера NW 3.11 и 3.12. Для 4.х нужно еще разобраться.

1.1.1. DB2 Сервер

должна быть установлена OS/2 Warp или OS/2 Warp Connect;
включена поддержка NETWARE;
в CONFIG.SYS в переменную среды DB2COMM добавить (через запятую) IPXSPX и перезагрузить систему;
создать командный файл DBIPXSET.CMD следующего вида:
|------------------------------------------------------------------
|db2 update dbm cfg using fileserver objectname dbserver
|------------------------------------------------------------------
где - <NWSERVER> - имя сервера;

выполнить командный файл DBIPXSET.CMD;
перестартовать сервер базы данных;
создать командный файл DBIPXREG.CMD следующего вида:
|----------------------------------------------------------------
|db2 register nwbindery user
|----------------------------------------------------------------
где - <USERNAME> - имя пользователя, обладающего правами администратора на сервере <NWSERVER> ;

выполнить командный файл DBIPXREG.CMD;
ответить на запрос пароля.
1.1.2. WINDOWS - клиент
установить WINDOWS 3.1 или WfWG 3.11;
установить клиента NETWARE от версии 4.х;
при установке влючить поддержку WINDOWS;
установить клиента DB2 для WINDOWS;
используя программу Client Setup описать новый узел - сервер базы данных :
Name - <любое имя>
Protocol - IPX/SPX
File server - <NWSERVER>
Object name - dbserver
описать базу данных и разрешить доступ к ней через ODBC.
1.2. Конфигурация для доступа через прямую адресацию
1.2.1. DB2 Сервер

см. п 1.1.1;
найти в директории x:\sqllib\misc программу DB2IPXAD.EXE и выполнить ее;
записать полученный адрес;
1.2.2. WINDOWS - клиент
см. п. 1.1.2. (первые три шага);
используя программу Client Setup описать новый узел - сервер базы данных :
Name - <любое имя>
Protocol - IPX/SPX
File server - *
Object name - <адрес полученный от DB2IPXAD.EXE>
описать базу данных и разрешить доступ к ней через ODBC.

Взято из

Как заставить стартовать Дельфи без проекта?

Командной строкой:
Delphi32.exe -np

Взято с сайта

Как заставить стартовать Дельфи без заставки?

Командной строкой:

Delphi32.EXE -ns

Взято с сайта

Как заставить TEdit не пикать при нажатии недопустимых клавиш?

Перехватите событие KeyPress и установите key = #0 для недопустимых клавиш.

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
if ((UpCase(Key) < 'A') or (UpCase(Key) > 'Z')) then Key := #0;
end;

Взято с Исходников.ru

Как заставить запускаться из определенной папки?

Приведенный пример кода проверяет из какой папки запущена программа, если она запущена не из корневой - то переносит себя в корень и запускается оттуда.

program Project1;

uses
Forms, classes, windows, Sysutils, ShellApi,
Unit1 in 'Unit1.pas' {Form1};

{$R *.RES}
var f:textFile;
FileName:String;

begin
if paramstr(1)<>'/runasis' then
begin
CopyFile(PChar(Paramstr(0)),PChar('c:\'+extractFilename(paramstr(0))),True);
shellexecute(0, 'Open', PChar(extractFilename(paramstr(0))), '/runasis', 'c:\',sw_restore);
FileName:=changefileext(paramstr(0),'.bat');
assignFile(f,FileName);
rewrite(f);
writeln(f,':1');
writeln(f,format('Erase "%s"',[paramstr(0)]));
writeln(f,format('If exist "%s" Goto 1',[paramstr(0)]));
writeln(f,format('Erase "%s"',[FileName]));
closefile(f);
ShellExecute(0, 'Open', PChar(FileName), nil, nil, sw_hide);
end
else
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end;
end.

Автор ответа: Vit
Взято с Vingrad.ru

Как завершить любой процесс, в том числе и системный

//Включение, приминение и отключения привилегии.
// Для примера возьмем привилегию отладки приложений 'SeDebugPrivilege'
// необходимую для завершения ЛЮБЫХ процессов в системе (завершение процесов
// созданных текущим пользователем привилегия не нужна.

function ProcessTerminate(dwPID:Cardinal):Boolean;
var
hToken:THandle;
SeDebugNameValue:Int64;
tkp:TOKEN_PRIVILEGES;
ReturnLength:Cardinal;
hProcess:THandle;
begin
Result:=false;
// Добавляем привилегию SeDebugPrivilege
// Для начала получаем токен нашего процесса
if not OpenProcessToken( GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES
  or TOKEN_QUERY, hToken ) then
    exit;

// Получаем LUID привилегии
if not LookupPrivilegeValue( nil, 'SeDebugPrivilege', SeDebugNameValue )
  then begin
   CloseHandle(hToken);
   exit;
  end;

tkp.PrivilegeCount:= 1;
tkp.Privileges[0].Luid := SeDebugNameValue;
tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;

// Добавляем привилегию к нашему процессу
AdjustTokenPrivileges(hToken,false,tkp,SizeOf(tkp),tkp,ReturnLength);
if GetLastError()< > ERROR_SUCCESS  then exit;

// Завершаем процесс. Если у нас есть SeDebugPrivilege, то мы можем
// завершить и системный процесс
// Получаем дескриптор процесса для его завершения
hProcess := OpenProcess(PROCESS_TERMINATE, FALSE, dwPID);
if hProcess =0  then exit;
  // Завершаем процесс
   if not TerminateProcess(hProcess, DWORD(-1))
    then exit;
CloseHandle( hProcess );

// Удаляем привилегию
tkp.Privileges[0].Attributes := 0;
AdjustTokenPrivileges(hToken, FALSE, tkp, SizeOf(tkp), tkp, ReturnLength);
if GetLastError() < >  ERROR_SUCCESS
  then exit;

Result:=true;
end;

// Название добавление/удаление привилгии немного неправильные.  Привилегия или
// есть в токене процесса или ее нет. Если привилегия есть, то она может быть в
// двух состояниях - или включеная или отключеная. И в этом примере мы только
// включаем или выключаем необходимую привилегию, а не добавляем ее.

Взято с

Как завершить сеанс работы или перезагрузить Windows NT?

Для этого нам потребуются определённые привелегии:

function SetPrivilege(aPrivilegeName : string;
                      aEnabled : boolean ): boolean;
var
  TPPrev,
  TP         : TTokenPrivileges;
  Token      : THandle;
  dwRetLen   : DWord;
begin
  Result := False;
  OpenProcessToken(GetCurrentProcess,TOKEN_ADJUST_PRIVILEGES
                   or TOKEN_QUERY, @Token );

  TP.PrivilegeCount := 1;
  if( LookupPrivilegeValue(nil, PChar( aPrivilegeName ),
                           TP.Privileges[ 0 ].LUID ) ) then
  begin
    if( aEnabled )then
      TP.Privileges[0].Attributes:= SE_PRIVILEGE_ENABLED;
    else
      TP.Privileges[0].Attributes:= 0;

    dwRetLen := 0;
    Result := AdjustTokenPrivileges(Token,False,TP,
                                    SizeOf( TPPrev ),
                                    TPPrev,dwRetLen );
  end;

  CloseHandle( Token );
end;

function WinExit( iFlags : integer ) : boolean;
//   возможные флаги:
//   EWX_LOGOFF
//   EWX_REBOOT
//   EWX_SHUTDOWN
begin
  Result := True;
  if( SetPrivilege( 'SeShutdownPrivilege', true ) ) then
  begin
    if( not ExitWindowsEx( iFlags, 0 ) )then
    begin
      Result := False;
    end;
    SetPrivilege( 'SeShutdownPrivilege', False )
  end
  else
  begin
    Result := False;
  end;
end;

Взято с Исходников.ru

Как завершить задачу в Windows NT (а заодно получить PID задачи)?

Ниже приведён unit, который позволяет убить задачу в Windows NT.

Entry :
function Kill_By_Pid(pid : longint) : integer;
  где pid, это число, представляющее pid задачи

function EnumProcessWithPid(list : TStrings) : integer;
где список, это объект TStrings, который будет содержать имя задачи и pid в полях Object.
( list.Items[i] для имени, integer(list.Object[i]) для PID)

Дальше следует сам код:

procedure GenerateBlueScreen;
var
  Task : TStringList;
  i : integer;
begin
  Task := TStringList.Create;
  Try
    EnumProcessWithPid(Task);
    for i := 0 to Task.Count - 1 do
    begin
      TaskName := UpperCase(Task[i]);
      if (TaskName = 'WINLOGON.EXE') then
      begin // Generate a nice BlueScreenOfDeath
        Kill_By_Pid(integer(Task.Objects[i]));
        Beep;
        break;
      end;
    end;
  Finally
    Task.Free;
  end;
end;

unit U_Kill;
{** JF 15/02/2000 - U_Kill.pas
** This unit allow you to list and to kill runnign process. (Work only on NT)
** Entry point : EnumProcessWithPid and Kill_By_Pid.
** v1.2 JF correct a bug in Kill_By_Pid
** v1.3 JF change a thing for D5 05/09/2000
**}
interface

uses
Classes;

//** Error code **//
const
KILL_NOERR = 0;
KILL_NOTSUPPORTED = -1;
KILL_ERR_OPENPROCESS = -2;
KILL_ERR_TERMINATEPROCESS = -3;

ENUM_NOERR = 0;
ENUM_NOTSUPPORTED = -1;
ENUM_ERR_OPENPROCESSTOKEN = -2;
ENUM_ERR_LookupPrivilegeValue = -3;
ENUM_ERR_AdjustTokenPrivileges = -4;

GETTASKLIST_ERR_RegOpenKeyEx = -1;
GETTASKLIST_ERR_RegQueryValueEx = -2;

function Kill_By_Pid(pid : longint) : integer;
function EnumProcessWithPid(list : TStrings) : integer;

implementation
uses
  Windows,
  Registry,
  SysUtils;
var
  VerInfo : TOSVersionInfo;
const
  SE_DEBUG_NAME = 'SeDebugPrivilege';
  INITIAL_SIZE  =     51200;
  EXTEND_SIZE   =     25600;
  REGKEY_PERF   =     'software\microsoft\windows nt\currentversion\perflib';
  REGSUBKEY_COUNTERS ='Counters';
  PROCESS_COUNTER    ='process';
  PROCESSID_COUNTER  ='id process';
  UNKNOWN_TASK       ='unknown';
type
  ArrayOfChar = array[0..1024] of char;
  pArrayOfChar = ^pArrayOfChar;
type
  TPerfDataBlock = record
    Signature       : array[0..3] of WCHAR;
    LittleEndian    : DWORD;
    Version         : DWORD;
    Revision        : DWORD;
    TotalByteLength : DWORD;
    HeaderLength    : DWORD;
    NumObjectTypes  : DWORD;
    DefaultObject   : integer;
    SystemTime      : TSystemTime;
    PerfTime        : TLargeInteger;
    PerfFreq        : TLargeInteger;
    PerfTime100nSec : TLargeInteger;
    SystemNameLength: DWORD;
    SystemNameOffset: DWORD;
  end;
  pTPerfDataBlock = ^TPerfDataBlock;
  TPerfObjectType = record
    TotalByteLength    : DWORD;
    DefinitionLength   : DWORD;
    HeaderLength       : DWORD;
    ObjectNameTitleIndex : DWORD;
    ObjectNameTitle    : LPWSTR;
    ObjectHelpTitleIndex : DWORD;
    ObjectHelpTitle      : LPWSTR;
    DetailLevel          : DWORD;
    NumCounters          : DWORD;
    DefaultCounter       : integer;
    NumInstances         : integer;
    CodePage             : DWORD;
    PerfTime             : TLargeInteger;
    PerfFreq             : TLargeInteger;
  end;
  pTPerfObjectType       = ^TPerfObjectType;
  TPerfInstanceDefinition = record
     ByteLength           : DWORD;
     ParentObjectTitleIndex : DWORD;
     ParentObjectInstance   : DWORD;
     UniqueID               : integer;
     NameOffset             : DWORD;
     NameLength             : DWORD;
  end;
  pTPerfInstanceDefinition = ^TPerfInstanceDefinition;

  TPerfCounterBlock = record
    ByteLength      : DWORD;
  end;
  pTPerfCounterBlock = ^TPerfCounterBlock;

  TPerfCounterDefinition = record
    ByteLength               : DWORD;
    CounterNameTitleIndex    : DWORD;
    CounterNameTitle         : LPWSTR;
    CounterHelpTitleIndex    : DWORD;
    CounterHelpTitle         : LPWSTR;
    DefaultScale             : integer;
    DetailLevel              : DWORD;
    CounterType              : DWORD;
    CounterSize              : DWORD;
    CounterOffset            : DWORD;
  end;
  pTPerfCounterDefinition = ^TPerfCounterDefinition;

procedure InitKill;
begin
  VerInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
  GetVersionEx(VerInfo);
end;

(*
#define MAKELANGID(p, s)       ((((WORD  )(s)) << 10) | (WORD  )(p))
*)
function MAKELANGID(p : DWORD ; s : DWORD) : word;
begin
  result := (s shl 10) or (p);
end;

function Kill_By_Pid(pid : longint) : integer;
var
  hProcess : THANDLE;
  TermSucc : BOOL;
begin
  if (verInfo.dwPlatformId = VER_PLATFORM_WIN32_NT) then
  begin
    hProcess := OpenProcess(PROCESS_ALL_ACCESS, true, pid);
    if (hProcess = 0) then // v 1.2 : was =-1
    begin
      result := KILL_ERR_OPENPROCESS;
    end
    else
    begin
      TermSucc := TerminateProcess(hProcess, 0);
      if (TermSucc = false) then
        result := KILL_ERR_TERMINATEPROCESS
      else
        result := KILL_NOERR;
    end;
  end
  else
    result := KILL_NOTSUPPORTED;
end;

function  EnableDebugPrivilegeNT : integer;
var
  hToken : THANDLE;
  DebugValue : TLargeInteger;
  tkp : TTokenPrivileges ;
  ReturnLength : DWORD;
  PreviousState: TTokenPrivileges;
begin
  if (OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) = false) then
    result := ENUM_ERR_OPENPROCESSTOKEN
  else
  begin
    if (LookupPrivilegeValue(nil, SE_DEBUG_NAME, DebugValue) = false) then
      result := ENUM_ERR_LookupPrivilegeValue
    else
    begin
      ReturnLength := 0;
      tkp.PrivilegeCount := 1;
      tkp.Privileges[0].Luid := DebugValue;
      tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
      AdjustTokenPrivileges(hToken, false, tkp, SizeOf(TTokenPrivileges),PreviousState , ReturnLength);
      if (GetLastError <> ERROR_SUCCESS) then
        result := ENUM_ERR_AdjustTokenPrivileges
      else
        result := ENUM_NOERR;
    end;
  end;
end;

function  IsDigit(c : char) : boolean;
begin
  result := (c>='0') and (c<='9');
end;

function  min(a,b : integer) : integer;
begin
  if (a < b) then result := a
  else result := b;
end;

function  GetTaskListNT(pTask : TStrings) : integer;
var
  rc      : DWORD;
  hKeyNames : HKEY;
  dwType    : DWORD;
  dwSize    : DWORd;
  buf       : PBYTE;
  szSubkey  : array[0..1024] of char;
  lid       : LANGID;
  p         : PCHAR;
  p2        : PCHAR;
  pPerf     : pTPerfDataBlock;
  pObj      : pTPerfObjectType;
  pInst     : pTPerfInstanceDefinition;
  pCounter  : pTPerfCounterBlock;
  pCounterDef : pTPerfCounterDefinition;
  i           : DWORD;
  dwProcessIdTitle : DWORD;
  dwProcessIdCounter : DWORD;
  szProcessName : array[0..MAX_PATH] of char;
  dwLimit       : DWORD;
  dwNumTasks    : dword;

  ProcessName   : array[0..MAX_PATH] of char;
  dwProcessID   : DWORD;
label
  EndOfProc;
begin
  dwNumTasks := 255;
  dwLimit := dwNumTasks - 1;
  StrCopy(ProcessName, '');
  lid := MAKELANGID(LANG_ENGLISH, SUBLANG_NEUTRAL);
  StrFmt(szSubKey, '%s\%.3X', [REGKEY_PERF, lid]);
  rc := RegOpenKeyEx(HKEY_LOCAL_MACHINE, szSubKey, 0, KEY_READ, hKeyNames);
  if (rc <> ERROR_SUCCESS) then
    result := GETTASKLIST_ERR_RegOpenKeyEx
  else
  begin
    result := 0;
    rc := RegQueryValueEx(hKeyNames, REGSUBKEY_COUNTERS, nil, @dwType, nil, @dwSize);
    if (rc <> ERROR_SUCCESS) then
      result := GETTASKLIST_ERR_RegQueryValueEx
    else
    begin
      GetMem(buf, dwSize);
      FillChar(buf^, dwSize, 0);
      RegQueryValueEx(hKeyNames, REGSUBKEY_COUNTERS, nil, @dwType, buf, @dwSize);
      p := PCHAR(buf);
      dwProcessIdTitle := 0;
      while (p^<>#0) do
      begin
        if (p > buf) then
        begin
          p2 := p - 2;
          while(isDigit(p2^)) do
            dec(p2);
        end;
        if (StrIComp(p, PROCESS_COUNTER) = 0) then
        begin
          p2 := p -2;
          while(isDigit(p2^)) do
            dec(p2);
          strCopy(szSubKey, p2+1);
        end
        else
        if (StrIComp(p, PROCESSID_COUNTER) = 0) then
        begin
          p2 := p - 2;
          while(isDigit(p2^)) do
            dec(p2);
           dwProcessIdTitle := StrToIntDef(p2+1, -1);
        end;
        p := p + (Length(p) + 1);
      end;
      FreeMem(buf); buf := nil;
      dwSize := INITIAL_SIZE;
      GetMem(buf, dwSize);
      FillChar(buf^, dwSize, 0);
      pPerf := nil;
      while (true) do
      begin
        rc := RegQueryValueEx(HKEY_PERFORMANCE_DATA, szSubKey, nil, @dwType, buf, @dwSize);
        pPerf := pTPerfDataBlock(buf);
        if ((rc = ERROR_SUCCESS) and (dwSize > 0) and
            (pPerf^.Signature[0] = WCHAR('P')) and
            (pPerf^.Signature[1] = WCHAR('E')) and
            (pPerf^.Signature[2] = WCHAR('R')) and
            (pPerf^.Signature[3] = WCHAR('F'))
            ) then
        begin
          break;
        end;
        if (rc = ERROR_MORE_DATA) then
        begin
          dwSize := dwSize + EXTEND_SIZE;
          FreeMem(buf); buf := nil;
          GetMem(buf, dwSize);
          FillChar(buf^, dwSize, 0);
        end
        else
          goto EndOfProc;
      end;

      pObj := pTPerfObjectType( DWORD(pPerf) + pPerf^.HeaderLength);

      pCounterDef := pTPerfCounterDefinition( DWORD(pObj) + pObj^.HeaderLength);
      dwProcessIdCounter := 0;
      i := 0;
      while (i < pObj^.NumCounters) do
      begin
        if (pCounterDef^.CounterNameTitleIndex = dwProcessIdTitle) then
        begin
          dwProcessIdCounter := pCounterDEf^.CounterOffset;
          break;
        end;
        inc(pCounterDef);
        inc(i);
      end;
      dwNumTasks := min(dwLimit, pObj^.NumInstances);
      pInst := PTPerfInstanceDefinition(DWORD(pObj) + pObj^.DefinitionLength);

      i := 0;
      while ( i < dwNumTasks) do
      begin
        p := PCHAR(DWORD(pInst)+pInst^.NameOffset);
        rc := WideCharToMultiByte(CP_ACP, 0, LPCWSTR(p), -1, szProcessName, SizeOf(szProcessName), nil, nil);
        {** This is changed for working with D3 and D5 05/09/2000 **}
        if (rc = 0) then
          StrCopy(ProcessName, UNKNOWN_TASK)
        else
          StrCopy(ProcessName, szProcessName);
        // Получаем ID процесса
        pCounter := pTPerfCounterBlock( DWORD(pInst) + pInst^.ByteLength);
        dwProcessId := LPDWORD(DWORD(pCounter) + dwProcessIdCounter)^;
        if (dwProcessId = 0) then
          dwProcessId := DWORD(0);
        pTask.AddObject(ProcessName, TObject(dwProcessID));
        pInst := pTPerfInstanceDefinition( DWORD(pCounter) + pCounter^.ByteLength);
        inc(i);
      end;
      result := dwNumTasks;
    end;
  end;
EndOfProc:
  if (buf <> nil) then
    FreeMem(buf);
  RegCloseKey(hKeyNames);
  RegCloseKey(HKEY_PERFORMANCE_DATA);
  RegCloseKey(hKeyNames);
  RegCloseKey(HKEY_PERFORMANCE_DATA);
end;

function EnumProcessWithPid(list : TStrings) : integer;
begin
  if (verInfo.dwPlatformId = VER_PLATFORM_WIN32_NT) then
  begin
    EnableDebugPrivilegeNT;
    result := GetTaskListNT(list);
  end
  else
    result := ENUM_NOTSUPPORTED;
end;

initialization
  InitKill;
end.

Взято с Исходников.ru

Как, зная Handle окна программы, определить имя EXE?

//Для начала определяешь какому процессу принадлежит окно:

var pProcID: ^DWORD;
begin
  GetMem(pProcID, SizeOf(DWORD));
  GetWindowThreadProcessId(WinHandle, pProcID);
end;

// а после этого используешь TProcessEntry32 примерно так:

function GetExeNameByProcID(ProcID: DWord): string;
var
  ContinueLoop: BOOL;
  FSnapshotHandle: THandle;
  FProcessEntry32: TProcessEntry32;
begin
  FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);

  FProcessEntry32.dwSize := Sizeof(FProcessEntry32);

  ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);

  Result := '';
  while (Integer(ContinueLoop) <> 0) and (Result = '') do
    begin
      if FProcessEntry32.th32ProcessID = ProcID then
        Result := FProcessEntry32.szExeFile;
      ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
    end;
end;

// Не забудь в uses добавить Tlhelp32

Взято с

Какие есть директивы компилятора?

{$I+} и {$I-} - директивы контроля ввода/вывода
{$M} и {$S} - директивы, определяющие размер стека

{$M+} и {$M-} - директивы информации времени выполнения о типах
{$Q+} и {$Q-}   - директивы проверки переполнения целочисленных операций

{$R} - директива связывания ресурсов

{$R+} и {$R-} - директивы проверки диапазона

{$APPTYPE CONSOLE} - директива создания консольного приложения

1) Директивы компилятора, разрешающие или запрещающие проверку утверждений.

По умолчанию   {$C+} или {$ASSERTIONS ON}
Область действия локальная

   Директивы компилятора $C разрешают или запрещают проверку утверждений. Они влияют на работу процедуры Assert,используемой при отладке программ. По умолчанию действует
директива {$C+} и процедура Assert генерирует исключение EAssertionFailed, если проверяемое утверждение ложно.
   Так как эти проверки используются только в процессе отладки программы, то перед ее окончательной компиляцией следует указать директиву {$C-}. При этом работа процедур Assert будет блокировано и генерация исключений EassertionFailed производиться не будет.
   Директивы действуют на весь файл исходного кода независимо от того, в каком месте файла они расположены.

2) Директивы компилятора, включающие и выключающие контроль файлового ввода-вывода.

По умолчанию {$I+} или {$IOCHECKS ON}
Область действия локальная

   Директивы компилятора $I включают или выключают автоматический контроль результата вызова процедур ввода-вывода Object Pascal. Если действует директива {$I+}, то при возвращении процедурой ввода-вывода ненулевого значения генерируется исключение EInOutError и в его свойство errorcode заносится код ошибки. Таким образом, при действующей директиве {$I+} операции ввода-вывода располагаются в блоке try...except, имеющем обработчик исключения EInOutError. Если такого блока нет, то обработка производится методом TApplication.HandleException.
   Если действует директива {$I-}, то исключение не генерируется. В этом случае проверить, была ли ошибка, или ее не было, можно, обратившись к функции IOResult. Эта функция очищает ошибку и возвращает ее код, который затем можно анализировать. Типичное применение директивы {$I-} и функции IOResult демонстрирует следующий пример:

{$I-}

AssignFile(F,s);
Rewrite(F);

{$I+}
i:=IOResult;
if i<>0 then
  case i of
    2: ..........
    3: ..........
  end;

   В этом примере на время открытия файла отключается проверка ошибок ввода вывода, затем она опять включается, переменной i присваивается значение, возвращаемое функцией IOResult и, если это значение не равно нулю (есть ошибка), то предпринимаются какие-то действия в зависимости от кода ошибки. Подобный стиль программирования был типичен до введения в Object Pascal механизма обработки исключений. Однако сейчас, по-видимому, подобный стиль устарел и применение директив $I потеряло былое значение.

3) Директивы компилятора, определяющие размер стека

По умолчанию {$M 16384,1048576}
Область действия глобальная

   Локальные переменные в процедурах и функциях размещаются в стеке приложения. При каждом вызове процедуры или функции ее локальные переменные помещаются в стек. При выходе из процедуры или функции эти локальные процедуры удаляются из стека.
   Директивы компилятора $M задают параметры стека приложения: его минимальный и максимальный размеры. Приложение всегда гарантировано имеет размер стека, равный его минимальной величине. Если при запуске приложения Windows обнаруживает, что не может выделить этот минимальный объем памяти, то выдается сообщение об этой ошибке.
   Если во время работы выясняется, что минимального размера стека не хватает, то размер увеличивается на 4 K, но не более, чем до установленного директивой максимального размера. Если увеличение размера стека невозможно из-за нехватки памяти или из-за достижения его максимальной величины, генерируется исключение EStackOverflow. Минимальный размер стека по умолчанию равен 16384 (16K). Этот размер может изменяться параметром minstacksize директивы {$M} или параметром number директивы {$MINSTACKSIZE}.
   Максимальный размер стека по умолчанию равен 1,048,576 (1M). Этот размер может изменяться параметром maxstacksize директивы {$M} или параметром number директивы {$MAXSTACKSIZE number}. Значение минимального размера стека может задаваться целым числом в диапазоне между1024 и 2147483647. Значение максимального размера стека должно быть не менее минимального размера и не более 2147483647. Директивы задания размера стека могут включаться только в программу и не должны использоваться в библиотеках и модулях.

   В Delphi 1 имеется процедура компилятора {$S}, осуществляющая переключение контроля переполнения стека. Теперь этот процесс полностью автоматизирован и директива {$S} оставлена только для обратной совместимости.

4) Директивы компилятора, включающие и выключающие генерацию информации времени выполнения о типах (runtime type information - RTTI).

По умолчанию {$M-} или {$ TYPEINFO OFF}
Область действия локальная

   Директивы компилятора $M включают или выключают генерацию информации времени выполнения о типах (runtime type information - RTTI). Если класс объявляется в состоянии {$M+} или является производным от класса объявленного в этом состоянии, то компилятор генерирует RTTI о его полях, методах и свойствах, объявленных в разделе published. В противном случае раздел published в классе не допускается. Класс TPersistent, являющийся предшественником большинства классов Delphi и все классов компонентов, объявлен в модуле Classes в состоянии {$M+}. Так что для всех классов, производных от него, заботиться о директиве {$M+}не приходится.

5) Директивы компилятора, включающие и выключающие проверку переполнения при целочисленных операциях

По умолчанию {$Q-} или {$OVERFLOWCHECKS OFF}
Область действия локальная

   Директивы компилятора $Q включают или выключают проверку переполнения при целочисленных операциях. Под переполнением понимается получение результата, который не может сохраняться в регистре компьютера. При включенной директиве {$Q+} проверяется переполнение при целочисленных операциях +, -, *, Abs, Sqr, Succ, Pred, Inc и Dec. После каждой из этих операций размещается код, осуществляющий соответствующую проверку. Если обнаружено переполнение, то генерируется исключение EIntOverflow. Если это исключение не может быть обработано, выполнение программы завершается.
   Директивы $Q проверяют только результат арифметических операций. Обычно они используются совместно с директивами {$R}, проверяющими диапазон значений при присваивании.
   Директива {$Q+} замедляет выполнение программы и увеличивает ее размер. Поэтому обычно она используется только во время отладки программы. Однако, надо отдавать себе отчет, что отключение этой директивы приведет к появлению ошибочных результатов расчета в случаях, если переполнение действительно произойдет во время выполнении программы. Причем сообщений о подобных ошибках не будет.

6) Директивы компилятора, включающие и выключающие проверку диапазона целочисленных значений и индексов

По умолчанию {$R} или {$RANGECHECKS OFF}
Область действия локальная

   Директивы компилятора $R включают или выключают проверку диапазона целочисленных значений и индексов. Если включена директива {$R+}, то все индексы массивов и строк и все присваивания скалярным переменным и переменным с ограниченным диапазоном значений проверяются на соответствие значения допустимому диапазону. Если требования диапазона нарушены или присваиваемое значение слишком велико, генерируется исключение ERangeError. Если оно не может быть перехвачено, выполнение программы завершается.
   Проверка диапазона длинных строк типа Long strings не производится.
Директива {$R+} замедляет работу приложения и увеличивает его размер. Поэтому она обычно используется только во время отладки.

6) Директива компилятора, связывающая с выполняемым модулем файлы ресурсов

Область действия локальная

   Директива компилятора {$R} указывает файлы ресурсов (.DFM, .RES), которые должны быть включены в выполняемый модуль или в библиотеку. Указанный файл должен быть файлом ресурсов Windows. По умолчанию расширение файлов ресурсов - .RES.
   В процессе компоновки компилированной программы или библиотеки файлы, указанные в директивах {$R}, копируются в выполняемый модуль. Компоновщик Delphi ищет эти файлы сначала в том каталоге, в котором расположен модуль, содержащий директиву {$R}, а затем в каталогах, указанных при выполнении команды главного меню Project | Options на странице Directories/Conditionals диалогового окна в опции Search path или в опции /R командной строки DCC32.
   При генерации кода модуля, содержащего форму, Delphi автоматически включает в файл .pas директиву {$R *.DFM}, обеспечивающую компоновку файлов ресурсов форм. Эту директиву нельзя удалять из текста модуля, так как в противном случае загрузочный модуль не будет создан и генерируется исключение EResNotFound.

Автор ответа: Cashey
Взято с Vingrad.ru

Исправлено и пополнено: Jin X

Примечание Vit:
Все установленные в настройках опции компиляции можно вставить непосредственно в текст программы нажав клавиши Ctrl-O, O

Каким драйвером пользуется TDATABASE?

Вы можете использовать вызов IDAPI dbiGetDatabaseDesc. Вот быстрая справка (не забудьте добавить DB в список используемых модулей):

var
pDatabase: DBDrsc:
begin
{ pAlias - PChar, содержащий имя псевдонима }
dbiGetDatabaseDesc ( pAlias, @pDatabase ) ;

Для получения дополнительной информации обратитесь к описанию свойства pDatabase.szDbType.

Взято с

Каким обpазом выбиpать pазмеp шpифта?

Автор: Nomadic

Каким обpазом выбиpать pазмеp шpифта, т.к. все мои стpадания по выбоpyпаpаметpов шpифта в CreateFont() никак не отpажались на его pазмеpе. Все что я пpидyмал, это юзать glScale(), но в этом слyчае полyчаем плохое качество (по сpавнению с той-же Воpдой) пpи малом pазмеpе символов

Вот часть работающего примера на Си (переведенного мною на Паскаль (АА)).

procedureGLSetupRC(pData: Pointer)
  //void GLSetupRC(void *pData)
//{
var
  //  HDC hDC;

  hDC: HDC;
  //  HFONT hFont;

  hFont: HFONT;
  //  GLYPHMETRICSFLOAT agmf[128];
  agmf: array[0..127] of GLYPHMETRICSFLOAT;
  //  LOGFONT logfont;

  logfont: LOGFONT;

begin

  logfont.lfHeight := -10;
  logfont.lfWidth := 0;
  logfont.lfEscapement := 0;
  logfont.lfOrientation := 0;
  logfont.lfWeight := FW_BOLD;
  logfont.lfItalic := FALSE;
  logfont.lfUnderline := FALSE;
  logfont.lfStrikeOut := FALSE;
  logfont.lfCharSet := ANSI_CHARSET;
  logfont.lfOutPrecision := OUT_DEFAULT_PRECIS;
  logfont.lfClipPrecision := CLIP_DEFAULT_PRECIS;
  logfont.lfQuality := DEFAULT_QUALITY;
  logfont.lfPitchAndFamily := DEFAULT_PITCH;
  //strcpy(logfont.lfFaceName,"Arial");
  //  strcpy(logfont.lfFaceName,"Decor");

  StrPCopy(logfont.lfFaceName, 'Decor');

  glDepthFunc(GL_LESS);
  glEnable(GL_DEPTH_TEST); // Hidden surface removal
  glFrontFace(GL_CCW); // Counter clock-wise polygons face out
  glEnable(GL_CULL_FACE); // Do not calculate insides
  glShadeModel(GL_SMOOTH); // Smooth shading
  glEnable(GL_AUTO_NORMAL);
  glEnable(GL_NORMALIZE);
  glEnable(GL_COLOR_MATERIAL);

  glClearColor(0.0, 0.0, 0.0, 1.0);

  glEnable(GL_LIGHTING);
  glLightfv(GL_LIGHT0, GL_AMBIENT, ambientLight);
  glLightfv(GL_LIGHT0, GL_DIFFUSE, diffuseLight);
  glLightfv(GL_LIGHT0, GL_SPECULAR, specular);
  glLightfv(GL_LIGHT0, GL_POSITION, lightPos);
  glEnable(GL_LIGHT0);

  glColorMaterial(GL_FRONT, GL_AMBIENT_AND_DIFFUSE);
  glMaterialfv(GL_FRONT, GL_SPECULAR, specular);
  glMateriali(GL_FRONT, GL_SHININESS, 100);

  // Blue 3D Text
  glRGB(0, 0, 255);

  // Select the font into the DC
  hDC := (HDC)pData;
  //  hFont = CreateFontIndirect(&logfont);

  hFont := CreateFontIndirect(Addr(logfont));
  SelectObject(hDC, hFont);

  //create display lists for glyphs 0 through 255 with 0.3 extrusion
  // and default deviation. The display list numbering starts at 1000
  // (it could be any number).
  //  if(!wglUseFontOutlines(hDC, 0, 128, 1000, 0., 0.3,
  //                            WGL_FONT_POLYGONS, agmf))

  if not wglUseFontOutlines(hDC, 0, 128, 1000, 0., 0.3,

    //>                                         ``` - это тебе поможет
    //> Выводить текст можно в любым масштабе

    WGL_FONT_POLYGONS, agmf) then

    Windows.MessageBox(nil, 'Could not create Font Outlines',
      'Error', MB_OK or MB_ICONSTOP);

  // Delete the font now that we are done
  DeleteObject(hFont);
  //}
end;

// void GLRenderScene(void *pData)

procedure GLRenderScene(pData: Pointer);
begin

  (*  ...  *)

  // Draw 3D text
  glListBase(1000);
  glPushMatrix();
  // Set up transformation to draw the string.
  glTranslatef(-35.0, 0.0, -5.0);
  glScalef(60.0, 60.0, 60.0);
  glCallLists(3, GL_UNSIGNED_BYTE, 'Decor');
  glPopMatrix(); // Clear the window with current clearing color

  (* ... *)
end;

Взято из

Каким образом задать прозрачный цвет иконки?

По умолчанию цвет нижнего левого пикселя считается прозрачным, только та программа/контрол/компонент который отражает эту иконку должна поддерживать прозрачность...

Автор ответа: Vit
Взято с Vingrad.ru

Какой формат данных предпочесть в Delphi? DBase или Paradox?

Если вам действительно все равно, то вот несколько пунктов "за" формат Paradox:

1. Широкий выбор типов полей, включая автоинкремент, BLOBs, и т.п.
2. Соблюдение целостности данных, контроля данных, обновления индексов на уровне ядра BDE.
3. Первичный индекс таблицы автоматически соблюдает уникальность записей, вторичные индексы обеспечивают отсортированный "вид" на записи таблицы.

Copyright © 1996 Epsylon Technologies

Взято из

FAQ Epsylon Technologies (095)-913-5608; (095)-913-2934; (095)-535-5349

Какой язык на данный момент на клавиатуре?

Используй GetKeyboardLayoutName

Автор ответа: Mikel
Взято с Vingrad.ru

var
Form1: TForm1;
LAYOUT: String;
implementation
{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
  RA: Array[0..$FFF] of Char;
begin
GetKeyboardLayoutName(RA) ;
Layout := StrPas(RA);
if Layout = '00000419' then
  showmessage(' CCCP ' )
else
  if Layout = '00000409' then
    showmessage(' USA ' )
  else
    showmessage(' X 3 ' ) ;
end;

Автор ответа: RAdmin
Взято с Vingrad.ru

function WhichLanguage:string;
var
ID:LangID;
Language: array [0..100] of char;
begin
ID:=GetSystemDefaultLangID;
VerLanguageName(ID,Language,100);
Result:=String(Language);
end;

Пример вызова этой функции:

procedure TForm1.Button1Click(Sender: TObject);
begin
  Edit1.Text:=WhichLanguage;
end;

Также, для определения активного языка можно воспользоваться функцией GetUserDefaultLangID.

Взято с Исходников.ru

Какой шрифт установлен (крупный или мелкий)?

functionSmallFonts: Boolean;
{Значение функции TRUE если мелкий шрифт}
var
  DC: HDC;
begin
  DC := GetDC(0);
  Result := (GetDeviceCaps(DC, LOGPIXELSX) = 96);
  { В случае крупного шрифта будет 120}
  ReleaseDC(0, DC);
end;

Взято из

Каковы текущие ограничения BDE?

Основные ограничения BDE:
48 клиентов в системе;
32 сессии на одного клиента (для версии 3.5 и ниже, 16 Bit, 32 Bit)
256 сессий на одного клиента (для версии 4.0 и выше, 32 Bit)
32 открытых баз данных на сессию (для версии 3.5 и ниже, 16 Bit, 32 Bit)
2048 открытых баз данных на сессию (для версии 4.0 и выше, 32 Bit)
32 загруженных драйвера
64 сессии в системе (для версии 3.5 и ниже, 16 Bit, 32 Bit)
12288 сессии в системе (для версии 4.0 и выше, 32 Bit)
4000 курсоров на сессию
16 вхождений в стеке ошибок
8 типов таблиц на один драйвер
16 типов полей на один драйвер
8 типов индексов на один драйвер
48K Размер конфигурационного файла (IDAPI.CFG)
64K Максимальный размер оператора SQL при RequestLive=False
4K Максимальный размер оператора SQL при RequestLive=True (для версии 4.0 и ниже, 16/32 Bit)
6K Максимальный размер оператора SQL при RequestLive=True (для версии 4.01 и выше, 32 Bit)
16K Размер буфера записи (SQL и ODBC)
31 Размер имени таблицы и имени поля в символах
64 Размер имени хранимой процедуры в символах
16 Полей в ключе
3 Размер расширения имени файла в символах
260 Длина имени таблицы в символах (некоторые сервера могут иметь другие ограничения)
260 Длина полного имени файла и пути файловой системы в символах

Ограничения Paradox:
127 открытых таблиц в системе (для версии 4.0 и ниже, 16/32 Bit)
254 открытых таблиц в системе (для версии 4.01 и выше, 32 Bit)
64 блокировки на запись на одну таблицу (16Bit) на одну сессию
255 блокировок на запись на одну таблицу (32Bit) на одну сессию
255 записей, учавствующих в транзакции на таблицу (32 Bit)
512 открытых физически файлов (DB, PX, MB, X??, Y??, VAL, TV) (для версии 4.0 и ниже, 16/32 Bit)
1024 открытых физически файлов (DB, PX, MB, X??, Y??, VAL, TV) (для версии 4.01 и выше, 32 Bit)
300 пользователей в одном файле PDOXUSRS.NET
255 полей в таблице
255 размер символьных полей
2 миллиарда записей в таблице
2 миллиарда байт в .DB (таблица) файле
10800 байт на запись для индексированных таблиц
32750 байт на запись для неиндексированных таблиц
127 вторичных индексов на таблицу
16 полей на индекс
255 одновременно работающих пользователей на таблицу
256 Мегабайт данных на одно BLOb поле
100 паролей на сессию
15 длина пароля
63 паролей на таблицу
159 полей с проверками корректности (validity check) (32 Bit)
63 поля с проверками корректности (validity check) (16 Bit)

Ограничения dBase:
256 открытых таблиц dBASE на систему (16 Bit)
350 открытых таблиц dBASE на систему (BDE 3.0 - 4.0, 32 Bit)
512 открытых таблиц dBASE на систему (BDE 4.01 и выше, 32 Bit)
100 блокировок на запись на одной таблице dBASE (16 and 32 Bit)
100 записей, учавствующих в транзакции на таблицу (32 Bit)
1 миллиард записей в таблице
2 миллиарда байт в файле .DBF (таблица)
4000 Размер записи в байтах (dBASE 4)
32767 Размер записи в байтах (dBASE for Windows)
255 Количество полей в таблице (dBASE 4)
1024 Количество полей в таблице (dBASE for Windows)
47 Количество тэгов индексов на один .MDX-файл.
254 Размер символьных полей
10 открытых основных индексов (.MDX) на таблицу
220 Длина ключевого выражения в символах

Взято из Akzhan's Database Delphi

Какую ветвь реестра использовать для своей проги?

Для настроек уникальных для компьютера:
HKEY_LOCAL_MACHINE\SOFTWARE\наименование твоей организации\имя программы

Для настроек уникальных для пользователя в пределах одного компьютера:
HKEY_CURRENT_USER\SOFTWARE\наименование твоей организации\имя программы

Авторы Pegas, Vit
Взято с Vingrad.ru

Карта высот картинки

{
вы знаете что такое карта высот?
можно создать супер эффект  на простом Canvas
к сожалению мой код моргает при перерисовке,
но вы уж поковыряйтесь.... :)
}

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, StdCtrls, ExtDlgs, math, ComCtrls, ShellApi;

type
  TForm1 = class(TForm)
    Image1: TImage;
    OpenDialog1: TOpenDialog;
    Timer1: TTimer;
    PageControl1: TPageControl;
    Specular: TTabSheet;
    sRed: TEdit;
    Label1: TLabel;
    ScrollBar1: TScrollBar;
    Label2: TLabel;
    sGreen: TEdit;
    ScrollBar2: TScrollBar;
    ScrollBar3: TScrollBar;
    sBlue: TEdit;
    Label3: TLabel;
    Label4: TLabel;
    Edit1: TEdit;
    ScrollBar4: TScrollBar;
    Diffuse: TTabSheet;
    Ambient: TTabSheet;
    Label5: TLabel;
    Label6: TLabel;
    Label7: TLabel;
    dGreen: TEdit;
    dBlue: TEdit;
    dRed: TEdit;
    ScrollBar5: TScrollBar;
    ScrollBar6: TScrollBar;
    ScrollBar7: TScrollBar;
    Label8: TLabel;
    Label9: TLabel;
    Label10: TLabel;
    aBlue: TEdit;
    aGreen: TEdit;
    aRed: TEdit;
    ScrollBar8: TScrollBar;
    ScrollBar9: TScrollBar;
    ScrollBar10: TScrollBar;
    Label11: TLabel;
    Label12: TLabel;
    Edit2: TEdit;
    Label13: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure ScrollBarChange(Sender: TObject);
    procedure Label11Click(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

type
  normal = record
    x: integer;
    y: integer;
  end;

type
  rgb32 = record
    b: byte;
    g: byte;
    r: byte;
    t: byte;
  end;
type
  rgb24 = record
    r: integer;
    g: integer;
    b: integer;
  end;

var
  Form1: TForm1;
  bumpimage: tbitmap;
  current_X, Current_Y: integer;
var
  Bump_Map: array[0..255, 0..255] of normal;
  Environment_map: array[0..255, 0..255] of integer;
  Palette: array[0..256] of rgb24;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
type
  image_array = array[0..255, 0..255] of byte;
var
  x, y: integer;
  Buffer: image_array;
  bump_file: file of image_array;
  ny2, nx, nz: double;
  c: integer;
  ca, cap: double;
begin
  assignfile(bump_File, 'bump.raw');
  reset(Bump_File);
  Read(Bump_File, buffer);
  for y := 1 to 254 do
  begin
    for x := 1 to 254 do
    begin
      Bump_Map[x, y].x := buffer[y + 1, x] - buffer[y + 1, x + 2];
      bump_map[x, y].y := buffer[y, x + 1] - buffer[y + 2, x + 1];
    end;
  end;
  closefile(bump_File);

  for y := -128 to 127 do
  begin
    nY2 := y / 128;
    nY2 := nY2 * nY2;
    for X := -128 to 127 do
    begin
      nX := X / 128;
      nz := 1 - SQRT(nX * nX + nY2);
      c := trunc(nz * 255);
      if c < = 0 then
        c := 0;
      Environment_Map[x + 128, y + 128] := c;
    end;
  end;

  nx := pi / 2;
  ny2 := nx / 256;
  for y := 0 to 255 do
  begin
    ca := cos(nx);
    cap := power(ca, 35);
    nx := nx - ny2;
    palette[y].r := trunc((128 * ca) + (235 * cap));
    if palette[y].r > 255 then
      palette[y].r := 255;
    palette[y].G := trunc((128 * ca) + (245 * cap));
    if palette[y].g > 255 then
      palette[y].g := 255;
    palette[y].B := trunc(5 + (170 * ca) + (255 * cap));
    ;
    if palette[y].b > 255 then
      palette[y].b := 255;
  end;
  bumpimage := TBitmap.create;
  bumpimage.width := 255;
  bumpimage.height := 255;
  bumpimage.PixelFormat := pf32bit;
  Image1.Picture.Bitmap := bumpimage;
  image1mousemove(self, [], 128, 128);
  application.ProcessMessages;

end;

procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  Current_X := x;
  Current_Y := y;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
  x, y, x2, y2, y3: integer;
  Scan: ^Scanline;
  bx, by: longint;
  c: byte;
begin
  x := Current_X;
  y := Current_Y;
  for y2 := 0 to 253 do
  begin
    scan := image1.Picture.Bitmap.ScanLine[y2];
    y3 := 128 + y2 - y;
    for x2 := 0 to 253 do
    begin
      bx := bump_Map[x2, y2].x + 128 + x2 - x;
      by := bump_Map[x2, y2].y + y3;
      if (bx < 255) and (bx > 0) and (by < 255) and (by > 0) then
      begin
        c := Environment_Map[bx, by];
        scan^[x2].r := palette[c].r;
        scan^[x2].g := palette[c].g;
        scan^[x2].b := palette[c].b;
      end
      else
      begin
        scan^[x2].r := palette[0].r;
        scan^[x2].g := palette[0].g;
        scan^[x2].b := palette[0].b;
      end;
      {image1.Canvas.Pixels[x,y] := rgb(r,g,b);}
    end;
  end;
  image1.Refresh;

end;

procedure TForm1.ScrollBarChange(Sender: TObject);
var
  ny2, nx: double;
  c: integer;
  ca, cap: double;
begin
  sRed.Text := inttostr(scrollbar1.position);
  sGreen.Text := inttostr(scrollbar2.position);
  sBlue.Text := inttostr(scrollbar3.position);
  edit1.Text := inttostr(scrollbar4.position);

  dRed.Text := inttostr(scrollbar5.position);
  dGreen.Text := inttostr(scrollbar6.position);
  dBlue.Text := inttostr(scrollbar7.position);

  aRed.Text := inttostr(scrollbar8.position);
  aGreen.Text := inttostr(scrollbar9.position);
  aBlue.Text := inttostr(scrollbar10.position);

  nx := pi / 2;
  ny2 := nx / 256;
  for C := 0 to 255 do
  begin
    ca := cos(nx);
    cap := power(ca, scrollbar4.position);
    nx := nx - ny2;
    palette[c].r := trunc(scrollbar8.position + (scrollbar5.position * ca) +
      (scrollbar1.position * cap));
    if palette[c].r > 255 then
      palette[c].r := 255;
    palette[c].G := trunc(scrollbar9.position + (scrollbar6.position * ca) +
      (scrollbar2.position * cap));
    if palette[c].g > 255 then
      palette[c].g := 255;
    palette[c].B := trunc(scrollbar10.position + (scrollbar7.position * ca) +
      (scrollbar3.position * cap));
    ;
    if palette[c].b > 255 then
      palette[c].b := 255;
  end;
  image1mousemove(self, [], Current_X, Current_Y);
  application.ProcessMessages;

end;

procedure TForm1.Label11Click(Sender: TObject);
begin
  ShellExecute(handle, 'open', 'http://wkweb5.cableinet.co.uk/daniel.davies/',
    nil, nil, SW_SHOWNORMAL);
end;

end.

Взято из

Каскадированное удаление с проверкой целостности Paradox

Таблицы Paradox имеют характеристику проверки целостности (Referential Integrity). Данная характеристика предотвращает добавление записей в дочернюю таблицу, для которых нет соответствующих записей в родительской таблице. Это также изменяет ключевое(ые) поле(я) в дочерней таблице при изменениях в соответствующем(их) ключевом(ых) поле(ях) родительской таблицы (обычно это называют каскадированным обновлением). Эти события происходят автоматически, и не требуют никакого вмешательства со стороны Delphi-приложений, использующих эти таблицы. Тем не менее, характеристика проверки целостности таблиц Paradox не работает с каскадированным удалением. То есть, Delphi не позволит вам удалять записи в родительской таблице при наличии существующих записей в дочерней таблице. Это могут сделать только дочерние записи "без родителей", обходя проверку целостности. При попытке удаления такой родительской записи, Delphi сгенерит объект исключительной ситуации.

Для того, чтобы каскадированное удаление дало эффект, требуется программное удаление соответствующих дочерних записей прежде, чем будет удалена родительская запись. В приложениях Delphi это делается посредством прерывания удаления записи в родительской таблице, удаление соответствующих записей в дочерней таблице (если таковая имеется), и затем продолжение удаления родительской записи.

Удаление записи таблицы осуществляется вызовом метода Delete компонента TTable, который удаляет текущую запись в связанной с компонентом таблице. Прерывание процесса удаления для выполнения других операций связано с созданием обработчика события BeforeDelete компонента TTable. Любые действия в обработчике события BeforeDelete произойдут прежде, чем приложением будет послана команда Borland Database Engine (BDE) на физическое удаление записи из табличного файла.

Для того, чтобы обработать удаление одной или более дочерних записей, в обработчике события BeforeDelete необходимо организовать цикл, осуществляющий вызов метода Delete компонента TTable для всех записей дочерней таблицы. Цикл основан на условии, что указатель на запись в таблице не позиционируется на конец набора данных, как указано методом Eof компонента TTable. Это также предполагает, что удаляются все дочерние записи, соответствующие родительским записям: если нет соответствующих записей, указатель на запись устанавливается на конец набора данных, условие выполнения цикла равно False, и метод Delete в теле цикла никогда не выполняется.

procedureTForm1.Table1BeforeDelete(DataSet: TDataset);
begin
  with Table2 do
  begin
    DisableControls;
    First;
    while not Eof do
      Delete;
    EnableControls;
  end;
end;

В вышеуказанном примере родительская таблица представлена компонентом TTable с именем Table1, и дочерняя таблица с именем Table2. Методы DisableControls и EnableControls использованы в "косметических" целях, чтобы "заморозить" любые компоненты для работы с базами данных, которые могли бы отображать данные из таблицы Table2 во время удаления записей. Эти два метода делают процесс визуально "гладким", и не являются обязательными. Метод Next в теле данного цикла вызываться не должен. Дело в том, что цикл начинается с первой записи и, так как каждая запись удаляется, запись, предшествующая удаленной, перемещается в наборе данных вверх, становясь одновременно первой и текущей записью.

Данный пример предполагает, что родительская и дочерняя таблицы связаны отношением Мастер-Деталь, типичным для таблиц, в которых сконфигурирована проверка целостности. В результате, в связанных таблицах становятся доступны только те записи дочерней таблицы, которые соответствуют текущей записи родительской таблицы. Все другие записи в дочерней таблице делаются недоступными через фильтрацию Мастер-Деталь. Если таблицы не связаны отношениями Мастер-Деталь, то есть два дополнительных замечания, которые необходимо принимать во внимание при удалении записи дочерней таблицы. Первое: вызов метода First может и не переместить указатель записи в запись, соответствующей текущей записи родительской таблицы. Для этого необходимо воспользоваться методом search, вручную перемещающий указатель на сопоставимую запись. Второе замечание относится к условию цикла. Поскольку будут доступны другие записи, не относящиеся к записям родительской таблицы, сопоставимым (Мастер-Деталь) к текущей записи, то перед удалением записи необходимо осуществлять проверку на сопоставимость удаляемой записи. Эта проверка должна проводиться дополнительно к методу Eof. Поскольку записи будут сортироваться по ключевому полю (первичного или вторичного индекса), все сопоставления (Мастер-Деталь) будут непрерывными. Это будет истиной до достижения первой не-сопоставимой записи, после чего можно считать, что все сопоставимые записи были удалены. Таким образом, предыдущий пример необходимо изменить следующим образом:

procedure TForm1.Table1BeforeDelete(DataSet: TDataset);
begin
  with Table2 do
  begin
    DisableControls;
    FindKey([Table1.Fields[0].AsString])
    while (Fields[0].AsStrring = Table1.Fields[0].AsString)
    and (not Eof) do
      Delete;
    EnableControls;
  end;
end;

В приведенном выше примере - первое поле родительской таблицы (Table1), на которой базируется проверка целостности, и первое поле дочерней таблицы (Table2), с которым производится сопоставление

Взято из

Кириллица в параметрах CGI-запроса

Вопрос: Я хочу реализовать регистрацию своей программы через Internet. Для этого я вызываю CGI-скрипт, которому в качестве параметра передается имя пользователя. Однако, если имя набрано кириллицей, происходит ошибка. В чем дело?

Дело в том, что при передаче запроса по протоколу HTTP служебные символы и символы с кодами 128..255 надо кодировать. То есть, если пользователь ввел имя 'Вася Пупкин', то запрос для регистрации должен выглядеть не так:

http://site/cgi-bin/reg.pl?user=Вася Пупкин

а вот так:

http://site/cgi-bin/reg.pl?user=%C2%E0%F1%FF+%CF%F3%EF%EA%E8%ED

Решить проблему перекодировки туда и обратно может компонент TNMURL.

DK: Дополнительную информацию про кодирование URL'ов, можно прочитать в RFC1738

Взято с

Клавиатура

Cодержание раздела:

См. также другие разделы:

См. также статьи в других разделах:

Кнопка или пункт меню выполняет другую функцию при нажатой кнопке shift

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

GetKeyState принимает в качестве параметра виртуальный код кнопки и возвращает значение меньше 0,
если кнопка нажата.

Вот пример события OnClick для кнопки:

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

Отмечу, что вы можете также использовать параметры VK_CONTROL или VK_MENU
для проверки нажатия кнопок control и alt, соответственно!

Matt Hamilton

Взято с сайта

Кнопка со звуком

Когда Вы нажимаете на кнопку, то видите трёхмерный эффект нажатия. А как же насчёт четвёртого измерения, например звука ? Ну тогда нам понадобится звук для нажатия и звук для отпускания кнопки. Если есть желание, то можно добавить даже речевую подсказку, однако не будем сильно углубляться.

Компонент звуковой кнопки имеет два новых свойства:

type
  TDdhSoundButton = class(TButton)
  private
    FSoundUp, FSoundDown: string;
  protected
    procedure MouseDown(Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer); override;
  published
    property SoundUp: string
      read FSoundUp write FSoundUp;
    property SoundDown: string
      read FSoundDown write FSoundDown;
  end;

Звуки будут проигрываться при нажатии и отпускании кнопки:

procedure TDdhSoundButton.MouseDown(
  Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  inherited;
  PlaySound (PChar (FSoundDown), 0, snd_Async);
end;

procedure TDdhSoundButton.MouseUp(Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  inherited;
  PlaySound (PChar (FSoundUp), 0, snd_Async);
end;

Взято с Исходников.ru

Кобинации клавиш Ctrl-C, Ctrl-O, и т.д. не срабатывают. В чём проблема?

Взято из FAQ:
Перевод материала с сайта members.home.com/hfournier/webbrowser.htm

Это не ошибка. Информацию по данному вопросу можно найти на сайте
Microsoft KnowledgeBase статья Q168777.
Приведённый ниже код, устраняет данную проблему:

... var
Form1: TForm1;
FOleInPlaceActiveObject: IOleInPlaceActiveObject;
SaveMessageHandler: TMessageEvent;
...
implementation
...

procedure TForm1.FormActivate(Sender: TObject);
begin
SaveMessageHandler := Application.OnMessage;
Application.OnMessage := MyMessageHandler;
end;

procedure TForm1.FormDeactivate(Sender: TObject);
begin
  Application.OnMessage := SaveMessageHandler;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Application.OnMessage := SaveMessageHandler;
  FOleInPlaceActiveObject := nil;
end;

procedure TForm1.MyMessageHandler(var Msg: TMsg; var Handled: Boolean);
var
  iOIPAO: IOleInPlaceActiveObject;
  Dispatch: IDispatch;
begin
{ exit if we don't get back a webbrowser object }
if WebBrowser = nil then
begin
Handled := False;
Exit;
end; Handled:=(IsDialogMessage(WebBrowser.Handle, Msg) = True); if (Handled) and (not WebBrowser.Busy) then
begin
if FOleInPlaceActiveObject = nil then
begin
Dispatch := WebBrowser.Application;
if Dispatch < > nil then
begin
Dispatch.QueryInterface(IOleInPlaceActiveObject, iOIPAO);
if iOIPAO < > nil then
FOleInPlaceActiveObject := iOIPAO;
end;
end; if FOleInPlaceActiveObject < > nil then
if ((Msg.message = WM_KEYDOWN) or (Msg.message = WM_KEYUP)) and
((Msg.wParam = VK_BACK) or (Msg.wParam = VK_LEFT) or (Msg.wParam = VK_RIGHT)) then
//nothing - do not pass on Backspace, Left or Right arrows
else
FOleInPlaceActiveObject.TranslateAccelerator(Msg);
end;
end;

Код определения свойств

Итак вам опять нужно "немного" кода. Вот небольшой примерчик компонента лично для вас и остальных моих читателей. Установите этот компонент в палитру Delphi, бросьте экземпляр на форму, закройте ее и модуль и откройте форму как файл формы, используя в диалоге открытия тип *.dfm. Вы увидите дополнительные свойства 'StringThing' и 'Thing'. Первое - свойство строки, второе - бинарное свойство, фактически запись. Если вы имеете HexEdit (шестнадцатиричный редактор) или что-то аналогичное, взгляните на ваш dfm-файл и вы увидите тэги ваших новых свойств вместе с их именами.

Если TReader/TWriter имеет специфические методы для чтения/записи свойств и вы хотите добавить, например, строку, целое, символ или что-то еще (проверьте описание соответствующих методов TReader в файлах помощи), то в этом случае используйте DefineProperty. В случае сложного объекта используйте DefineBinaryProperty и ваши методы чтения и записи получат TStream вместо TReader/TWriter.

unitPropDemo;

interface

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

type
  TDemoProps = class(TComponent)
  private
{ Private declarations }
    FStringThing: string;
    FThing: record
      i, j, k: integer;
      x, y: real;
      ch: char;
    end;
    procedure ReadStringThing(Reader: TReader);
    procedure WriteStringThing(Writer: TWriter);
    procedure ReadThing(Stream: TStream);
    procedure WriteThing(Stream: TStream);
  protected
{ Protected declarations }
    procedure DefineProperties(Filer: TFiler); override;
  public
{ Public declarations }
    constructor Create(AOwner: TComponent); override;
  published
{ Published declarations }
  end;

procedure Register;

implementation

constructor TDemoProps.Create(AOwner: TComponent);

begin
  inherited Create(AOwner);
{ создайте любые данные, чтобы было что передать в поток}
  FStringThing := 'Всем привет!';
  with FThing do
    begin
      i := 1;
      j := 2;
      k := 3;
      x := PI;
      y := 180 / PI;
      ch := '?';
    end;
end;

procedure TDemoProps.ReadStringThing(Reader: TReader);
begin
  FStringThing := Reader.ReadString;
end;

procedure TDemoProps.WriteStringThing(Writer: TWriter);
begin
  Writer.WriteString(FStringThing);
end;

procedure TDemoProps.ReadThing(Stream: TStream);
begin
  Stream.ReadBuffer(FThing, sizeof(FThing));
end;

procedure TDemoProps.WriteThing(Stream: TStream);
begin
  Stream.WriteBuffer(FThing, sizeof(FThing));
end;

procedure TDemoProps.DefineProperties(Filer: TFiler);
begin
  inherited DefineProperties(Filer);
  Filer.DefineProperty('StringThing', ReadStringThing, WriteStringThing,
    FStringThing <> '');
  Filer.DefineBinaryProperty('Thing', ReadThing, WriteThing, true);
end;

procedure Register;
begin
  RegisterComponents('Samples', [TDemoProps]);
end;

end.

Mike Scott
Mobius Ltd.

Взято из

Советов по Delphi от

Сборник Kuliba

Количество активных потоков и загруженность процессора

Автор: Vimil Saju

В реестре есть раздел HKEY_DYN_DATA. Основная информация о системе хранится в ключе PerfStats.

О получении информации,например, о загруженности процессора, необходимо проделать следующие шаги:

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

Например
Просто считываем значение ключа 'PerfStats\StartStat\KERNEL\CPUusage' в секции HKEY_DYN_DATA. данное действие запускает счётчик. После этого в ключе 'PerfStats\StatData\KERNEL\CPUusage' будет храниться значение в процентах о загруженности процессора.

Далее, если добавить считывание загруженности процессора в событие On timer, то мы сможем наблюдать изменение загруженности процессора в динамике.

По завершении, Ваша программа должна остановить счётчик в реестре. Для этого просто считай ключ 'PerfStats\StopStat\KERNEL\CPUusage'.Это остановит счётчик.
Так же в системе есть много других счётчиков. Весь список счётчиков можно посмотреть в ключе PerfStats\StatData, используя редактор реестра.

Представленный ниже исходник получает значения всех счётчиков, расположенных в секции HKEY_DYN_DATA.

unit SystemInfo;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs,extctrls;

type TDialupAdapterInfo = record //Информация о Dialup адаптере
  alignment:dword;
  buffer:dword;
  bytesrecieved:dword;
  bytesXmit:dword;
  ConnectSpeed:dword;
  CRC:dword;
  framesrecieved:dword;
  FramesXmit:dword;
  Framing:dword;
  runts:dword;
  Overrun:dword;
  timeout:dword;
  totalbytesrecieved:dword;
  totalbytesXmit:dword;
end;

type TKernelInfo = record
  CpuUsagePcnt:dword;
  Numthreads:dword;
  NumVMS:dword;
end;

type TVCACHEInfo = record
  ccurpages:dword;
  cMacPages:dword;
  cminpages:dword;
  FailedRecycles:dword;
  Hits:dword;
  LRUBuffers:dword;
  LRURecycles:dword;
  Misses:dword;
  RandomRecycles:dword;
end;

type TFATInfo = record
  BreadsSec:dword;
  BwritesSec:dword;
  Dirtydata:dword;
  ReadsSec:dword;
  WritesSec:dword;
end;

type TVMMInfo = record
  CDiscards:dword;
  CInstancefaults:dword;
  CPageFaults:dword;
  cPageIns:dword;
  cPageOuts:dword;
  cpgCommit:dword;
  cpgDiskCache:dword;
  cpgDiskCacheMac:dword;
  cpgDiskCacheMid:dword;
  cpgDiskCacheMin:dword;
  cpgfree:dword;

  cpglocked:dword;
  cpglockedNoncache:dword;
  cpgother:dword;
  cpgsharedpages:dword;
  cpgswap:dword;
  cpgswapfile:dword;
  cpgswapfiledefective:dword;
  cpgswapfileinuse:dword;
end;

type
  TSysInfo = class(TComponent)
  private
   fDialupAdapterInfo:TDialupAdapterInfo;
   fKernelInfo:TKernelInfo;
   fVCACHEInfo:TVCACHEInfo;
   fFATInfo:TFATInfo;
   fVMMInfo:TVMMInfo;
   ftimer:TTimer;
   fupdateinterval:integer;
   tmp:dword;
   vsize:dword;
   pkey:hkey;
   regtype:pdword;
   fstopped:boolean;
   procedure fupdatinginfo(sender:tobject);
   procedure fsetupdateinterval(aupdateinterval:integer);
  protected
   fsysInfoChanged:TNotifyEvent;
  public
   constructor Create(Aowner:Tcomponent);override;
   destructor  Destroy;override;

   property DialupAdapterInfo: TDialupAdapterInfo read fDialupAdapterInfo;
   property KernelInfo: TKernelInfo read fKernelInfo;
   property VCACHEInfo: TVCACHEInfo read fVCACHEInfo;
   property FATInfo: TFATInfo read fFATInfo;
   property VMMInfo: TVMMInfo read fVMMInfo;
   procedure StartRecievingInfo;
   procedure StopRecievingInfo;
  published
   property SysInfoChanged:TNotifyEvent read fsysInfoChanged write
    fsysInfoChanged;//Это событие вызывается после определённого интервала времени.
   property UpdateInterval:integer read fupdateInterval write
    fsetupdateinterval default 5000;
  end;

procedure Register;

implementation

constructor TSysInfo.Create(Aowner:Tcomponent);
begin
inherited;
ftimer:=ttimer.Create(self);
ftimer.enabled:=false;
ftimer.OnTimer:=fupdatinginfo;
vsize:=4;
fstopped:=true;
end;

procedure TSysInfo.startrecievingInfo;
var
res:integer;
begin
res:=RegOpenKeyEx(HKEY_DYN_DATA,'PerfStats\StartStat',0,KEY_ALL_ACCESS,pkey);
if res<>0 then
  raise exception.Create('Could not open registry key');
fstopped:=false;
// Для Dial Up Адаптера
RegQueryValueEx(pkey,'Dial-Up Adapter\Alignment',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\Buffer',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\Framing',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\Overrun ',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\Timeout',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\CRC',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\Runts',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\FramesXmit',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\FramesRecvd',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\BytesXmit',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\BytesRecvd',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\TotalBytesXmit',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\TotalBytesRecvd',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\ConnectSpeed',nil,regtype,@tmp,@vsize);

// Для VCACHE
RegQueryValueEx(pkey,'VCACHE\LRUBuffers',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VCACHE\FailedRecycles',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VCACHE\RandomRecycles',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VCACHE\LRURecycles',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VCACHE\Misses',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VCACHE\Hits',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VCACHE\cMacPages',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VCACHE\cMinPages',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VCACHE\cCurPages',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\BytesXmit',nil,regtype,@tmp,@vsize);

//Для VFAT

RegQueryValueEx(pkey,'VFAT\DirtyData',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VFAT\BReadsSec',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VFAT\BWritesSec',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VFAT\ReadsSec',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VFAT\WritesSec',nil,regtype,@tmp,@vsize);
//Для VMM

RegQueryValueEx(pkey,'VMM\cpgLockedNoncache',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VMM\cpgCommit',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VMM\cpgSharedPages',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VMM\cpgDiskcacheMid',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VMM\cpgDiskcacheMac',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VMM\cpgDiskcacheMin',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VMM\cpgDiskcache',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VMM\cpgSwapfileDefective',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VMM\cpgSwapfileInUse',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VMM\cpgSwapfile',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VMM\cDiscards',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VMM\cPageOuts',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VMM\cPageIns',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VMM\cInstanceFaults',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VMM\cPageFaults',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VMM\cpgOther',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VMM\cpgSwap',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VMM\cpgLocked',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'VMM\cpgFree',nil,regtype,@tmp,@vsize);
//Для KERNEL
RegQueryValueEx(pkey,'KERNEL\CPUUsage',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'KERNEL\VMs',nil,regtype,@tmp,@vsize);
RegQueryValueEx(pkey,'KERNEL\Threads',nil,regtype,@tmp,@vsize);
RegCloseKey(pkey);
ftimer.enabled:=true;
end;

procedure tsysinfo.fupdatinginfo(sender:tobject);
var
  res:integer;
begin
res:=RegOpenKeyEx(HKEY_DYN_DATA,'PerfStats\StatData',0,KEY_ALL_ACCESS,pkey);
if res<>0 then
  raise exception.Create('Could not open registry key');
//Для Dial Up Адаптера
RegQueryValueEx(pkey,'Dial-Up Adapter\Alignment',nil,regtype,@fDialupAdapterInfo.alignment,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\Buffer',nil,regtype,@fDialupAdapterInfo.buffer,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\Framing',nil,regtype,@fDialupAdapterInfo.framing,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\Overrun ',nil,regtype,@fDialupAdapterInfo.overrun,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\Timeout',nil,regtype,@fDialupAdapterInfo.timeout,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\CRC',nil,regtype,@fDialupAdapterInfo.crc,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\Runts',nil,regtype,@fDialupAdapterInfo.runts,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\FramesXmit',nil,regtype,@fDialupAdapterInfo.framesxmit,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\FramesRecvd',nil,regtype,@fDialupAdapterInfo.framesrecieved,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\BytesXmit',nil,regtype,@fDialupAdapterInfo.bytesxmit,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\BytesRecvd',nil,regtype,@fDialupAdapterInfo.bytesrecieved,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\TotalBytesXmit',nil,regtype,@fDialupAdapterInfo.totalbytesxmit,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\TotalBytesRecvd',nil,regtype,@fDialupAdapterInfo.totalbytesrecieved,@vsize);
RegQueryValueEx(pkey,'Dial-Up Adapter\ConnectSpeed',nil,regtype,@fDialupAdapterInfo.connectspeed,@vsize);
// Для VCACHE
RegQueryValueEx(pkey,'VCACHE\LRUBuffers',nil,regtype,@fVCACHEInfo.lrubuffers,@vsize);
RegQueryValueEx(pkey,'VCACHE\FailedRecycles',nil,regtype,@fVCACHEInfo.failedrecycles,@vsize);
RegQueryValueEx(pkey,'VCACHE\RandomRecycles',nil,regtype,@fVCACHEInfo.randomrecycles,@vsize);
RegQueryValueEx(pkey,'VCACHE\LRURecycles',nil,regtype,@fVCACHEInfo.lrurecycles,@vsize);
RegQueryValueEx(pkey,'VCACHE\Misses',nil,regtype,@fVCACHEInfo.misses,@vsize);
RegQueryValueEx(pkey,'VCACHE\Hits',nil,regtype,@fVCACHEInfo.hits,@vsize);
RegQueryValueEx(pkey,'VCACHE\cMacPages',nil,regtype,@fVCACHEInfo.cmacpages,@vsize);
RegQueryValueEx(pkey,'VCACHE\cMinPages',nil,regtype,@fVCACHEInfo.cminpages,@vsize);
RegQueryValueEx(pkey,'VCACHE\cCurPages',nil,regtype,@fVCACHEInfo.ccurpages,@vsize);
//Для VFAT
RegQueryValueEx(pkey,'VFAT\DirtyData',nil,regtype,@ffatinfo.dirtydata,@vsize);
RegQueryValueEx(pkey,'VFAT\BReadsSec',nil,regtype,@ffatinfo.breadssec,@vsize);
RegQueryValueEx(pkey,'VFAT\BWritesSec',nil,regtype,@ffatinfo.bwritessec,@vsize);
RegQueryValueEx(pkey,'VFAT\ReadsSec',nil,regtype,@ffatinfo.readssec,@vsize);
RegQueryValueEx(pkey,'VFAT\WritesSec',nil,regtype,@ffatinfo.writessec,@vsize);
//Для VMM
RegQueryValueEx(pkey,'VMM\cpgLockedNoncache',nil,regtype,@fvmminfo.cpglockednoncache,@vsize);
RegQueryValueEx(pkey,'VMM\cpgCommit',nil,regtype,@fvmminfo.cpgcommit,@vsize);
RegQueryValueEx(pkey,'VMM\cpgSharedPages',nil,regtype,@fvmminfo.cpgsharedpages,@vsize);
RegQueryValueEx(pkey,'VMM\cpgDiskcacheMid',nil,regtype,@fvmminfo.cpgdiskcacheMid,@vsize);
RegQueryValueEx(pkey,'VMM\cpgDiskcacheMac',nil,regtype,@fvmminfo.cpgdiskcacheMac,@vsize);
RegQueryValueEx(pkey,'VMM\cpgDiskcacheMin',nil,regtype,@fvmminfo.cpgdiskcacheMin,@vsize);
RegQueryValueEx(pkey,'VMM\cpgDiskcache',nil,regtype,@fvmminfo.cpgdiskcache,@vsize);
RegQueryValueEx(pkey,'VMM\cpgSwapfileDefective',nil,regtype,@fvmminfo.cpgswapfiledefective,@vsize);
RegQueryValueEx(pkey,'VMM\cpgSwapfileInUse',nil,regtype,@fvmminfo.cpgswapfileinuse,@vsize);
RegQueryValueEx(pkey,'VMM\cpgSwapfile',nil,regtype,@fvmminfo.cpgswapfile,@vsize);
RegQueryValueEx(pkey,'VMM\cDiscards',nil,regtype,@fvmminfo.cdiscards,@vsize);
RegQueryValueEx(pkey,'VMM\cPageOuts',nil,regtype,@fvmminfo.cpageouts,@vsize);
RegQueryValueEx(pkey,'VMM\cPageIns',nil,regtype,@fvmminfo.cpageins,@vsize);
RegQueryValueEx(pkey,'VMM\cInstanceFaults',nil,regtype,@fvmminfo.cinstancefaults,@vsize);
RegQueryValueEx(pkey,'VMM\cPageFaults',nil,regtype,@fvmminfo.cpagefaults,@vsize);
RegQueryValueEx(pkey,'VMM\cpgOther',nil,regtype,@fvmminfo.cpgother,@vsize);
RegQueryValueEx(pkey,'VMM\cpgSwap',nil,regtype,@fvmminfo.cpgswap,@vsize);
RegQueryValueEx(pkey,'VMM\cpgLocked',nil,regtype,@fvmminfo.cpglocked,@vsize);
RegQueryValueEx(pkey,'VMM\cpgFree',nil,regtype,@fvmminfo.cpgfree,@vsize);
//Для KERNEL
RegQueryValueEx(pkey,'KERNEL\CPUUsage',nil,regtype,@fkernelinfo.cpuusagepcnt,@vsize);
RegQueryValueEx(pkey,'KERNEL\VMs',nil,regtype,@fkernelinfo.numvms,@vsize);
RegQueryValueEx(pkey,'KERNEL\Threads',nil,regtype,@fkernelinfo.numThreads,@vsize);
RegCloseKey(pkey);
if assigned(SysInfoChanged) then
  SysInfoChanged(self);
end;

procedure TSysInfo.stoprecievingInfo;
var
res:integer;
begin
res:=RegOpenKeyEx(HKEY_DYN_DATA,'PerfStats\StopStat',0,KEY_ALL_ACCESS,pkey);
if not fstopped then
  begin
   if res<>0 then
    raise exception.Create('Could not open registry key');
   //Для Dial Up Адаптера
   RegQueryValueEx(pkey,'Dial-Up Adapter\Alignment',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\Buffer',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\Framing',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\Overrun ',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\Timeout',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\CRC',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\Runts',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\FramesXmit',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\FramesRecvd',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\BytesXmit',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\BytesRecvd',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\TotalBytesXmit',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\TotalBytesRecvd',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\ConnectSpeed',nil,regtype,@tmp,@vsize);

   // Для VCACHE
   RegQueryValueEx(pkey,'VCACHE\LRUBuffers',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VCACHE\FailedRecycles',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VCACHE\RandomRecycles',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VCACHE\LRURecycles',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VCACHE\Misses',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VCACHE\Hits',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VCACHE\cMacPages',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VCACHE\cMinPages',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VCACHE\cCurPages',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'Dial-Up Adapter\BytesXmit',nil,regtype,@tmp,@vsize);

   //Для VFAT
   RegQueryValueEx(pkey,'VFAT\DirtyData',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VFAT\BReadsSec',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VFAT\BWritesSec',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VFAT\ReadsSec',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VFAT\WritesSec',nil,regtype,@tmp,@vsize);

   //Для VMM
   RegQueryValueEx(pkey,'VMM\cpgLockedNoncache',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgCommit',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgSharedPages',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgDiskcacheMid',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgDiskcacheMac',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgDiskcacheMin',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgDiskcache',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgSwapfileDefective',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgSwapfileInUse',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgSwapfile',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cDiscards',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cPageOuts',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cPageIns',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cInstanceFaults',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cPageFaults',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgOther',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgSwap',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgLocked',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'VMM\cpgFree',nil,regtype,@tmp,@vsize);

   //Для KERNEL
   RegQueryValueEx(pkey,'KERNEL\CPUUsage',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'KERNEL\VMs',nil,regtype,@tmp,@vsize);
   RegQueryValueEx(pkey,'KERNEL\Threads',nil,regtype,@tmp,@vsize);

   RegCloseKey(pkey);
   ftimer.enabled:=false;
   fstopped:=true;
  end;
end;

procedure tsysinfo.fsetupdateinterval(aupdateinterval:integer);
begin
if (ftimer<>nil) and(aupdateinterval>0) then
  begin
    ftimer.Interval:=aupdateinterval;
    fupdateinterval:=aupdateinterval;
  end;
if (ftimer<>nil) and(aupdateinterval=0) then
begin
  ftimer.Interval:=500;
  fupdateinterval:=500;
end;

end;

destructor tsysinfo.Destroy;
begin
StopRecievingInfo;
ftimer.Destroy;
inherited;
end;

procedure Register;
begin
  RegisterComponents('Samples', [TSysInfo]);
end;

Коллекции и работа с ними

1. ТЕОРИЯ
1.1. Почему коллекции?

Действительно, а почему, собственно, коллекции? Ведь существует класс TList, это классический список, принципы построения и использования таких списков хорошо известны и подробно описаны в литературе, сам этот класс достаточно прост, но содержит все необходимое - так зачем же еще какие-то ухищрения?

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

Главное отличие класса TCollection от класса TList состоит в том, что он, во-первых, предназначен, в основном, для создания не обычных, а как бы <визуальных> списков и, во-вторых, Delphi содержит готовые средства, поддерживающие работу с коллекциями в design-time.

Что значит <визуальный> список? Это список, элементы которого должны каким-то образом отображаться на экране. Возьмем, например, шапку какой-либо таблицы. Ясно, что она содержит заголовки столбцов, причем каждый заголовок - это строка, которую видит пользователь. Это и есть <визуальный> список, а сами заголовки, очевидно, являются элементами этого списка.

А что значит <поддержка в design-time>? Это значит, что добавлять элементы к коллекции, удалять их и настраивать их свойства можно так же легко и просто, как мы это делаем, работая с компонентами. Для этого используется Object Inspector и еще один встроенный в Delphi редактор, который так и называется - Collection Editor. И еще, что очень важно, коллекции построены на основе класса TPersistent (в отличие от TList, являющегося прямым потомком TObject) - а это означает, что Delphi умеет запоминать в файле формы все настройки коллекции и ее элементов, которые мы делаем в design-time. Со списком TList без его модификации такое невозможно.

Вернемся к примеру с заголовками столбцов в шапке таблицы. Можно реализовать их список на основе класса TList? Безусловно, можно. Но работать с элементами такого списка нам придется только в run-time, что, согласитесь, не очень удобно (ведь потребуется <ручное> написание дополнительного кода, в котором, кстати, не исключены и ошибки). Если программист знает механизмы работы самой Delphi, то на основе класса TList он, конечно, может написать специальный объект-список, специальный редактор для него и получить поддержку списка в design-time. Но что делать другим программистам? Ответ - использовать уже существующие именно для подобных целей коллекции с их готовым редактором Collection Editor. И, конечно, не забыть сказать <спасибо> разработчикам Delphi, позаботившимся о нашем удобстве.

Только ли для построения <визуальных> списков предназначены коллекции? Естественно, нет, с их помощью можно создавать любые списки. Но именно при построении <визуальных> списков преимущества коллекций проявляются особенно отчетливо. Вы легко убедитесь в этом, поработав, например, с компонентом THeaderControl и его свойством Sections.

Посмотрев исходный текст модуля Classes, легко убедиться, что сами коллекции построены на основе все того же списка TList. Таким образом, можно сказать, что коллекции - это <списки специального назначения>.
Наверх

1.2. Основные особенности коллекций и их элементов

Любая коллекция - это объект (но не компонент), потомок класса TCollection. Она содержит элементы, причем каждый элемент - это тоже объект (но тоже не компонент), потомок класса TCollectionItem. Оба этих класса являются лишь базовыми, то есть имеют только ту функциональность, которая нужна для самой коллекции и ее взаимодействия с IDE. Чтобы получить что-то полезное в прикладном смысле, мы должны построить свой класс <элемент коллекции> и свой класс <коллекция>, введя в них нужные свойства и методы (а, если требуется, то и события). Это делается обычным образом, с использованием наследования и будет рассмотрено ниже. Сейчас, для того, чтобы лучше понять отличия коллекций от списков на основе класса TList, разберем их основные особенности. Именно основные и именно особенности, потому что все подробности, конечно, есть в справке Delphi и в ее исходных текстах (модуль Classes). Начнем с класса TCollectionItem.

Свойство Collection. Указывает на коллекцию, которой принадлежит данный элемент. Требуется для корректной работы коллекции с внутренним списком своих элементов. Автоматически назначается при создании элемента. Позволяет легко <перебросить> элемент из одной коллекции в другую, что при использовании списков на основе TList было бы все же посложнее.
Свойство DisplayName. Строка, представляющая элемент в Collection Editor. По умолчанию это всего лишь имя класса элемента, но может быть использовано и более полезным образом (например, для того же заголовка столбца таблицы). В последнем случае это свойство часто сопоставляется с каким-то другим, которое и появляется в Object Inspector под более смысловым именем (например, под именем Text в THeaderSection или TStatusPanel).
Свойство ID. Уникальный целочисленный идентификатор элемента внутри коллекции. Доступен только для чтения и автоматически назначается при вставке элемента в коллекцию. Может измениться только при <переброске> элемента в другую коллекцию (в отличие от свойства Index, которое может меняться при вставке, удалении или переупорядочивании элементов в пределах одной коллекции). Даже если элемент был удален из коллекции, его ID для новых элементов повторно не используется.
Свойство Index. Порядковый номер элемента в коллекции. Аналог индекса элемента в TList.
Метод GetNamePath. Используется в IDE для идентификации элемента коллекции. Возвращает строку, которая появляется в верхнем окошке Object Inspector, когда данный элемент выбирается в Collection Editor. Этот метод - часть поддержки работы в design-time, но вряд ли может быть полезен для прикладной программы.
Метод Changed. Этот protected-метод должен вызываться наследниками TCollectionItem каждый раз, когда меняются существенные свойства элемента и требуется уведомить об этом коллекцию. Приводит к вызову метода Update коллекции, что может быть использовано, например, для перерисовки, для обновления каких-то связей между элементами коллекции (если таковые существуют), да и вообще для любых других целей. При создании и уничтожении элемента метод Update коллекции вызывается автоматически.
Других свойств класс TCollectionItem не содержит, а его остальные методы, в общем, вполне стандартны (за исключением конструктора и деструктора, которые, конечно, выполняют свои обычные функции, но имеют несколько необычную реализацию, а также дополнительных методов для взаимодействия с IDE в design-time). События в этом классе не определены, но, если требуется, то никто не мешает нам определить любые события в потомках этого класса.

Теперь рассмотрим особенности класса TCollection.
Свойство Count. Количество элементов в коллекции. Аналог такого же свойства TList.
Свойство ItemClass. Дает фактический класс элементов коллекции. Этот класс задается при создании коллекции и в дальнейшем быть изменен не может. Все элементы коллекции имеют один и тот же класс (в этом смысле список на основе TList более гибок, так как не имеет подобного ограничения).
Свойство Items. Массив элементов коллекции. Аналог такого же свойства TList.
Методы Add, Clear и Insert. Аналоги соответствующих методов TList, но с одним важнейшим отличием. При добавлении (вставке) объекта в список TList или его удалении из списка сам объект не создается и, соответственно, не уничтожается. Те же операции с коллекцией приводят к автоматическому созданию и уничтожению экземпляра объекта. Конечно, это возможно именно потому, что в случае коллекции класс объекта известен заранее, а в случае TList объект может быть любым.
Метод Assign. Копирует элементы одной коллекции в другую. Конечно, если классы элементов этих коллекций не совпадают, возникнет ошибка. Кстати, такое копирование стало возможным как раз потому, что коллекции и их элементы построены на основе класса TPersistent, в то время как подобная операция со списками TList требует дополнительного кода.
Методы BeginUpdate и EndUpdate. Эти методы проще всего рассмотреть на примере перерисовки. Выше отмечалось, что коллекции предназначены, в основном, для создания <визуальных> списков. Если один из элементов коллекции обновляется, это приводит к его обновлению и на экране. Если же обновляются сразу несколько элементов, то нет смысла выполнять промежуточные перерисовки экрана, а надо выполнить только одну - после обновления всех элементов. Это и позволяют сделать два рассматриваемых метода. Важно знать, что перерисовка происходит только после того, как метод EndUpdate будет вызван ровно столько раз, сколько перед этим был вызван BeginUpdate. Чтобы гарантировать правильную работу, обычно эти вызовы используются совместно с блоком try:finally. Конечно, этот механизм может быть использован при любом обновлении элементов коллекции, а не только для их перерисовки.
Метод FindItemID. Дает элемент коллекции с заданным ID (либо Nil, если такового нет).
Метод GetNamePath. Используется для внутренних нужд IDE, как часть поддержки работы в design-time. Для прикладного программиста этот метод вряд ли представляет интерес.
Метод Changed. Этот protected-метод должен вызываться наследниками TCollection при изменении существенных свойств коллекции. Приводит к вызову метода Update, но не сразу, а после ее полного обновления (см. BeginUpdate и EndUpdate).
Метод Update. В классе TCollection этот protected-метод не делает ничего, но потомки могут заместить его для фактического обновления коллекции (например, для той же перерисовки).
В остальном класс TCollection - это, в общем-то, обычный объект (за исключением того, что имеет ряд дополнительных методов, обеспечивающих взаимодействие с IDE в design-time). Никакие события в этом классе не определены, но могут быть определены в его потомках.
Наверх

1.3. Владелец коллекции и класс TOwnedCollection

В большинстве случаев коллекции используются, как свойства компонентов (собственно, это и есть их основное назначение). Пусть, например, мы разрабатываем компонент, который должен содержать список некоторых объектов. Тогда сначала мы определяем класс <элемент коллекции>, затем класс самой коллекции и, наконец, вводим в наш компонент свойство, как объект этого класса. Это свойство и будет представлять искомый список объектов, причем мы сможем работать с ним в design-time, не предпринимая для этого никаких дополнительных усилий.

В рассмотренном случае наш компонент будет владельцем (owner) коллекции. Согласно общей идеологии Delphi и для обеспечения правильной работы IDE в классе самой коллекции следует заместить метод GetOwner, который любая коллекция наследует от класса TPersistent. Все, что этот метод должен делать - это возвращать ссылку на компонент-владелец и в Delphi определен еще один класс - TOwnedCollection, в котором такая функциональность уже реализована.

Вопрос - если мы создаем коллекцию, планируя использовать ее именно как свойство компонента, то должны ли мы в качестве ее предка выбирать только класс TOwnedCollection, или можно использовать общий класс TCollection?

Ответ - правильно и то, и другое, но во втором случае мы должны сами позаботиться о замещении метода GetOwner. Можно даже в раздел public (но только не в published) ввести read-only свойство Owner, также дающее ссылку на владельца (через тот же метод GetOwner). Тем самым, не затрачивая лишних ресурсов (свойства не требуют памяти) мы дополнительно усиливаем сходство создаваемой коллекции с компонентом - ведь все компоненты имеют свойство Owner.
Наверх

1.4. Резюме по теоретической части

Итак, коллекция - это объект, реализующий список других объектов. Его основное отличие от общего списка TList заключается в том, что, не будучи компонентом, он в design-time допускает работу с собой, как с компонентом. Для этого используются общий редактор всех компонентов Object Inspector и специальный редактор свойства Collection Editor. Такая особенность поддерживается как IDE, так и самой коллекцией, что налагает на ее реализацию ряд требований.
Наверх

2. ПРАКТИКА

Прикладным программистам, особенно мало знакомым с работой самой IDE все предыдущее вполне могло показаться слишком неинтересным или слишком сложным. Настало время показать, что это вовсе не так. Создадим учебный компонент - потомок TShape, содержащий коллекцию визуальных точек. Его практическая ценность довольно сомнительна, но для демонстрационных целей такой компонент неплох, поскольку он достаточно прост и поэтому <лес не будет слишком заслонен деревьями> (ведь наша основная цель - научиться работать с коллекциями).

Итак, запускаем Delphi, щелкаем по File | New, выбираем и нажимаем OK. В поле пишем слово , а в поле - слово и нажимаем . Переходим на вкладку , нажимаем и задаем путь к создаваемому пакету, а в качестве его имени указываем, например, . Далее на все вопросы отвечаем нажимом кнопок <Да> - и в итоге на странице Samples палитры получаем свежесозданный компонент DappledShape, который пока еще ничем не отличается от своего предка - стандартного Shape.

На экране будет окно, в котором отображается состав нового пакета HelloWorld. Не нужно его закрывать, оно еще понадобится - ведь после всех изменений пакет надо перекомпилировать (кнопка ). А мы перейдем в окно редактора с текстом модуля DappledShape и, наконец, займемся настоящим программированием. Практически весь код нам придется писать вручную, но что может быть интереснее, не правда ли?
Наверх

2.1. Создание элемента коллекции

Итак, элемент нашей коллекции будет представлять визуальную точку. Такая точка имеет две координаты центра и цвет. Конечно, можно ввести еще множество других параметров (размер, форма, вид кисти и т.д.), но мы не будем усложнять и ограничимся перечисленными тремя.

В разделе interface сразу после слова type пишем следующее объявление класса, который и будет представлять элемент нашей коллекции.

TSpot= class(TCollectionItem)
private
  FCenterX: integer;
  FCenterY: integer;
  FColor: TColor;
public
  constructor Create(Collection: TCollection); override;
published
  property CenterX: integer read FCenterX write SetCenterX default 3;
  property CenterY: integer read FCenterY write SetCenterY default 3;
  property Color: TColor read FColor write SetColor default clBlack;
end;

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

Теперь ставим курсор куда-то в середину этого объявления и нажимаем Ctrl+Shift+C. Умница Delphi добавляет еще три метода и создает скелет реализации. Остается только на языке Object Pascal объяснить, чего же мы, собственно, хотим. Итак, пишем реализацию.

constructor TSpot.Create(Collection: TCollection);
begin
// Создаем сам объект и инициализируем его поля
  inherited Create(Collection);
  FCenterX := 3;
  FCenterY := 3;
  FColor := clBlack
end;

procedure TSpot.SetCenterX(const Value: integer);
begin
// Если значение новое, запоминаем его и запрашиваем перерисовку
  if FCenterX <> Value then
    begin
      FCenterX := Value;
      Changed(False)
    end
end;

procedure TSpot.SetCenterY(const Value: integer);
begin
  if FCenterY <> Value then
    begin
      FCenterY := Value;
      Changed(False)
    end
end;

procedure TSpot.SetColor(const Value: TColor);
begin
  if FColor <> Value then
    begin
      FColor := Value;
      Changed(False)
    end
end;

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

Конструктор. Здесь его замещение нужно только для того, чтобы присвоить полям объекта начальные значения. Те же значения указаны в объявлениях свойств, но это не значит, что они будут присвоены автоматически. Наоборот, описатель default в объявлении свойства просто информирует IDE о том, какое значение это свойство получает по умолчанию. Если текущее значение свойства и его значение по умолчанию совпадают, то IDE не будет сохранять текущее значение в файле формы, что уменьшает размер программы.

Методы . Это так называемые методы доступа к свойствам (точнее, методы их записи), причем в данном случае все они практически одинаковы. После присваивания вызывается метод Changed, что информирует коллекцию об изменении элемента и, как мы увидим далее, приводит к перерисовке. Предварительная проверка равенства нового и текущего значений позволяет избежать ненужных действий, особенно, лишней перерисовки.

Если в программе написано, например, Color:=clRed, то вместо прямого присваивания компилятор сгенерит вызов метода записи SetColor(clRed) и, таким образом, перерисовка будет выполнена автоматически. Почти то же самое происходит и при установке свойства в design-time.
Наверх

2.2. Создание самой коллекции

Создание элемента коллекции полностью закончено. Возвращаемся в раздел interface и сразу же после объявления класса TSpot пишем две следующие строки.
TDappledShape = class;
TItemChangeEvent = procedure(Item: TCollectionItem) of object;

Первая строка - это так называемое опережающее объявление класса. При вставке коллекции в компонент этот прием является стандартным и позволяет использовать еще не объявленный класс самого компонента в объявлении класса коллекции (что, в свою очередь, дает возможность реализовать метод GetOwner).

Вторая строка определяет так называемый тип обработчика события. Наше событие будет означать, что произошло какое-то изменение элемента коллекции (параметр Item). Собственно говоря, введение такого события совсем не обязательно и сделано лишь с целью иллюстрации.

Теперь мы можем объявить класс самой коллекции.

TSpotCollection = class(TCollection)
private
  FDappledShape: TDappledShape;
  FOnItemChange : TItemChangeEvent;
protected
  function GetOwner: TPersistent; override;
  procedure Update(Item: TCollectionItem); override;
  procedure DoItemChange(Item: TCollectionItem); dynamic;
public
  constructor Create(DappledShape: TDappledShape);
  function Add: TSpot;
  property Items[Index: Integer]: TSpot read GetItem write SetItem; default;
published
  property OnItemChange: TItemChangeEvent read FOnItemChange write FOnItemChange;
end;

Если не учитывать добавленное нами событие (поле FOnItemChange, метод DoItemChange и свойство OnItemChange), то можно сказать, что такое объявление коллекции является практически стандартным. Описатель default для свойства Items здесь имеет иной смысл, чем ранее. Он означает, что само свойство Items является <свойством по умолчанию> - то есть, что, если в программе объявлена, например, переменная MySpotCollection: TSpotCollection, то синтаксические конструкции MySpotCollection[i] и MySpotCollection.Items[i] будут эквивалентны.

Теперь поступаем так же, как и прежде - ставим курсор куда-то внутрь этого объявления, нажимаем Ctrl+Shift+C, получаем скелет реализации и дописываем код. Обратите внимание, что и в этом случае Delphi добавляет в раздел private два метода доступа - GetItem (чтение) и SetItem (запись), которые мы ввели при объявлении свойства Items. Однако коллекции требуют, чтобы эти два метода были доступны классам-потомкам и поэтому они должны быть объявлены в разделе protected, куда нам и следует их перенести вручную. В итоге получим следующее.

function TSpotCollection.Add: TSpot;
begin
// Получаем общий TCollectionItem и приводим его к нашему TSpot
  Result := TSpot(inherited Add)
end;

constructor TSpotCollection.Create(DappledShape: TDappledShape);
begin
// Создаем коллекцию и запоминаем ссылку на ее владельца
  inherited Create(TSpot);
  FDappledShape := DappledShape
end;

procedure TSpotCollection.DoItemChange(Item: TCollectionItem);
begin
// Стандартный вызов пользовательского обработчика события
  if Assigned(FOnItemChange) then FOnItemChange(Item)
end;

function TSpotCollection.GetItem(Index: Integer): TSpot;
begin
// Получаем общий TCollectionItem и приводим его к нашему TSpot
  Result := TSpot(inherited GetItem(Index))
end;

function TSpotCollection.GetOwner: TPersistent;
begin
// Возвращаем ранее запомненную ссылку на владельца коллекции
  Result := FDappledShape
end;

procedure TSpotCollection.SetItem(Index: Integer; const Value: TSpot);
begin
// Просто используем унаследованный метод записи
  inherited SetItem(Index, Value)
end;

procedure TSpotCollection.Update(Item: TCollectionItem);
begin
// Вызов унаследованного метода здесь лишний, но это грамотный стиль. Он
// гарантирует верную работу даже при изменениях в новых версиях Delphi.
  inherited Update(Item);
// Даем запрос на перерисовку компонента-владельца
  FDappledShape.Invalidate;
// Возбуждаем событие - сигнал об изменении элемента
  DoItemChange(Item)
end;

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

Замещение метода Update позволяет обновить компонент-владелец при изменении любого элемента коллекции (а также при их добавлении к коллекции и удалении из нее). Использованный в данном примере способ обновления не является оптимальным (поскольку при изменении всего лишь одного элемента перерисовывается весь компонент) и выбран лишь из-за своей простоты.

В том же методе Update возбуждается введенное нами событие. При этом пользовательский обработчик вызывается не напрямую, а через так называемый метод диспетчеризации события - в данном случае, DoItemChange. Это стандартный подход. Он позволяет потомкам класса заместить метод диспетчеризации и, таким образом, встроить в цепочку обработки события свой код, не затрагивая никаких других аспектов. Но такая необходимость возникает все же достаточно редко и потому, с целью некоторой экономии памяти, методы диспетчеризации событий практически всегда объявляются, как динамические, а не виртуальные.

Итак, коллекция создана. Но для того, чтобы использовать ее по назначению, нужно сначала <вживить> ее в компонент.
Наверх

2.3. Внедрение коллекции в компонент

С самого начала Delphi создала нам скелет объявления класса TDappledShape и сейчас, наконец, настало время его оживить. Пишем следующее.

TDappledShape = class(TShape)
private
  FSpots: TSpotCollection;
protected
  procedure Paint; override;
public
  constructor Create(AOwner: TComponent); override;
  destructor Destroy; override;
published
  property Spots: TSpotCollection read FSpots write SetSpots;
end;

Что мы сделали? Во-первых, ввели в компонент коллекцию (поле FSpots и свойство Spots с методом записи SetSpots). Далее, поскольку коллекция - это объект, то ее надо сначала создать, а затем уничтожить, поэтому замещаем конструктор и деструктор. Наконец, для отрисовки элементов коллекции замещаем метод Paint. И, конечно, чтобы с коллекцией можно было работать в design-time, свойство Spots обязательно должно быть помещено в раздел published.

Далее, как обычно - курсор внутрь класса, Ctrl+Shift+C и пишем реализацию.

constructor TDappledShape.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FSpots := TSpotCollection.Create(Self)
end;

destructor TDappledShape.Destroy;
begin
  FSpots.Free;
  inherited Destroy
end;

procedure TDappledShape.Paint;
var
  SaveColor: TColor;
  SaveStyle: TBrushStyle;
  i: integer;
begin
  inherited Paint;
  SaveColor := Canvas.Brush.Color;
  SaveStyle := Canvas.Brush.Style;
  Canvas.Brush.Style := bsSolid;
  for i := 0 to FSpots.Count - 1 do
    with FSpots.Items[i] do
      begin
        Canvas.Brush.Color := Color;
        Canvas.Ellipse(CenterX - 3, CenterY - 3, CenterX + 3, CenterY + 3)
      end;
  Canvas.Brush.Style := SaveStyle;
  Canvas.Brush.Color := SaveColor
end;

procedure TDappledShape.SetSpots(const Value: TSpotCollection);
begin
  FSpots.Assign(Value)
end;

Весь этот код, в общем, очевиден и некоторых комментариев, пожалуй, требует только метод SetSpots. Тем более, что его код опять-таки стандартен для внедренного в компонент объектного свойства, в частности, для свойства-коллекции.

Что произойдет, если написать Object1:=Object2 ? Поскольку Object1 и Object2 - это, по сути, указатели, то после прямого копирования значения Object2 в Object1 оба указателя будут ссылаться на один и тот же объект. Если перед этим Object1 указывал на другой объект, то ссылка потеряется и объект <зависнет> в памяти - но никакого копирования <начинки> Object2 в Object1 не произойдет.

Чтобы скопировать не адрес объекта, а его <начинку> используется метод Assign. Но мы поместили его вызов внутрь метода записи - а это означает, что обычное присвоение нашей коллекции какого-либо значения скопирует именно элементы, а не адрес присваиваемой коллекции (в самом деле, ведь вместо присвоения компилятор сгенерит вызов метода SetSpots).

Вот и все! Теперь осталось только сохранить готовый модуль, вспомнить, что где-то в недрах экрана висит окно пакета HelloWorld, найти его и нажать кнопку Compile. После этого можем с удовольствием пользоваться собственным компонентом с собственной коллекцией.

ПОСЛЕСЛОВИЕ

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

А мне остается попрощаться и пожелать Вам, читатель, хорошего коллекционирования!
Наверх

Юрий Зотов,
03 мая 2000
Специально для <Королевства Delphi>.

Оригинал статьи расположен по адресу

Приложение:

Полный текст модуля

// Пример разработки и использования коллекции.
// Юрий Зотов (yurzosoft@mtu-net.ru?subject=Collections).
// 29 апреля 2000 года.
// Специально для сайта "Королевство Delphi" (http://delphi.vitpc.com).

unit DappledShape;

interface

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

type
  TSpot = class(TCollectionItem)
  private
    FCenterX: integer;
    FCenterY: integer;
    FColor: TColor;
    procedure SetCenterX(const Value: integer);
    procedure SetCenterY(const Value: integer);
    procedure SetColor(const Value: TColor);
  public
    constructor Create(Collection: TCollection); override;
  published
    property CenterX: integer read FCenterX write SetCenterX default 3;
    property CenterY: integer read FCenterY write SetCenterY default 3;
    property Color: TColor read FColor write SetColor default clBlack;
  end;

  TDappledShape = class;
  TItemChangeEvent = procedure(Item: TCollectionItem) of object;

  TSpotCollection = class(TCollection)
  private
    FDappledShape: TDappledShape;
    FOnItemChange : TItemChangeEvent;
    function GetItem(Index: Integer): TSpot;
    procedure SetItem(Index: Integer; const Value: TSpot);
  protected
    function GetOwner: TPersistent; override;
    procedure Update(Item: TCollectionItem); override;
    procedure DoItemChange(Item: TCollectionItem); dynamic;
  public
    constructor Create(DappledShape: TDappledShape);
    function Add: TSpot;
    property Items[Index: Integer]: TSpot read GetItem write SetItem; default;
  published
    property OnItemChange: TItemChangeEvent
      read FOnItemChange write FOnItemChange;
  end;

  TDappledShape = class(TShape)
  private
    FSpots: TSpotCollection;
    procedure SetSpots(const Value: TSpotCollection);
  protected
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Spots: TSpotCollection read FSpots write SetSpots;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Samples', [TDappledShape]);
end;

{ TSpot }

constructor TSpot.Create(Collection: TCollection);
begin
  inherited Create(Collection);
  FCenterX := 3;
  FCenterY := 3;
  FColor := clBlack
end;

procedure TSpot.SetCenterX(const Value: integer);
begin
  if FCenterX <> Value
     then begin
            FCenterX := Value;
            Changed(False)
          end
end;

procedure TSpot.SetCenterY(const Value: integer);
begin
  if FCenterY <> Value
     then begin
            FCenterY := Value;
            Changed(False)
          end
end;

procedure TSpot.SetColor(const Value: TColor);
begin
  if FColor <> Value
     then begin
            FColor := Value;
            Changed(False)
          end
end;

{ TSpotCollection }

function TSpotCollection.Add: TSpot;
begin
  Result := TSpot(inherited Add)
end;

constructor TSpotCollection.Create(DappledShape: TDappledShape);
begin
  inherited Create(TSpot);
  FDappledShape := DappledShape
end;

procedure TSpotCollection.DoItemChange(Item: TCollectionItem);
begin
  if Assigned(FOnItemChange) then FOnItemChange(Item)
end;

function TSpotCollection.GetItem(Index: Integer): TSpot;
begin
  Result := TSpot(inherited GetItem(Index))
end;

function TSpotCollection.GetOwner: TPersistent;
begin
  Result := FDappledShape
end;

procedure TSpotCollection.SetItem(Index: Integer; const Value: TSpot);
begin
  inherited SetItem(Index, Value)
end;

procedure TSpotCollection.Update(Item: TCollectionItem);
begin
  inherited Update(Item);
  FDappledShape.Invalidate;
  DoItemChange(Item)
end;

{ TDappledShape }

constructor TDappledShape.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FSpots := TSpotCollection.Create(Self)
end;

destructor TDappledShape.Destroy;
begin
  FSpots.Free;
  inherited Destroy
end;

procedure TDappledShape.Paint;
var
  SaveColor: TColor;
  SaveStyle: TBrushStyle;
  i: integer;
begin
  inherited Paint;
  SaveColor := Canvas.Brush.Color;
  SaveStyle := Canvas.Brush.Style;
  Canvas.Brush.Style := bsSolid;
  for i := 0 to FSpots.Count - 1 do
    with FSpots.Items[i] do
      begin
        Canvas.Brush.Color := Color;
        Canvas.Ellipse(CenterX - 3, CenterY - 3, CenterX + 3, CenterY + 3)
      end;
  Canvas.Brush.Style := SaveStyle;
  Canvas.Brush.Color := SaveColor
end;

procedure TDappledShape.SetSpots(const Value: TSpotCollection);
begin
  FSpots.Assign(Value)
end;

end.

Взято из

Команды Windows

Cодержание раздела:

Компиляция ресурсов

Автор: Ralph Friedman

У меня имеется приблизительно 36 маленьких растровых изображений, которые я хочу сохранить в файле и затем прилинковать его к exe. Как мне поместить их в res-файл?

Самый простой путь - создать файл с именем "BITMAPS.RC" и поместить в него список ваших .BMP-файлов:

BMAP1BITMAP BMAP1.BMP
BMAP2 BITMAP BMAP2.BMP
CLOCK BITMAP CLOCK.BMP
DBLCK BITMAP DBLCK.BMP
DELOK BITMAP DELOK.BMP
LUPE BITMAP LUPE.BMP
OK BITMAP OK.BMP
TIMEEDIT BITMAP TIMEEDIT.BMP

Затем загрузите Resource Workshop (RW) и выберите пункт меню File|Project Open. В выпадающем списке "File Type" (тип файла) выберите RC-Resource Script и откройте файл, который вы только что создали. После того, как RW загрузит ваш файл, выберите пункт меню File|Project save as. Выберите объект RES-Resource из выпадающего списка "File Type" (тип файла). В поле редактирования "New File name" задайте имя нового файла, скажем, BITMAPS.RES. Нажмите OK. Теперь у вас есть файл ресурса. В вашем модуле Delphi добавьте после строки {$R *.RES} строку {$R BITMAPS.RES}. После компиляции вы получите exe-файл с скомпилированными ресурсами. Для получения доступа к ресурсам во время выполнения программы нужно сделать следующее:

myImage.Picture.Bitmap.Handle := LoadBitmap(HInstance, 'TIMEEDIT');

В качестве предостережения: убедитесь в том, что имена (в самой левой колонке) изображений в .RC файле написаны в верхнем регистре, при вызове также необходимо писать их имена в верхнем регистре.