Статьи по Delphi (015)…

Дублирование компонентов и их потомков во время выполнения приложения 2.

interface
uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, Grids, DBGrids, DB, DBTables, Outline;
function Replicator(C: TComponent): TComponent;
implementation
{ Следующая процедура "клонирует" свойства C1 и записывает их в C2.
C1 и C2 должны иметь один и тот же тип. Используйте данный метод для
компонентов, не имеющих метода Assign. }
procedure CloneComponent(C1: TComponent; C2: TComponent);
var
  S: TMemoryStream;
begin
  if C1.ClassType <> C2.ClassType then
    raise EComponentError.Create('Типы объектов не совместимы');
  if C1 is TWinControl then
    TWinControl(C2).Parent := TWinControl(C1).Parent;
  S := TMemoryStream.Create; { создаем поток для работы с памятью }
  with S do
  begin
    WriteComponent(C1); { пишем свойства C1 в поток }
    Seek(0, 0); { перемещаемся в начало потока }
    ReadComponent(C2); { читаем свойства из потока в C2 }
    Free; { освобождаем поток }
  end;
end;
{ Следующая функция "реплицирует" компонент C и возвращает новый
компонент типа и со свойствами компонента C. }
function Replicator(C: TComponent): TComponent;
begin
  Result := TComponentClass(C.ClassType).Create(C.Owner); { создаем компонент }
  CloneComponent(C, Result); { клонируем его }
end;
end.

Вот как это использовать:

var
  BitBtn: TBitBtn;
begin
  { Если BitBtn1 уже существует }
  TComponent(BitBtn) := Replicator(BitBtn1);
end;

Как создать базу данных Access во время выполнения.

procedure CreateMSAccessDB(filename : String);
var
  DBEngine, Workspace: Variant;
const
  {Important to use the following constant as is}
  dbLangGeneral = ';LANGID=0x0409;CP=1252;COUNTRY=0';
  dbVersion30 = 32;
begin
  DBEngine := CreateOleObject('DAO.DBEngine');
  {DBEngine := CreateOleObject('DAO.DBEngine.35'); For DAO 3.5}
  Workspace := DBEngine.Workspaces[0];
  try
    Workspace.CreateDatabase(filename, dbLangGeneral, dbVersion30);
  except on EOleException do
    ShowMessage('Database already exists');
  end;
end;

Создание события во время выполнения приложения.

На примере переопределения события в Memo:

memo.onchange:=memo1Change;
procedure TForm1.Memo1Change(Sender: TObject);
begin
  panel1.caption:='Содержимое было изменено';
end;

Ошибки времени выполнения.

type
str31  = string[31];
function ErrMeaning (ResultCode: Integer): str31;
{----------------------------------------------------------}
{ Возвращает строковое значение по коду ошибки.            }
{----------------------------------------------------------}
const
NumOfEntries = 108;
type
ErrorEntry = record
Code: Integer;
Meaning: str31;
end;
ErrorMeaningsArray = array [1..NumOfEntries] of ErrorEntry;
const
MeaningsArray: ErrorMeaningsArray =
{Ошибки DOS}
((Code:   1;  Meaning: 'Неверный номер DOS-функции' {Invalid DOS function number}),
(Code:   2;  Meaning: 'Файл не найден' {File not found}),
(Code:   3;  Meaning: 'Путь не найден' {Path not found}),
(Code:   4;  Meaning: 'Слишком много открытых файлов' {Too many open files}),
(Code:   5;  Meaning: 'В доступе к файлу отказано' {File access denied}),
(Code:   6;  Meaning: 'Неверный дескриптор файла' {Invalid file handle}),
(Code:   7;  Meaning: 'Разрушены управляющие блоки памяти' {Memory control blocks destroyed}),
(Code:   8;  Meaning: 'Недостаточно памяти DOS' {Insufficient DOS memory}),
(Code:   9;  Meaning: 'Неверный адрес блока памяти' {Invalid memory block address}),
(Code:  10;  Meaning: 'Неверное окружение DOS' {Invalid DOS environment}),
(Code:  11;  Meaning: 'Неверный формат (DOS)' {Invalid format (DOS)}),
(Code:  12;  Meaning: 'Неверный код доступа к файлу' {Invalid file access code}),
(Code:  13;  Meaning: 'Неверные данные (DOS)' {Invalid data (DOS)}),
(Code:  15;  Meaning: 'Неверный номер устройства' {Invalid drive number}),
(Code:  16;  Meaning: 'Невозможно удалить текущую директорию' {Cannot remove current directory}),
(Code:  17;  Meaning: 'Невозможно переименовать драйвер' {Cannot rename across drives}),
(Code:  18;  Meaning: 'Файлов больше нет' {No more files}),
(Code:  19;  Meaning: 'Диск защищен от записи' {Disk write-protected}),
(Code:  20;  Meaning: 'Неизвестное устройство (DOS)' {Unknown unit (DOS)}),
(Code:  21;  Meaning: 'Устройство не готово' {Drive not ready}),
(Code:  22;  Meaning: 'Неизвестная команда DOS' {Unknown DOS command}),
(Code:  23;  Meaning: 'CRC-ошибка' {CRC error}),
(Code:  24;  Meaning: 'Плохой запрос длины структуры' {Bad request structure length}),
(Code:  25;  Meaning: 'Ошибка поиска' {Seek error}),
(Code:  26;  Meaning: 'Неизвестный тип носителя' {Unknown media type}),
(Code:  27;  Meaning: 'Сектор диска не найден' {Disk sector not found}),
(Code:  28;  Meaning: 'Недостаточно бумаги' {Out of paper}),
(Code:  29;  Meaning: 'Ошибка записи' {Write fault}),
(Code:  30;  Meaning: 'Ошибка чтения' {Read fault}),
(Code:  31;  Meaning: 'Общий сбой' {General failure}),
(Code:  32;  Meaning: 'Нарушение общего доступа к файлу' {File sharing violation}),
(Code:  33;  Meaning: 'Нарушение блокировки файла' {File lock violation}),
(Code:  34;  Meaning: 'Неверная смена диска' {Invalid disk change}),
(Code:  35;  Meaning: 'Управляющий блок файла недоступен' {File control block unavailable}),
(Code:  36;  Meaning: 'Переполнение разделяемого буфера' {Sharing buffer overflow}),
(Code:  37;  Meaning: 'Несовпадение кодовой страницы' {Code page mismatch}),
(Code:  38;  Meaning: 'Ошибка обработки EOF' {Error handling EOF}),
(Code:  39;  Meaning: 'Дескриптор диска полон' {Handle disk full}),
(Code:  50;  Meaning: 'Сетевой запрос не поддерживается' {Network request not supported}),
(Code:  51;  Meaning: 'Удаленный компьютер недоступен' {Remote computer not listening}),
(Code:  52;  Meaning: 'Дубликат имени в сети' {Duplicate name on network}),
(Code:  53;  Meaning: 'Сетевое имя не найдено' {Network name not found}),
(Code:  54;  Meaning: 'Сеть занята' {Network busy}),
(Code:  55;  Meaning: 'Сетевое устройство больше не существует' {Network device no longer exists}),
(Code:  56;  Meaning: 'Превышен лимит команды NetBIOS' {NetBIOS command limit exceeded}),
(Code:  57;  Meaning: 'Ошибка сетевого адаптера' {Network adaptor error}),
(Code:  58;  Meaning: 'Неверный сетевой ответ' {Incorrect network response}),
(Code:  59;  Meaning: 'Неожиданная ошибка сети' {Unexpected network error}),
(Code:  60;  Meaning: 'Несовместимый удаленный адаптер' {Incompatible remote adaptor}),
(Code:  61;  Meaning: 'Очередь на печать переполнена' {Print queue full}),
(Code:  62;  Meaning: 'Нет достаточного места для файла печати' {Not enough space for print file}),
(Code:  63;  Meaning: 'Файл печати удален' {Print file deleted}),
(Code:  64;  Meaning: 'Сетевое имя удалено' {Network name deleted}),
(Code:  65;  Meaning: 'Доступ запрещен' {Access denied}),
(Code:  66;  Meaning: 'Неверный тип сетевого устройства' {Network device type incorrect}),
(Code:  67;  Meaning: 'Сетевое имя не найдено' {Network name not found}),
(Code:  68;  Meaning: 'Превышен предел сетевого имени' {Network name limit exceeded}),
(Code:  69;  Meaning: 'Превышен предел сеансов NetBIOS' {NetBIOS session limit exceeded}),
(Code:  70;  Meaning: 'Временная пауза' {Temporarily paused}),
(Code:  71;  Meaning: 'Сетевой запрос не принят' {Network request not accepted}),
(Code:  72;  Meaning: 'Пауза переадресации печати/диска' {Print/disk redirection paused}),
(Code:  80;  Meaning: 'Файл уже существует' {File already exists}),
(Code:  82;  Meaning: 'Невозможно создать каталог' {Cannot make directory entry}),
(Code:  83;  Meaning: 'Ошибка прерывания 24' {Fail on interrupt 24}),
(Code:  84;  Meaning: 'Слишком много переадресаций' {Too many redirections}),
(Code:  85;  Meaning: 'Дубликат переадресации' {Duplicate redirection}),
(Code:  86;  Meaning: 'Неверный пароль' {Invalid password}),
(Code:  87;  Meaning: 'Неверный параметр' {Invalid parameter}),
(Code:  88;  Meaning: 'Ошибка данных сети' {Network data fault}),
{Ошибки ввода/вывода (I/O errors)}
(Code: 100;  Meaning: 'Ошибка чтения диска' {Disk read error}),
(Code: 101;  Meaning: 'Ошибка записи диска' {Disk write error}),
(Code: 102;  Meaning: 'Файл не назначен' {File not assigned}),
(Code: 103;  Meaning: 'Файл не открыт' {File not open}),
(Code: 104;  Meaning: 'Не открыт файл для приема' {File not open for input}),
(Code: 105;  Meaning: 'Не открыт файл для выдачи' {File not open for output}),
(Code: 106;  Meaning: 'Неверный числовой формат' {Invalid numeric format}),
{Критические ошибки (Только для реального или защищенного режима)}
(Code: 150;  Meaning: 'Диск защищен от записи' {Disk is write protected}),
(Code: 151;  Meaning: 'Неизвестное устройство' {Unknown unit}),
(Code: 152;  Meaning: 'Устройство не готово' {Drive not ready}),
(Code: 153;  Meaning: 'Неизвестная команда DOS' {Unknown DOS command}),
(Code: 154;  Meaning: 'Ошибка CRC в данных' {CRC error in data}),
(Code: 155;  Meaning: 'Плохой запрос длины структуры устройства' {Bad drive request struct length}),
(Code: 156;  Meaning: 'Ошибка позиционирования диска' {Disk seek error}),
(Code: 157;  Meaning: 'Неизвестный тип носителя' {Unknown media type}),
(Code: 158;  Meaning: 'Сектор не найден' {Sector not found}),
(Code: 159;  Meaning: 'Недостаточно бумаги в принтере' {Printer out of paper}),
(Code: 160;  Meaning: 'Ошибка записи устройства' {Device write fault}),
(Code: 161;  Meaning: 'Ошибка чтения устройства' {Device read fault}),
(Code: 162;  Meaning: 'Аппаратный сбой' {Hardware failure}),
{Фатальные ошибки}
(Code: 200;  Meaning: 'Деление на ноль' {Division by zero}),
(Code: 201;  Meaning: 'Ошибка проверки диапазона' {Range check error}),
(Code: 202;  Meaning: 'Ошибка переполнения стека' {Stack overflow error}),
(Code: 203;  Meaning: 'Ошибка переполнения кучи' {Heap overflow error}),
(Code: 204;  Meaning: 'Неверная операция с указателем' {Invalid pointer operation}),
(Code: 205;  Meaning: 'Переполнение числа с плавающей точкой' {Floating point overflow}),
(Code: 206;  Meaning: 'Потеря значимости числа с плавающей точкой' {Floating point underflow}),
(Code: 207;  Meaning: 'Неверная операция с числом с плавающей точкой' {Invalid floating pt. operation}),
(Code: 208;  Meaning: 'Не установлен оверлей-менеджер' {Overlay manager not installed}),
(Code: 209;  Meaning: 'Ошибка чтения оверлей-файла' {Overlay file read error}),
(Code: 210;  Meaning: 'Объект не инициализирован' {Object not initialised}),
(Code: 211;  Meaning: 'Вызов абстрактного метода' {Call to abstract method}),
(Code: 212;  Meaning: 'Ошибка регистрации потока' {Stream registration error}),
(Code: 213;  Meaning: 'Индекс TCollection вышел за границы диапазона' {TCollection index out of range}),
(Code: 214;  Meaning: 'Ошибка переполнения TCollection' {TCollection overflow error}),
(Code: 215;  Meaning: 'Ошибка арифметического переполнения' {Arithmetic overflow error}),
(Code: 216;  Meaning: 'Общая ошибка защиты' {General Protection Fault}),
(Code: 217;  Meaning: 'Необработанное исключение' {Unhandled exception}),
(Code: 219;  Meaning: 'Неверное приведение типа' {Invalid typecast}));
var
Low, High, Mid, Diff: Integer;
begin
Low := 1;
High := NumOfEntries;
while Low <= High do
begin
Mid := (Low + High) div 2;
Diff := MeaningsArray[Mid].Code - ResultCode;
if Diff < 0 then Low  := Mid + 1 else
if Diff > 0 then High := Mid - 1 else
begin {нашли это}
ErrMeaning := MeaningsArray[Mid].Meaning;
Exit; {ErrMeaning}
end;
end; {while}
ErrMeaning := 'Ошибка ' + IntToStr(ResultCode) +
' (неизвестное значение)';
end; {ErrMeaning}

Ещё...

  var
    i: Integer;
  begin
    for i := 1 to NumOfEntries do
      if MeaningsArray[i].Code < ResultCode then
        Continue {до следующей итерации цикла FOR loop}
      else
      begin
        if MeaningsArray[i].Code = ResultCode then
        begin
          ErrMeaning := MeaningsArray[i].Meaning;
          Exit; {ErrMeaning}
        end
        else {Code in array > ResultCode}
          Break; {выход из цикла FOR}
      end;
    ErrMeaning := 'Ошибка ' + IntToStr(ResultCode) +
                  ' (неизвестное значение)';
  end; {ErrMeaning}

Функции редактора полей во время выполнения программы.

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

procedure SetupFieldsAndOpenDataset(DataSet: TDataSet);
var
  FieldNum, DefNum: Integer;
begin
  with DataSet do
  begin
    if Active then
      Close;
    FieldDefs.Update; {набор данных должен быть закрыт}
    {ищем каждое предопределенное TField в DataSet.FieldDefs:}
    for FieldNum := FieldCount - 1 downto 0 do
      with Fields[FieldNum] do
      begin
        DefNum := FieldDefs.IndexOf(FieldName);
        if DefNum < 0 then
          raise Exception.CreateFmt(
            'Поле "%s" не найдено в наборе данных "%s"',
            [FieldName, Dataset.Name]);
        {устанавливаем свойство size:}
        Size := FieldDefs[DefNum].Size;
      end;
    Open;
  end;
end;

RTTI в действии.

Бывает, что надо всем контролам на форме поменять OnMouseMove Event. Или же нужно сбросить свойство Hint у всех элементов, у которых это свойство есть. Контролы могут быть самые разные TEdit, TLabel, TListView и т.п. Такаие возможности в Delphi есть, более того, на них построена вся среда визуальной разработки IDE Delphi.

Для справки:

Run-time type information (RTTI) - это специальный механизм определения типа объекта во время выполнения. Чаще всего это актуально для определения типа объекта по указателю. Многие каркасные библиотеки самостоятельно поддерживают этот мехзанизм. В том числе и VCL.

Приведем пример использования данного механизма в Delphi. Для начала рассмотрим работу с методами, а затем - со свойствами.

Следующий пример устанавливает у всех компонентов на форме обработчик OnMouseMove на собственную процедуру.

unit Unit1;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls;
type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
    //...эта ф-ия обязательно должна быть описана здесь, а не в одном из
    // следующих разделов, иначе MethodAddress() ее не видит.
    procedure CommonMouseMove (Sender: TObject;
    Shift: TShiftState; X, Y: Integer);
  private
  public
    procedure SetEventMethodToAllComponentsInForm( FormX: TForm );
end;
var
  Form1: TForm1;
implementation
{$R *.DFM}
uses
  TypInfo;
procedure TForm1.SetEventMethodToAllComponentsInForm( FormX: TForm );
var
  PropInfo: PPropInfo;
  i: integer;
  CommonMethod: TMethod;
begin
  for i:=0 to FormX.ComponentCount-1 do
  begin
    PropInfo := GetPropInfo( FormX.Components[i].ClassInfo, 'OnMouseMove');
    if PropInfo <> nil then
    begin
      CommonMethod.Data := FormX.Components[i];
      CommonMethod.Code := Form1.MethodAddress('CommonMouseMove');
      SetMethodProp( FormX.Components[i], PropInfo, CommonMethod );
    end;
  end;
end;
procedure TForm1.CommonMouseMove (Sender: TObject;
Shift: TShiftState; X,Y: Integer);
begin
  ShowMessage('Delphi World is COOL!');
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
  //...передадим для пробы ссылку на эту же форму
  SetEventMethodToAllComponentsInForm( self );
end;

Это что касается методов. Свойства тоже не обделены такими возможностями. Для из изменения нужно использовать процедуру procedure SetOrdProp(Instance: TObject; PropInfo: PPropInfo; Value: Longint);

// procedure SetOrdProp(Instance: TObject;
// PropInfo: PPropInfo; Value: Longint);
// Например следующий код устанавливает
// свойство Color у всех компонентов формы,
// которые этим свойством располагают:
for i:=0 to FormX.ComponentCount-1 do
begin
  PropInfo := GetPropInfo( FormX.Components[i].ClassInfo, 'Color');
  if PropInfo <> nil then
    SetOrdProp( FormX.Components[i], PropInfo, clGreen );
end;

Обратите внимание, что используемые здесть процедуры для работы с RTTI определены в стандартном модуле TypInfo.

Жизнь и смерть в режиме run-time.

Оформил: DeeCo

Автор: Елена Филиппова

Лирическое вступление.

Итак, зачетной сессии посвящается...

Пояснения к проекту:

var
  New: TButton;
begin
  // Создаем НОВЫЙ экземпляр класса TButton
  // и кладем ссылку на него в переменную New
  New := TButton.Create(PanelTest);
  // Координаты левого верхнего угла новой кнопки на панели
  New.Top := ...;
  New.Left := ...;
  New.Name := 'Button';
  // А вот эта процедура  будет вызываться
  // при нажатии на новенькую кнопку
  // то есть - обработка событи OnClick
  New.OnClick := OnClickButton;
  // Оп! И делаем кнопку видимой на PanelTest
  New.Parent := PanelTest;
end;

New := TButton.Create(PanelTest);

TButton.Create(AOwner: TObject);

property Controls[Index: Integer]: TControl;

property OnClick: TNotifyEvent;

type
  TMyProcedure = procedure(I: Integer);

var
  MyProcedure: TMyProcedure;
procedure X(I: Integer);
begin
  ...
end;
...
  MyProcedure := X;

type
  TNotifyEvent = procedure(Sender: TObject) of object;

procedure TForm1.OnClickButton(Sender: TObject);
var
  Value: string;
begin
  MessageDlg('Нажата кнопка ' + TControl(Sender).Name, mtInformation, [mbOk],
    0);
end;

New.OnClick := OnClickButton;

Теперь наша кнопка прям как настоящая!

Ссылка на класс.

type
  TClass = class of TObject;

type
  TControlClass = class of TControl;

type
  TListClass = array[0..3] of TControlClass;
const
  ListClass: TListClass = (TEdit, TButton, TCheckBox, TLabel);

procedure TForm1.PanelTestDblClick(Sender: TObject);
const
  No: integer = 0;
var
  TypeClass: TControlClass;
  New: TControl;
  Point: TPoint;
begin
  if (rgComponents.ItemIndex >= 0) and
    (rgComponents.ItemIndex < rgComponents.Items.Count) then
  begin
    // Получаем ссылку на выбранный класс
    TypeClass := TControlClass(ListClass[rgComponents.ItemIndex]);
    Inc(No); // увеличиваем счетчик компонент
    // Создаем компонент - вызываем конструктор выбранного класса
    New := TypeClass.Create(PanelTest);
    Point := PanelTest.ScreenToClient(Mouse.CursorPos);
    New.Top := Point.y;
    New.Left := Point.x;
    // Имя = название класса + номер нового компонента
    New.Name := New.ClassName + IntToStr(No);
    New.Tag := 1;
    // Навешиваем меню по правой кнопке
    TEdit(New).PopupMenu := pmComponent;
    // Если это кнопка - назначим обработчик
    if TypeClass = TButton then
      TButton(New).OnClick := OnClickButton;
    // И помещаем новенького на панель
    New.Parent := PanelTest;
  end;
end;

Комментарий:

Point := PanelTest.ScreenToClient(Mouse.CursorPos);

TEdit(New).PopupMenu := pmComponent;

Tag = 1
Tag = 2
------
//Удалить компонент

procedure TForm1.AllColorClick(Sender: TObject);
var
  i: Integer;
begin
  if TControl(Sender).Tag = 0 then
    for i := 0 to PanelTest.ControlCount - 1 do
      TEdit(PanelTest.Controls[i]).Font.Color := ColorGrid.ForegroundColor
  else
    for i := 0 to PanelTest.ControlCount - 1 do
      if TWinControl(PanelTest.Controls[i]).Tag = TControl(Sender).Tag then
        TEdit(PanelTest.Controls[i]).Font.Color := ColorGrid.ForegroundColor
end;

for i := 0 to PanelTest.ControlCount - 1 do
begin
  if (PanelTest.Controls[i] is TEdit) then
    TEdit(PanelTest.Controls[i]).Text := ''
end;

pmComponent.PopUpComponent.Free;

На рисунке показан момент работы проекта:

procedure TForm1.miCheckBoxClick(Sender: TObject);
var
  Item: TMenuItem;
  i: Integer;
begin
  // очищаем  список
  for i := TMenuItem(Sender).Count - 1 downto 2 do
    TMenuItem(Sender).Delete(i);
  // Формируем свежий вариант меню по текущему списку СhескВох'ов
  for i := 0 to PanelTest.ControlCount - 1 do
    if (PanelTest.Controls[i] is TCheckBox) then
    begin
      Item := NewItem(TCheckBox(PanelTest.Controls[i]).Caption, 0, False, True,
        miCheckedClick, 0, '');
      TMenuItem(Sender).Add(Item);
      Item.Tag := LongInt(PanelTest.Controls[i]);
    end;
end;

Item.Tag := LongInt(PanelTest.Controls[i]);

procedure TForm1.miCheckedClick(Sender: TObject);
var
  i: Integer;
begin
  //Функция Ptr конвертирует 4 байта в тип Pointer.
  //function Ptr(Address: Integer): Pointer
  if TMenuItem(Sender).Tag = 0 then
  begin
    for i := 0 to PanelTest.ControlCount - 1 do
      if PanelTest.Controls[i] is TCheckBox then
        TCheckBox(PanelTest.Controls[i]).Checked := True
  end
  else
    TCheckBox(Ptr(TMenuItem(Sender).Tag)).Checked := True;
end;

var
  TagPtr: Ponter;
  ...
    TagPtr := Ptr(TMenuItem(Sender).Tag);
  if TagPtr <> nil then
    if TagPtr is TCheckBox then
      TCheckBox(TagPtr).Checked := True;

var
  ...
    MessTag: PChar;
  ...
  if TypeClass = TButton then
  begin
    TButton(New).OnClick := OnClickButton;
    // выделяем память под строку
    GetMem(MessTag, Length('Нажата кнопка №' + IntToStr(No)) + 1);
    StrCopy(MessTag, PChar('Нажата кнопка №' + IntToStr(No)));
    TButton(New).Tag := LongInt(MessTag);
  end
  else
    New.Tag := 1;
  ...

procedure TForm1.OnClickButton(Sender: TObject);
var
  Value: string;
begin
  Value := PChar(Ptr(TButton(Sender).Tag));
  MessageDlg(Value, mtInformation, [mbOk], 0);
end;

procedure TForm1.pmComponentPopup(Sender: TObject);
begin
  pmTag1.Checked := TPopupMenu(Sender).PopupComponent.Tag = 1;
  pmTag2.Checked := not pmTag1.Checked;
  pmLine.Visible := TPopupMenu(Sender).PopupComponent is TButton;
  pmNewMessage.Visible := pmLine.Visible;
end;

procedure TForm1.pmNewMessageClick(Sender: TObject);
var
  Value: string;
  MessTag: PChar;
begin
  MessTag := PChar(TButton(pmComponent.PopupComponent).Tag);
  Value := MessTag;
  if InputQuery('Сменить сообщение',
    'Для кнопки ' + TButton(pmComponent.PopupComponent).Name, Value) then
  begin
    FreeMem(MessTag);
    GetMem(MessTag, Length(Value) + 1);
    StrCopy(MessTag, PChar(Value));
    TButton(pmComponent.PopupComponent).Tag := LongInt(MessTag);
  end;
end;

procedure TForm1.ControlMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  DragPoint := Point(X, Y);
end;
procedure TForm1.ControlMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if (ssLeft in Shift) then
  begin
    TControl(Sender).Left := TControl(Sender).Left + x - DragPoint.X;
    TControl(Sender).Top := TControl(Sender).Top + y - DragPoint.y;
  end;
end;

...
New.Top := Point.y;
New.Left := Point.x;
TLabel(New).OnMouseDown := ControlMouseDown;
TLabel(New).OnMouseMove := ControlMouseMove;
...

Итого...

Менять главную форму во время выполнения.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

procedure SetAsMainForm(aForm:TForm);
 var
   P:Pointer;
 begin
   P := @Application.Mainform;
   Pointer(P^) := aForm;
 end;
 {************************************}
 // Example of Usage: 
{ 
Question: 
  If my application is main.exe and the main form is form1, form1 displays 
  when it runs. I would like to display other forms based on the parameter 
  passed. 
  main.exe param1 will display form2 as the first form 
  main.exe param2 with display form3 as the first form 
Answer: 
}
 program Project1;
 uses
   Forms,
   Unit1 in 'Unit1.pas' {Form1},
   Unit2 in 'Unit2.pas' {Form2},
   Unit3 in 'Unit3.pas' {Form3};
 {$R *.res}
 procedure SetAsMainForm(aForm:TForm);
 var
   P:Pointer;
 begin
   P := @Application.Mainform;
   Pointer(P^) := aForm;
 end;
 begin
   Application.Initialize;
   Application.CreateForm(TForm1, Form1);
   Application.CreateForm(TForm2, Form2);
   Application.CreateForm(TForm3, Form3);
   if Paramstr(1) = 'Param1' then
     SetAsMainForm(Form2);
   if Paramstr(1) = 'Param2' then
     SetAsMainForm(Form3);
   Application.Run;
 end.

Имя свойства в течение выполнения программы.

If ( Sender is TLabel ) then.. 

Или, если вам заранее известен тип объекта, то можно так:

TLabel( Sender ).Caption 

Чтобы получить доступ к имени, воспользуйтесь одним из приведенных ниже примеров. Пример:

formname:=(myform as tobject).name; 

Или.

formname:=(myform as tcontrol).name; 

Если вы используете свойство ClassName подобно этому:

with Sender as TForm do
  Label1.Caption := copy(ClassName,2,length(ClassName)-1);

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

If Sender is TForm then
  Label1.Caption := (Sender as TForm).Name ;

Это в случае, если вы пытаетесь выполнить следующее:

Label1.Caption := Form1.Name ;

Это целый сонм проблем. Я читал, что при исполнении этого кода или не доступно свойство Form (во время выполнения программы), или, что чаще, возникает заблуждение относительно инициализируемого класса (вернее, его имени, Form1). Если вы тщательно читали документацию по Delphi, то наверняка заметили тот факт, что установка свойства в Инспекторе Объектов (Object Inspector) НЕ означает его автоматическую установку во время выполнения программы. Чтобы с честью выбраться из этой ситуации, необходимо явно установить свойство (в нашем случае свойство .Name) в методе фомы .Create. Это может выглядеть приблизительно так:

procedure TForm1.Create( Sender : TObject ) ;
begin
  Form1.Name := 'Form1' ;
end ;
procedure TForm1.Button1Click( Sender : TObject ) ;
begin
  Label1.Caption := Form1.Name ;
end ;

var
  TC: TComponent;
begin
  TC := label1.Owner;
  label1.Caption := TC.ClassName;
end;

К своей форме я добавил кнопку, и в обработчике нажатия на нее я записал следующий код:

name := 'AName';

Затем, после щелчка на кнопке, я мог бы щелкнуть на форме, и заголовок метки изменился бы на 'AName'. Решением может служить определение свойства Name в обработчике события создания формы. Т.е., если вы назвали форму именем MyForm, то в обработчике события OnCreate вы должны написать следующее:

name := 'MyForm';

Это решит вашу проблему, а я закругляюсь.

Заменить элемент управления во время выполнения.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

unit Unit1;
 interface
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
   Dialogs, StdCtrls, ComCtrls, ExtCtrls;
 type
   TForm1 = class(TForm)
     Panel1: TPanel;
   private
     { Private-Deklarationen }
   public
     { Public-Deklarationen }
   end;
   (* Neue Komponente mit eigenen Eigenschaften ersetzt erst
      zur Programmlaufzeit das Verhalten von TPanel        *)
   (* The new component replace at runtime TPanel *)
   TExtPanel = class(TCustomControl)
   protected
     procedure WMSize(var Message: TWMSize); message WM_Size;
   end;
 var
   Form1: TForm1;
 implementation
 {$R *.DFM}
 procedure TExtPanel.WMSize;
 begin
   Caption := 'Width: ' + IntToStr(Width) +
     ', Height: ' + IntToStr(Height);
 end;
 procedure ReplaceParentClass(DelphiClass,
   OldParent,
   NewParent: TClass);
 var
   aClassPointer: ^Byte;
   pVCL, pNew: ^Pointer;
   dwProtect: DWORD;
 begin
   if Assigned(NewParent) then
     if Assigned(DelphiClass) then
     begin
       // ClassParent-Zeiger suchen 
      //Search ClassParent Pointer 
      while (DelphiClass.ClassParent <> OldParent) do
       begin
         with DelphiClass do
         begin
           if (ClassParent = nil) or
             (ClassParent = NewParent) then Exit;
           // DelphiClass.ClassParent zuweisen 
          // Set DelphiClass.ClassParent 
          DelphiClass := ClassParent;
         end
       end;
       // Parent-Zeiger der originalen VCL-Klasse suchen 
      // Search Parent-Pointer of original VCL-Class 
      aClassPointer := Pointer(DelphiClass);
       Inc(aClassPointer, vmtParent);
       pVCL          := Pointer(aClassPointer);
       aClassPointer := Pointer(NewParent);
       Inc(aClassPointer, vmtSelfPtr);
       pNew := Pointer(aClassPointer);
       // Schreibberechtigung holen, Zeigerwerte tauschen 
      // Set write permission, swap pointers 
      VirtualProtect(pVCL, SizeOf(Pointer), PAGE_READWRITE, @dwProtect);
       pVCL^ := pNEW;
       // alte Zugriffsrechte aktivieren 
      // avtivate old access right 
      VirtualProtect(pVCL, SizeOf(Pointer), dwProtect, @dwProtect);
     end
   end;
 initialization
   ReplaceParentClass(TPanel, TCustomControl, TExtPanel);
 finalization
   ReplaceParentClass(TPanel, TExtPanel, TCustomControl);
 end.

Назначение события во время выполнения программы.

Почуствуйте мощь RTTI (runtime type information)!

procedure SetEvent(ComponentWithEvent: TComponent;
  const Event: string;
  ComponentWithHandler: TComponent;
  const Handler: string);
var
  PropInfo: PPropInfo;
  Method: TMethod;
begin
  PropInfo := GetPropInfo(ComponentWithEvent.ClassInfo, Event);
  if PropInfo = nil then
    raise Exception.CreateFmt('Событие %s не найдено в классе %s',
      [Event, ComponentWithEvent.ClassName]);
  Method.Code := nil;
  if Assigned(ComponentWithHandler) and (Handler <> '') then
  begin
    Method.Code := ComponentWithHandler.MethodAddress(Handler);
    if Method.Code = nil then
      raise Exception.CreateFmt('Класс %s не имеет метода с именем %s',
        [ComponentWithHandler.ClassName,
        Handler]);
  end;
  Method.Data := ComponentWithHandler;
  SetMethodProp(ComponentWithEvent, PropInfo, Method);
end;
{ примеры, показывающие как использовать SetEvent }
procedure TForm1.SetBtnClick(Sender: TObject);
begin
  SetEvent(MenuItem, 'OnClick', Self, 'Test1Click');
end;
procedure TForm1.ClearBtnClick(Sender: TObject);
begin
  SetEvent(MenuItem, 'OnClick', nil, '');
end;

Пример реализации резиновой нити.

unit Main;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, ComCtrls;
type
  TMainForm = class(TForm)
    ColorDlg: TColorDialog;
    StatusBar: TStatusBar;
    Timer: TTimer;
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure TimerTimer(Sender: TObject);
  private
    MouseRect: TRect;
    IsDown: Boolean;
    RectColor: TColor;
  public
    { Public declarations }
  end;
var
  MainForm: TMainForm;
implementation
{$R *.DFM}
procedure TMainForm.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbLeft then
    with MouseRect do
    begin
      IsDown := True;
      Left := X;
      Top := Y;
      Right := X;
      Bottom := Y;
      Canvas.Pen.Color := RectColor;
    end;
  if (Button = mbRight) and ColorDlg.Execute
    then RectColor := ColorDlg.Color;
end;
procedure TMainForm.FormMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  IsDown := False;
  Canvas.Pen.Color := Color;
  with MouseRect do
    Canvas.Polyline([Point(Left, Top), Point(Right, Top), Point(Right, Bottom),
      Point(Left, Bottom), Point(Left, Top)]);
  with StatusBar do
  begin
    Panels[4].Text := '';
    Panels[5].Text := '';
  end;
end;
procedure TMainForm.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  with StatusBar do
  begin
    Panels[2].Text := 'X: ' + IntToStr(X);
    Panels[3].Text := 'Y: ' + IntToStr(Y);
  end;
  if not IsDown then Exit;
  Canvas.Pen.Color := Color;
  with mouserect do
  begin
    Canvas.Polyline([Point(Left, Top), Point(Right, Top), Point(Right, Bottom),
      Point(Left, Bottom), Point(Left, Top)]);
    Right := X;
    Bottom := Y;
    Canvas.Pen.Color := RectColor;
    Canvas.Polyline([Point(Left, Top), Point(Right, Top), Point(Right, Bottom),
      Point(Left, Bottom), Point(Left, Top)]);
  end;
  with StatusBar do
  begin
    Panels[4].Text := 'Ширина: ' + IntToStr(Abs(MouseRect.Right - MouseRect.Left));
    Panels[5].Text := 'Высота: ' + IntToStr(Abs(MouseRect.Bottom - MouseRect.Top));
  end;
end;
procedure TMainForm.TimerTimer(Sender: TObject);
begin
  with StatusBar do
  begin
    Panels[0].Text := 'Дата: ' + DateToStr(Now);
    Panels[1].Text := 'Время: ' + TimeToStr(Now);
  end;
end;
end.

Использование функций из RunDll32.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

Количество запущенных копий программы.

program CrtApp;
uses
  SysUtils, WinTypes, WinProcs, WinCrt;
var
  NumInstances, SavePrevInst: word;
procedure GetInstanceData(hInst, Offset, Size: Word); far; external 'KERNEL';
begin
  SavePrevInst := hPrevInst;
  NumInstances := 0;
  while hPrevInst <> 0 do
  begin
    GetInstanceData(hPrevInst, Ofs(hPrevInst), SizeOf(hPrevInst));
    Inc(NumInstances);
  end;
  Writeln('Уже запущено ', NumInstances, ' копий программы');
  hPrevInst := SavePrevInst;
end.

Создание компонент во время выполнения программы и обработка их событий.

В данном примере по созданию окна создаются кнопки, по нажатию каждой выводится сообщение, в котором значится заголовок кнопки, вызвавшей событие. Сначала вынесите на форму компонент TButton и по его нажатию напишите такой код:

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage((Sender as TButton).Caption);
end;

А основное действие свершится по созданию окна:

procedure TForm1.FormCreate(Sender: TObject);
var
  Button1: TButton;
  i: integer;
begin
  for i:=0 to 4 do
  begin
    Button1:=TButton.Create(Form1);
    with Button1 do
    begin
      Parent := Form1;
      Caption := 'Кнопка ' + IntToStr(i + 1);
      Height := 25;
      Width := 75;
      Top := i * 25 + 25;
      Left := 50;
      OnClick := Button1Click;
    end;
  end;
end;

Как перемещать компоненты во время работы программы.

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1MouseDown(Sender: TObject; Button: TMouseButton;
    Shift: TShiftState; X, Y: Integer);
    procedure Button1MouseMove(Sender: TObject; Shift: TShiftState; X,
    Y: Integer);
    procedure Button1MouseUp(Sender: TObject; Button:
    TMouseButton; Shift: TShiftState; X, Y: Integer);
  private
    {Private declarations}
  public
    {Public declarations}
    MouseDownPoint : TPoint;
    Moving : bool;
end;
var
  Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
  if ssCtrl in Shift then
  begin
    SetCapture(Button1.Handle);
    Moving := true;
    MouseDownPoint.X := x;
    MouseDownPoint.Y := Y;
  end;
end;
procedure TForm1.Button1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
  if Moving then
  begin
    Button1.Left := Button1.Left - (MouseDownPoint.x - x);
    Button1.Top := Button1.Top - (MouseDownPoint.y - y);
  end;
end;
procedure TForm1.Button1MouseUp(Sender: TObject; Button:
TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if Moving then
  begin
    ReleaseCapture;
    Moving := false;
    Button1.Left := Button1.Left - (MouseDownPoint.x - x);
    Button1.Top := Button1.Top - (MouseDownPoint.y - y);
  end;
end;

Показ свойств во время выполнения программы.

Я написал компонент-отладчик, выводящий в дереве все компоненты. Попробуйте этот код. Вызывайте функцию DisplayProperties как показано ниже:

DisplayProperties(Form1,                {Вы можете использовать любой компонент}
                  Outline1.Lines,       {Допускается любой TStrings-объект}
                  0);                   {0 - "стартовый", корневой уровень}

DisplayProperties(AObj: TObject; AList: TStrings; iIndentLevel: Integer);
var
  Indent: string;
  ATypeInfo: PTypeInfo;
  ATypeData: PTypeData;
  APropTypeData: PTypeData;
  APropInfo: PPropInfo;
  APropList: PPropList;
  iProp: Integer;
  iCnt: Integer;
  iCntProperties: SmallInt;
  ASecondObj: TObject;
procedure AddLine(sLine: string);
begin
  AList.Add(Indent + #160 + IntToStr(iProp) + ': ' + APropInfo^.Name
    + ' (' + APropInfo^.PropType^.Name + ')' + sLine);
end;
begin
  try
    Indent := GetIndentSpace(iIndentLevel);
    ATypeInfo := AObj.ClassInfo;
    ATypeData := GetTypeData(ATypeInfo);
    iCntProperties := ATypeData^.PropCount;
    GetMem(APropList, SizeOf(TPropInfo) * iCntProperties);
    GetPropInfos(ATypeInfo, APropList);
    for iProp := 0 to ATypeData^.PropCount - 1 do
    begin
      APropInfo := APropList^[iProp];
      case APropInfo^.PropType^.Kind of
        tkInteger:
          AddLine(' := ' + IntToStr(GetOrdProp(AObj, APropInfo)));
        tkChar:
          AddLine(' := ' + chr(GetOrdProp(AObj, APropInfo)));
        tkEnumeration:
          begin
            APropTypeData := GetTypeData(APropInfo^.PropType);
            if APropTypeData^.BaseType^.Name <> APropInfo^.PropType^.Name then
              AddLine(' := ' + IntToStr(GetOrdProp(AObj, APropInfo)))
            else
              AddLine(' := ' + APropTypeData^.NameList);
          end;
        tkFloat:
          AddLine(' := ' + FloatToStr(GetFloatProp(AObj, APropInfo)));
        tkString:
          AddLine(' := "' + GetStrProp(AObj, APropInfo) + '"');
        tkSet:
          begin
            AddLine(' := ' + IntToStr(GetOrdProp(AObj, APropInfo)));
          end;
        tkClass:
          begin
            ASecondObj := TObject(GetOrdProp(AObj, APropInfo));
            if ASecondObj = nil then
              AddLine(' := NIL')
            else
            begin
              AddLine('');
              DisplayProperties(ASecondObj, AList, iIndentLevel + 1);
            end;
          end;
        tkMethod:
          begin
            AddLine('');
          end;
      else
        AddLine(' := >>НЕИЗВЕСТНО<<');
      end;
    end;
  except {Выводим исключение и продолжаем дальше}
    on e: Exception do
      ShowMessage(e.Message);
  end;
  FreeMem(APropList, SizeOf(TPropInfo) * iCntProperties);
end;
function GetIndentSpace(iIndentLevel: Integer): string;
var
  iCnt: Integer;
begin
  Result := '';
  for iCnt := 0 to iIndentLevel - 1 do
    Result := Result + #9;
end;

Запуск программы.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

{ Open a file or starts a programm (without parameters) }
 procedure OpenFile(FileName: string);
 var
   c: array[0..800] of Char;
 begin
   StrPCopy(c, FileName);
   ShellExecute(Application.Handle, 'open', c, nil, nil, SW_NORMAL);
 end;
 { Starts a programm with commandline parameters }
 procedure OpenProgram(prog, params: string);
 var
   c, p: array[0..800] of Char;
 begin
   StrPCopy(c, prog);
   StrPCopy(p, params);
   ShellExecute(Application.Handle, 'open', c, p, nil, SW_NORMAL);
 end;
 { Starts a program and wait until its terminated: 
  WindowState is of the SW_xxx constants }
 function ExecAndWait(const FileName, Params: string;
   WindowState: Word): Boolean;
 var
   SUInfo: TStartupInfo;
   ProcInfo: TProcessInformation;
   CmdLine: string;
 begin
   { Enclose filename in quotes to take care of 
    long filenames with spaces. }
   CmdLine := '"' + FileName + '"' + Params;
   FillChar(SUInfo, SizeOf(SUInfo), #0);
   with SUInfo do
   begin
     cb := SizeOf(SUInfo);
     dwFlags := STARTF_USESHOWWINDOW;
     wShowWindow := WindowState;
   end;
   Result := CreateProcess(nil, PChar(CmdLine), nil, nil, False,
     CREATE_NEW_CONSOLE or
     NORMAL_PRIORITY_CLASS, nil,
     PChar(ExtractFilePath(FileName)),
     SUInfo, ProcInfo);
   { Wait for it to finish. }
   if Result then
     WaitForSingleObject(ProcInfo.hProcess, INFINITE);
 end;
 { Execute a complete shell command line and waits until terminated. }
 function ExecCmdLineAndWait(const CmdLine: string;
   WindowState: Word): Boolean;
 var
   SUInfo: TStartupInfo;
   ProcInfo: TProcessInformation;
 begin
   { Enclose filename in quotes to take care of 
    long filenames with spaces. }
   FillChar(SUInfo, SizeOf(SUInfo), #0);
   with SUInfo do
   begin
     cb := SizeOf(SUInfo);
     dwFlags := STARTF_USESHOWWINDOW;
     wShowWindow := WindowState;
   end;
   Result := CreateProcess(nil, PChar(CmdLine), nil, nil, False,
     CREATE_NEW_CONSOLE or
     NORMAL_PRIORITY_CLASS, nil,
     nil {PChar(ExtractFilePath(Filename))},
     SUInfo, ProcInfo);
   { Wait for it to finish. }
   if Result then
     WaitForSingleObject(ProcInfo.hProcess, INFINITE);
 end;
 { Execute a complete shell command line without waiting. }
 function OpenCmdLine(const CmdLine: string;
   WindowState: Word): Boolean;
 var
   SUInfo: TStartupInfo;
   ProcInfo: TProcessInformation;
 begin
   { Enclose filename in quotes to take care of 
    long filenames with spaces. }
   FillChar(SUInfo, SizeOf(SUInfo), #0);
   with SUInfo do
   begin
     cb := SizeOf(SUInfo);
     dwFlags := STARTF_USESHOWWINDOW;
     wShowWindow := WindowState;
   end;
   Result := CreateProcess(nil, PChar(CmdLine), nil, nil, False,
     CREATE_NEW_CONSOLE or
     NORMAL_PRIORITY_CLASS, nil,
     nil {PChar(ExtractFilePath(Filename))},
     SUInfo, ProcInfo);
 end;

Как запустить апплет панели управления.

Запустить аплет Панели управления можно вызвав функцию WinExec, для выполнения файла control.exe, которому передано имя аплета. Обычно аплеты панели управления расположены в каталоге System Windows и имеют расширение .cpl.

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

Запускать можете следующие апплеты:

Открыть меню кнопки ПУСК или запустить диалог запуска программ.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

// Show the Startmenu: 
keybd_event(VK_LWIN, MapVirtualKey(VK_LWIN, 0), 0, 0);
 keybd_event(VK_LWIN, MapVirtualKey(VK_LWIN, 0), KEYEVENTF_KEYUP, 0)
 //Show the Run-Dialog: 
keybd_event(VK_LWIN, MapVirtualKey(VK_LWIN, 0), 0, 0);
 keybd_event(Ord('R'), MapVirtualKey(Ord('R'), 0), 0, 0);
 keybd_event(Ord('R'), MapVirtualKey(Ord('R'), 0), KEYEVENTF_KEYUP, 0);
 keybd_event(VK_LWIN, MapVirtualKey(VK_LWIN, 0), KEYEVENTF_KEYUP, 0)

Как запускать внешнюю программу сразу с высоким приоритетом.

Пример:

procedure TForm1.Button1Click(Sender: TObject);
var
  ProcessID: DWORD;
  ProcessHandle: THandle;
  ThreadHandle: THandle;
begin
  ProcessID := GetCurrentProcessID;
  ProcessHandle := OpenProcess(PROCESS_SET_INFORMATION, false, ProcessID);
  SetPriorityClass(ProcessHandle, REALTIME_PRIORITY_CLASS);
  ThreadHandle := GetCurrentThread;
  SetThreadPriority(ThreadHandle, THREAD_PRIORITY_TIME_CRITICAL);
end;

Запустить консольное приложение и получить его стандартный вывод.

{ 
This function runs a program (console or batch) and adds its output 
to Memo1 
} 
{....} 
  private 
    function RunCaptured(const _dirName, _exeName, _cmdLine: string): Boolean; 
     
{....} 
function TForm1.RunCaptured(const _dirName, _exeName, _cmdLine: string): Boolean; 
var 
  start: TStartupInfo; 
  procInfo: TProcessInformation; 
  tmpName: string; 
  tmp: Windows.THandle; 
  tmpSec: TSecurityAttributes; 
  res: TStringList; 
  return: Cardinal; 
begin 
  Result := False; 
  try 
    { Setze ein Temporares File } 
    { Set a temporary file } 
    tmpName := 'Test.tmp'; 
    FillChar(tmpSec, SizeOf(tmpSec), #0); 
    tmpSec.nLength := SizeOf(tmpSec); 
    tmpSec.bInheritHandle := True; 
    tmp := Windows.CreateFile(PChar(tmpName), 
           Generic_Write, File_Share_Write, 
           @tmpSec, Create_Always, File_Attribute_Normal, 0); 
    try 
      FillChar(start, SizeOf(start), #0); 
      start.cb          := SizeOf(start); 
      start.hStdOutput  := tmp; 
      start.dwFlags     := StartF_UseStdHandles or StartF_UseShowWindow; 
      start.wShowWindow := SW_Minimize; 
      { Starte das Programm } 
      { Start the program } 
      if CreateProcess(nil, PChar(_exeName + ' ' + _cmdLine), nil, nil, True, 
                       0, nil, PChar(_dirName), start, procInfo) then 
      begin 
        SetPriorityClass(procInfo.hProcess, Idle_Priority_Class); 
        WaitForSingleObject(procInfo.hProcess, Infinite); 
        GetExitCodeProcess(procInfo.hProcess, return); 
        Result := (return = 0); 
        CloseHandle(procInfo.hThread); 
        CloseHandle(procInfo.hProcess); 
        Windows.CloseHandle(tmp); 
        { Die Ausgaben hinzufugen } 
        { Add the output } 
        res := TStringList.Create; 
        try 
          res.LoadFromFile(tmpName); 
          Memo1.Lines.AddStrings(res); 
        finally 
          res.Free; 
        end; 
        Windows.DeleteFile(PChar(tmpName)); 
      end 
      else 
      begin 
        Application.MessageBox(PChar(SysErrorMessage(GetLastError())), 
          'RunCaptured Error', MB_OK); 
      end; 
    except 
      Windows.CloseHandle(tmp); 
      Windows.DeleteFile(PChar(tmpName)); 
      raise; 
    end; 
  finally 
  end; 
end; 
// Example: 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  RunCaptured('C:\', 'cmd.exe', '/c dir'); 
end;

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

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

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

Сначала мы проверяем, установлен ли Screen Saver, если нет - возвращаемся с отрицательным ответом, в противном случае - запускаем его и возвращаем true.

function RunScreenSaver: bool;
var
  b: boolean;
begin
  result := false;
  if SystemParametersInfo(SPI_GETSCREENSAVEACTIVE, 0, @b, 0) <> true then
    exit;
  if not b then
    exit;
  PostMessage(GetDesktopWindow, WM_SYSCOMMAND, SC_SCREENSAVE, 0);
  result := true;
end;

Показать диалог для запуска приложения.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

 uses
   ComObj;
 procedure TForm1.FormCreate(Sender: TObject);
 var
   ShellApplication: Variant;
 begin
   ShellApplication := CreateOleObject('Shell.Application');
   ShellApplication.FileRun;
 end;

Показать диалог для запуска приложения 2.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

 { This code uses the undocumented RunFileDlg function to show the "run" dialog }
 { Dieser Code verwendet die undokumentierte RunFileDlg Funktion, um den Ausfuhren Dialog anzuzeigen }
 // For Win NT 
procedure RunFileDlgW(OwnerWnd: HWND; Icon: HICON; lpstrDirectory: PWideChar;
   lpstrTitle: PWideChar; lpstrDescription: PWideChar; Flags: Longint); stdcall;
   external 'Shell32.dll' Index 61;
 // For Win 9x (Win NT to show standard captions ) 
procedure RunFileDlg(OwnerWnd: HWND; Icon: HICON; lpstrDirectory: PChar;
   lpstrTitle: PChar; lpstrDescription: PChar; Flags: Longint); stdcall;
   external 'Shell32.dll' Index 61;
 const
   RFF_NOBROWSE = 1; //Removes the browse button. 
  RFF_NODEFAULT = 2; // No default item selected. 
  RFF_CALCDIRECTORY = 4; // Calculates the working directory from the file name. 
  RFF_NOLABEL = 8; // Removes the edit box label. 
  RFF_NOSEPARATEMEM = 14; // Removes the Separate Memory Space check box (Windows NT only). 
function ShowRunFileDialg(OwnerWnd: HWND; InitialDir, Title, Description: PChar;
   flags: Integer; StandardCaptions: Boolean): Boolean;
 var
   HideBrowseButton: Boolean;
   TitleWideChar, InitialDirWideChar, DescriptionWideChar: PWideChar;
   Size: Integer;
 begin
   if (Win32Platform = VER_PLATFORM_WIN32_NT) and not StandardCaptions then
   begin
     Size := SizeOf(WideChar) * MAX_PATH;
     InitialDirWideChar := nil;
     TitleWideChar := nil;
     DescriptionWideChar := nil;
     GetMem(InitialDirWideChar, Size);
     GetMem(TitleWideChar, Size);
     GetMem(DescriptionWideChar, Size);
     StringToWideChar(InitialDir, InitialDirWideChar, MAX_PATH);
     StringToWideChar(Title, TitleWideChar, MAX_PATH);
     StringToWideChar(Description, DescriptionWideChar, MAX_PATH);
     try
       RunFileDlgW(OwnerWnd, 0, InitialDirWideChar, TitleWideChar, DescriptionWideChar, Flags);
     finally
       FreeMem(InitialDirWideChar);
       FreeMem(TitleWideChar);
       FreeMem(DescriptionWideChar);
     end;
   end else
     RunFileDlg(OwnerWnd, 0, PChar(InitialDir), PChar(Title), PChar(Description), Flags);
 end;
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   ShowRunFileDialg(FindWindow('Shell_TrayWnd', nil), nil, nil, nil, RFF_NOBROWSE, True);
 end;

Как написать DLL, которую можно было-бы выполнить с помощью RunDll, RunDll32.

int __stdcall __declspec(dllexport) Test
(
HWND hWnd,
HINSTANCE hInstance,
LPCSTR lpCmdLine,
DWORD dummy
)
{
MessageBox(hWnd, lpCmdLine, "Command Line", MB_OK);
return 0;
}

rundll32 test.dll,_Test@16 this is a command line

На Паскале -

function Test(
  hWnd: Integer;
  hInstance: Integer;
  lpCmdLine: PChar;
  dummy: Longint
  ): Integer; stdcall; export;
begin
  Windows.MessageBox(hWnd, lpCmdLine, 'Command Line', MB_OK);
  Result := 0;
end;

int WINAPI RunDll( HWND hWnd, HINSTANCE hInstance, LPCSTR lpszCmdLine, DWORD dummy );
......
int WINAPI RunDllW( HWND hWnd, HINSTANCE hInstance, LPCWSTR lpszCmdLine, DWORD dummy );
......

EXPORTS
RunDll
RunDllA=RunDll
RunDllW

То rundll32 становится разборчивой -- под NT вызывает UNICODE-версию. Под 95, разумеется, ANSI.

Запустить на выполнение файл от имени любого пользователя.

Автор: Диюк Анрей.

unit HSAdvApi;
interface
uses
  Windows;
procedure MyCreateProcess(ConstCommandLine: string);
function CreateProcessWithLogonW(const lpUsername: PWideChar;
  const lpDomain: PWideChar; const lpPassword: PWideChar;
  dwLogonFlags: DWORD; const lpApplicationName: PWideChar;
  lpCommandLine: PWideChar; dwCreationFlags: DWORD;
  lpEnvironment: Pointer; const lpCurrentDirectory: PWideChar;
  lpStartupInfo: PStartupInfo;
  lpProcessInfo: PProcessInformation): Boolean; stdcall;
const
  LOGON_WITH_PROFILE = $00000001;
  LOGON_NETCREDENTIALS_ONLY = $00000002;
  LOGON_ZERO_PASSWORD_BUFFER = $80000000;
implementation
uses
  SysUtils;
{$WARN SYMBOL_DEPRECATED OFF}
{ ADVAPI32.DLL functions }
type
  TCreateProcessWithLogonW =
    function(const lpUsername: PWideChar;
    const lpDomain: PWideChar; const lpPassword: PWideChar;
    dwLogonFlags: DWORD; const lpApplicationName: PWideChar;
    lpCommandLine: PWideChar; dwCreationFlags: DWORD;
    lpEnvironment: Pointer; const lpCurrentDirectory: PWideChar;
    lpStartupInfo: PStartupInfo;
    lpProcessInfo: PProcessInformation): Boolean; stdcall;
const
  DllName = 'advapi32.dll';
var
  DllHandle: THandle;
  _CreateProcessWithLogonW: TCreateProcessWithLogonW;
function InitLib: Boolean;
begin
  if DllHandle = 0 then
    if Win32Platform = VER_PLATFORM_WIN32_NT then
    begin
      DllHandle := LoadLibrary(DllName);
      if DllHandle <> 0 then
      begin
        @_CreateProcessWithLogonW := GetProcAddress(DllHandle,
          'CreateProcessWithLogonW');
      end;
    end;
  Result := (DllHandle <> 0);
end;
function NotImplementedBool: Boolean;
begin
  SetLastError(ERROR_CALL_NOT_IMPLEMENTED);
  Result := false;
end;
function CreateProcessWithLogonW(const lpUsername: PWideChar;
  const lpDomain: PWideChar; const lpPassword: PWideChar;
  dwLogonFlags: DWORD; const lpApplicationName: PWideChar;
  lpCommandLine: PWideChar; dwCreationFlags: DWORD;
  lpEnvironment: Pointer; const lpCurrentDirectory: PWideChar;
  lpStartupInfo: PStartupInfo;
  lpProcessInfo: PProcessInformation): Boolean; stdcall;
begin
  if InitLib and Assigned(_CreateProcessWithLogonW) then
    Result := _CreateProcessWithLogonW(lpUsername, lpDomain, lpPassword,
      dwLogonFlags, lpApplicationName, lpCommandLine, dwCreationFlags,
      lpEnvironment, lpCurrentDirectory, lpStartupInfo, lpProcessInfo)
  else
    Result := NotImplementedBool;
end;
procedure MyCreateProcess(ConstCommandLine: string);
const
  UserName: WideString = 'ADMIN';
  Password: WideString = 'creyc';
  //ConstCommandLine : String = 'MONIC_S.EXE ';
  Title: WideString = 'SERVISE';
  Domain: WideString = 'SOKAL';
var
  MyStartupInfo: STARTUPINFO;
  ProcessInfo: PROCESS_INFORMATION;
  CommandLine: array[0..512] of WideChar;
begin
  FillChar(MyStartupInfo, SizeOf(MyStartupInfo), 0);
  MyStartupInfo.cb := SizeOf(MyStartupInfo);
  StringToWideChar(ConstCommandLine, CommandLine,
    Sizeof(CommandLine) div SizeOf(WideChar));
  MyStartupInfo.lpTitle := PWideChar(Title);
  if not CreateProcessWithLogonW(PWideChar(UserName), PWideChar(Domain),
    PWideChar(Password), LOGON_WITH_PROFILE, nil,
    CommandLine, 0, nil, nil, @MyStartupInfo, @ProcessInfo) then
    RaiseLastWin32Error()
  else
  begin
    CloseHandle(ProcessInfo.hProcess);
    CloseHandle(ProcessInfo.hThread);
  end;
end;
initialization
finalization
  if DllHandle <> 0 then
    FreeLibrary(DllHandle);
end.

Запустить процесс в защищенной области другого пользователя.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

uses
   JwaWinBase; ( http://members.chello.nl/m.vanbrakel2/ ) 
//... 
procedure TForm1.Button1Click(Sender: TObject);
 var
    si: STARTUPINFOW;
    pif: PROCESS_INFORMATION;
    res: Bool;
   s: string;
 begin
   //erstmal die StartUpInfoW setzen 
  //set StartUpInfoW first 
  si.cb := SizeOf(startupinfow);
   si.dwFlags  := STARTF_USESHOWWINDOW;
   si.wShowWindow := SW_SHOWDEFAULT;
   si.lpReserved := nil;
   si.lpDesktop := nil;
   si.lpTitle := 'Konsole';
   // dann CreateProcessWithLogonW аиsfьhгеn... 
  // run CreateProcessWithLogonW... 
  res := CreateProcessWithLogonW('Security', 'ArViCor', 'test', LOGON_WITH_PROFILE,
     'c:\win2kas\system32\regedt32.exe', nil
     , CREATE_DEFAULT_ERROR_MODE, nil, nil, si, pif);
   if booltostr(res) = '0' then
    begin
     //wenn ein Fehler auftritt, soll der Fehlercode ausgegeben werden 
    //ььег 'net helpmsg ' in der Kommandoeingabeaufforderung 
    //kann dieser entziffert werden 
    //if an error occures, show the error-code 
    //this code can be 'translated' with 'net helpmsg ' on command-prompt 
    str(GetLastError, s);
     ShowMessage('CreateProcessWithLogonResult: ' + booltostr(res) + #10 +
       'GetLastError: ' + s);
   end;
 end;
 // Verbesserungen gerne als Mail an mich! 

Как можно запустить lnk.

uses ShellApi;
procedure TForm1.Button1Click(Sender: TObject);
begin
  ShellExecute(0, nil, 'C:\WINDOWS\START MENU\DELPHI\Delphi3.lnk',
    nil, nil, SW_SHOWNORMAL);
end;

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

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

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.

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

Здесь представлены две функции 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 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 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;

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

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

Другой способ запуска чужого приложения.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

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;

Просмотрщик запущенных процессов.

В исходном коде есть недоработки, например, процедура Delproc получает в качестве параметра строку, затем переводит ее в целочисленный тип(integer), хотя можно передавать сразу число. Заморочка была в проверке числа-индекса на подлинность, а так как я выдрал часть кода из более ранней своей проги, я не стал это менять, а просто подогнал до рабочей версии. Оптимизацией кода вы можете заняться сами по желанию(вы можете, если хотите, а если не хотите, то вы не обязаны, вы посто могли бы... да... :))) Программа не работала в WinNT 4.0, но в Win9x работать должна.

unit main;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, tlhelp32, StdCtrls, ComCtrls, Buttons;
type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    Button1: TButton;
    Button2: TButton;
    Button4: TButton;
    Button5: TButton;
    StatusBar1: TStatusBar;
    Button6: TButton;
    procedure Button4Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
    procedure ListBox1Click(Sender: TObject);
    procedure Button6Click(Sender: TObject);
  private
    { Private declarations }
    procedure ListProcesses;
    procedure Delproc(numb: string);
  public
    { Public declarations }
  end;
var
  Form1: TForm1;
  processID: array[1..50] of integer;
function RegisterServiceProcess(dwProcessID, dwType: integer): integer; stdcall;
  external 'kernel32.dll';
implementation
{$R *.DFM}
procedure TForm1.delproc(numb: string);
var
  c1: Cardinal;
  pe: TProcessEntry32;
  s1, s2: string;
  x: integer;
begin
  x := 0;
  try
    Strtoint(numb);
  except
    Statusbar1.SimpleText := 'Invalid number';
    exit;
  end;
  c1 := CreateToolHelp32Snapshot(TH32CS_SnapProcess, 0);
  if c1 = INVALID_HANDLE_VALUE then
  begin
    Statusbar1.SimpleText := 'Process listing failed';
    exit;
  end;
  try
    pe.dwSize := sizeof(pe);
    if Process32First(c1, pe) then
      repeat
        inc(x);
        s1 := ExtractFileName(pe.szExeFile);
        s2 := ExtractFileExt(s1);
        Delete(s1, length(s1) + 1 - length(s2), maxInt);
        if x = strtoint(numb) then
          if terminateprocess(OpenProcess(PROCESS_ALL_ACCESS, false,
            pe.th32ProcessID), 1) then
          begin
            Statusbar1.SimpleText := 'Process ' + s1 + ' terminated.';
          end
          else
            Statusbar1.SimpleText := ('Couldnt terminate process' +
              pe.szExeFile);
      until not Process32Next(c1, pe);
  finally CloseHandle(c1);
  end;
end;
procedure Tform1.ListProcesses;
var
  c1: Cardinal;
  pe: TProcessEntry32;
  s1, s2: string;
  x: integer;
begin
  X := 0;
  c1 := CreateToolHelp32Snapshot(TH32CS_SnapProcess, 0);
  if c1 = INVALID_HANDLE_VALUE then
  begin
    Statusbar1.SimpleText := ('Информация о процессах закрыта.');
    exit;
  end;
  try
    pe.dwSize := sizeof(pe);
    if Process32First(c1, pe) then
      repeat
        inc(x);
        s1 := ExtractFileName(pe.szExeFile);
        s2 := ExtractFileExt(s1);
        Delete(s1, length(s1) + 1 - length(s2), maxInt);
        Listbox1.Items.Add(Inttostr(x) + '  ' + s1 + '  :  ' + pe.szExeFile);
        ProcessId[x] := pe.th32ProcessID;
        //ListBox1.Items.Add(inttostr(pe.th32ProcessID));
      until not Process32Next(c1, pe);
  finally CloseHandle(c1);
  end;
end;
procedure TForm1.Button4Click(Sender: TObject);
begin
  Close;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
  Button1.Enabled := false;
  Button5.Enabled := false;
  Button6.Enabled := false;
  ListProcesses;
  if not (csDesigning in ComponentState) then
    RegisterServiceProcess(GetCurrentProcessID, 1);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
  Listbox1.Clear;
  ListProcesses;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
  p: integer;
begin
  //hide
  with Listbox1 do
    p := Listbox1.Items.IndexOf(Listbox1.items[itemindex]) + 1;
  if not (csDesigning in ComponentState) then
    RegisterServiceProcess(ProcessID[p], 1);
  with Listbox1 do
    StatusBar1.SimpleText := (Listbox1.items[itemindex] + ' hidden');
end;
procedure TForm1.Button5Click(Sender: TObject);
var
  p: integer;
begin
  //show
  with Listbox1 do
    p := Listbox1.Items.IndexOf(Listbox1.items[itemindex]) + 1;
  if not (csDesigning in ComponentState) then
    RegisterServiceProcess(ProcessID[p], 0);
  with Listbox1 do
    StatusBar1.SimpleText := (Listbox1.items[itemindex] + ' shown');
end;
procedure TForm1.ListBox1Click(Sender: TObject);
begin
  Button1.Enabled := true;
  Button5.Enabled := true;
  Button6.Enabled := true;
end;
procedure TForm1.Button6Click(Sender: TObject);
var
  p: integer;
begin
  with Listbox1 do
    p := Listbox1.Items.IndexOf(Listbox1.items[itemindex]) + 1;
  delproc(inttostr(p));
end;
end.

Как узнать, запущен ли процесс в Win9x.

function IsRunning(sName: string): boolean;
var
  han: THandle;
  ProcStruct: PROCESSENTRY32; // from "tlhelp32" in uses clause
  sID: string;
begin
  Result := false;
  // Get a snapshot of the system
  han := CreateToolhelp32Snapshot(TH32CS_SNAPALL, 0);
  if han = 0 then
    exit;
  // Loop thru the processes until we find it or hit the end
  ProcStruct.dwSize := sizeof(PROCESSENTRY32);
  if Process32First(han, ProcStruct) then
  begin
    repeat
      sID := ExtractFileName(ProcStruct.szExeFile);
      // Check only against the portion of the name supplied, ignoring case
      if uppercase(copy(sId, 1, length(sName))) = uppercase(sName) then
      begin
        // Report we found it
        Result := true;
        Break;
      end;
    until not Process32Next(han, ProcStruct);
  end;
  // clean-up
  CloseHandle(han);
end;

Бегущая строка.

procedure TForm1.Timer1Timer(Sender: TObject);
const
  LengthGoString = 10;
  Gostring = 'Этот код был взят с проекта Delphi World'+
  ' Выпуск 2002 - 2003! Этот код б';
  // Повторить столько символов - сколько в LengthGoString
const
  i: Integer = 1;
begin
  Label1.Caption := Copy(GoString, i, LengthGoString);
  Inc(i);
  if Length(GoString) - LengthGostring < i then
    i:=1;
end;

Создание компонент в Run-Time.

Итак, рассмотрим на первый взгляд сложный вопрос о создании компонентов в Run_time (то есть во время работы программы). Но на самом деле этот вопрос довольно просто решается.

Давайте вместе попробуем написать код, чтобы при нажатии на кнопку на форме появлялось текстовое поле с каким-нибудь текстом. Для этого надо проделать следующие действия: объявить переменную необходимого вам типа компонента, в нашем случае TEdit, затем необходимо описать процедуру Create для нашей переменной, задать обязательное свойство Parent (то есть где появится наш компонент), ну и установить необязательные параметры типа высоты, ширины и т.д. Лучше разбираться на конкретном примере, так что смотрите какой у меня получился код:

procedure TForm1.Button1Click(Sender: TObject);
var
  x: TEdit; // объявляем переменную типа TEdit
begin
  x:=TEdit.create(self);// создаем экземпляр компонента
  x.parent:=form1;// текстовое поле появится на форме
  x.left:=10;
  x.top:=10;
  x.Width:=250;
  x.Text:='Delphi World is (:-0) !!!';
end;

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

Процессы создания визуальных и невизуальных компонентов несколько отличаются (последний попроще будет). Поскольку Edit мы уже создали (а это как раз визуальный компонент), теперь будем создавать невизуальный компонент, например FontDialog. Поставьте на форму еще кнопку. Обработчик события OnClick может выглядеть так:

procedure TForm1.Button2Click(Sender: TObject);
var
  y: TFontDialog; // объявляем переменную типа TFontDialog
begin
  y:=TFontdialog.Create(self);
  y.Execute; //только для демонстрации. Показать что работает.
end;

Вы свободно можете изменять любые свойства компонента, созданного во время работы приложения.

Теперь мы попробуем вместе проделать такую вещь: мы отсортируем находящиеся в Memo данные. Для этого поставьте на форму Memo и напишите в ней 4 строки, например:

Поскольку само Memo сортировать данные не умеет, то нам придется во время работы программы создать какую-нибудь переменную абстрактного класса TStringList (этот класс сортировать умеет), затем присвоить этому классу строки из Memo, отсортировать их и присвоить их обратно Memo. Поставим еще одну кнопку на форму, которая будет запускать процесс. Код получится примерно таким:

procedure TForm1.Button3Click(Sender: TObject);
var
  t: TStringList;
begin
  t:=TStringList.Create; //создаем
  t.AddStrings(memo1.lines); //присваиваем переменной t строки из Memo
  t.Sort; // сортируем
  memo1.Clear;
  memo1.Lines.AddStrings(t); // присваиваем memo уже отсортированные строки
end;

Теперь рассмотрим еще один вопрос, касающийся создания компонентов в Run-time. Допустим вам надо создать 20 полей для ввода текста (Edit) и еще десять меток (Label), не будете же вы 20 раз писать одно и тоже для каждого edit'a. В этой ситуации есть очень элегантный выход: воспользоваться массивом компонентов. В общем виде объявление массива компонентов может выглядеть так: имя_переменной:array[нижний_индекс..верхний_индекс] of тип_компонента. Теперь поупражняемся в этом. Создайте новое приложение. На форму поместите только кнопку. Обработчик события OnClick которой у меня получился таким:

procedure TForm1.Button1Click(Sender: TObject);
var
  a: array [1..20] of TEdit; // массив элементов Edit
  b: array [1..10] of TLabel; //массив меток
  i, j: integer;
begin
  for i:=1 to 20 do
  begin
    a[i]:=TEdit.create(self);
    a[i].parent:=form1;
    a[i].left:=10;
    a[i].text:='элемент # '+inttostr(i);
    a[i].top:=i*20;
  end;
  for j:=1 to 10 do
  begin
    b[j]:=TLabel.create(self);
    b[j].parent:=form1;
    b[j].left:=200;
    b[j].Caption:='элемент # '+inttostr(j);
    b[j].top:=j*30;
  end;
end;

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

Как упаковать базу (DBase, Paradox) в RunTime.

Для dBase:

uses
  DbiProcs;
with Table do
begin
  OldState := Active;
  Close;
  Exclusive := True;
  Open;
  DbiPackTable(DBHandle, Handle, nil, nil, True);
  {^ здесь можно добавить check()}
  Close;
  Exclusive := False;
  Active := OldState;
  { при желании можно сохранить закладку }
end;

Для Paradox:

DbiDoRestructure(DBHandle, 1, ?, nil, nil, nil, False); { см. dbiProcs.int }

Вместо ? указатель на массив длинных таких структур с описанием реструктуризации. Кто делал на Px, я думаю, дадут пример.

Это насчет упаковки db (может что-то и лишнее, что-то можно сделать по-другому, но работает ).

Пример для Paradox:

uses
  BDE; // for D3, для D2 непомню (что-то типа DbiProc и еще что-то)
// для примера
tLog: TTable; // таблица юзающая d:\db\log.db
var
  TblDesc: CRTblDesc;
  rslt: DBIResult;
  Dir: string; //имеется в виду huge string т.е. {$H+}
  hDb: hDbiDb;
begin
  tLog.Active:=False; //деактивируем TTable
  SetLength(Dir, dbiMaxNameLen + 1);
  DbiGetDirectory(tLog.DBHandle, False, PChar(Dir));
  SetLength(Dir, StrLen(PChar(Dir)));
  DbiOpenDatabase(nil, nil, dbiReadWrite, dbiOpenExcl,
  nil, 0, nil, nil, hDb);
  DbiSetDirectory(hDb, PChar(Dir));
  FillChar(TblDesc, sizeof(CRTblDesc), 0);
  StrPCopy(TblDesc.szTblName, 'd:\db\log.db');
  // здесь должно быть полное имя файла
  // которое можно:
  // а) ввести руками;
  // б) вытащить из пропертей таблицы;
  // в) вытащить из алиаса;
  // г) см. FAQ
  StrCopy(TblDesc.szTblType, szParadox);
  //BTW тут может и szDBase стоять
  TblDesc.bPack := TRUE;
  DbiDoRestructure(hDb, 1, @TblDesc, nil, nil, nil, False);
  DbiCloseDatabase(hDb);
end;

Как запустить приложение и подождать пока оно отработает 7.

Автор: RhinoFC WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Запуск программы и ожидание ее завершения.
Функция запускает внешнюю программу, заданную параметром Path, и ждет ее завершения.
Во время выполнения внешней программы, текущее приложение скрывается (
т.к. не может перерисовать главное окно, что некрасиво), поэтому фактически
происходит переключение с текущей программы на внешнюю и,
после завершения внешней программы, обратно.
В качестве внешней программы может выступать любой выполняемый файл (EXE, COM, BAT, SCR).
Зависимости: Windows, Forms
Автор:       Евгений Валяев (RhinoFC), rhinofc@sniiggims.ru, ICQ:55263922, Новосибирск
Copyright:   RhinoFC
Дата:        5 июня 2002 г.
***************************************************** }
function SwitchToProg(const Path: string): Boolean;
var
  SI: TStartupInfo;
  PI: TProcessInformation;
  ExitCode: Cardinal;
begin
  FillChar(SI, SizeOf(SI), 0);
  SI.cb := SizeOf(SI);
  Result := CreateProcess(nil, PChar(Path), nil, nil, False, 0, nil, nil,
    SI, PI);
  if Result then
  begin
    Application.MainForm.Hide;
    while GetExitCodeProcess(PI.hProcess, ExitCode) and
      (ExitCode = STILL_ACTIVE) do
      ; // ждем завершения, пустой цикл
    Application.MainForm.Show;
  end;
end;

Как запустить приложение и подождать пока оно отработает 8.

Автор: Elena_tark WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Дождаться завершение внешнего приложения
Дожидается завершения внешнего процесса
Зависимости: shellAPI
Автор:       elena_tark, elena_tark@freemail.ru, Калуга
Copyright:   Собственное
Дата:        1 августа 2003 г.
***************************************************** }
procedure ShellExec(Sender: TObject);
var
  ProcInfo: PShellExecuteInfo;
begin
  (Sender as TControl).Enabled := False;
  GetMem(ProcInfo, SizeOf(ProcInfo^));
  with ProcInfo^ do
  begin
    Wnd := Handle;
    cbSize := SizeOf(ProcInfo^);
    lpFile := PChar('notepad.exe');
    lpParameters := nil;
    lpVerb := 'open';
    nShow := SW_SHOW;
    fMask := SEE_MASK_DOENVSUBST or SEE_MASK_NOCLOSEPROCESS;
  end;
  try
    Win32check(ShellExecuteEx(ProcInfo));
    while not Application.Terminated and
      (WaitForSingleObject(ProcInfo.hProcess, 100) = WAIT_TIMEOUT) do
      Application.ProcessMessages;
  finally
    if ProcInfo.hProcess <> 0 then
      CloseHandle(ProcInfo.hProcess);
    Dispose(ProcInfo);
    (Sender as TControl).Enabled := True;
  end;
end;

Запуск программы и ожидание завершения определенное время.

Автор: Kostas WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Запуск программы и ожидание завершения опр.время
Запускает внешнюю программу и ожидает его завершения определённое время,
если истекает время то, программа продолжает работу не зависимо от
состояния внешней программы (На случай подвисания вн. прог-мы, особенно DOS)
Зависимости: Windows
Автор:       Kostas, kostas@tut.by, РБ Гомельская обл. г. Речица
Copyright:   вроде delphi.mastak.ru (слегка доработанно)
Дата:        03 мая 2002 г.
***************************************************** }
function ExecAndWait(aCmd: string; WaitTimeOut: cardinal = INFINITE): Cardinal;
var
  si: STARTUPINFO;
  pi: PROCESS_INFORMATION;
  res: BOOL;
  r: cardinal;
begin
  with si do
  begin
    cb := sizeof(si);
    lpReserved := nil;
    lpDesktop := nil;
    lpTitle := PChar('External program "' + aCmd + '"');
    dwFlags := 0;
    cbReserved2 := 0;
    lpReserved2 := nil;
  end;
  res := CreateProcess(nil, PChar(aCmd), nil, nil, FALSE, 0, nil, nil, si, pi);
  if res then
    WaitForSingleObject(pi.hProcess, WaitTimeOut);
  GetExitCodeProcess(pi.hProcess, r);
  result := r;
end;
// Пример использования:
procedure Exec(CommandStr, WaitTime);
begin
  if ExecAndWait(CommandStr, WaitTime) = WAIT_FAILED then
    ShowMessage('Истекло время ожидания внешней программы ' + CommandStr);
end;

Запуск программы и ожидание ее окончания, принудительное завершение если Timeout.

Автор: August WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Запуск программы и ожидание ее окончания, принудительное завершение если timeout
Функция создавалась для запуска и сопровождения приложения в указаном интервале времени.
Я лично для наблюдения за работой приложения включил функцию в нить,
которая (обрывалась) по завершении процесса.
Зависимости: Classes, SysUtils, Windows, strUtils, Consts;
Автор:       August, august@torba.com, ICQ:176381214
Copyright:   doctorAugust
Дата:        5 февраля 2003 г.
***************************************************** }
function ExecuteFileTm(FileName: string; Params: string; Dsk: boolean; TimeOut:
  cardinal): boolean;
var
  Res: LongBool;
  PIn: PROCESS_INFORMATION;
  SII: STARTUPINFO;
  RetCode: cardinal;
  TmOut: cardinal; //In seconds
  i: cardinal;
  CreationsFlags: cardinal;
begin
  TmOut := TimeOut;
  try
    if Dsk then
    begin
      CreationsFlags := CREATE_DEFAULT_ERROR_MODE or NORMAL_PRIORITY_CLASS
        or CREATE_UNICODE_ENVIRONMENT;
    end
    else
    begin
      CreationsFlags := CREATE_DEFAULT_ERROR_MODE or CREATE_NO_WINDOW
        or NORMAL_PRIORITY_CLASS
        or CREATE_UNICODE_ENVIRONMENT;
    end;
    getstartupinfo(SII);
    Res := createprocess(
      pchar(FileName),
      pchar(Params),
      nil,
      nil,
      True,
      CreationsFlags,
      nil,
      pchar(extractfilepath(FileName)),
      SII,
      PIn);
  except
    CloseHandle(Pin.hProcess);
    ExecuteFileTm := False;
    exit;
  end;
  if not Res then
  begin
    CloseHandle(Pin.hProcess);
    ExecuteFileTm := False;
    exit;
  end;
  i := 0;
  RetCode := STILL_ACTIVE;
  while (i <= TmOut) and (RetCode = STILL_ACTIVE) do
  begin
    try
      GetExitCodeProcess(Pin.hProcess, RetCode);
    except
      CloseHandle(Pin.hProcess);
      ExecuteFileTm := False;
      exit;
    end;
    Sleep(1000);
    inc(i);
  end;
  if (i > TmOut) and (RetCode = STILL_ACTIVE) then
  begin
    TerminateProcess(Pin.hProcess, RetCode);
    CloseHandle(Pin.hProcess);
    // ExecuteFilePrExt:=false;
    ExecuteFileTm := false; // ION T
    exit;
  end;
  CloseHandle(Pin.hProcess);
  ExecuteFileTm := True;
end;

Пример запуска макроса в MS Word.

...      
vvWord:= CreateOleObject('Word.Application.8');  
vvWord.Application.Visible:=true;  
vvWord.Documents.Open( TempFileName );  
vvWord.ActiveDocument.SaveAs( FileName, 1 ); // as .DOC  
vvWord.Application.Run( 'Macros Name' );  
...

Русификация консольных приложений в Delphi.

С периодичностью раз в месяц-полтора конференция RU.DELPHI оглашается стонами на тему “Консоль не поет по-русски”, за которыми стоит вывод текста в консольных приложениях в кодировке OEM (Delphi IDE, как и все GUI, работает в ANSI).

С точки зрения набора символов эти кодовых таблицы не совпадают: позиции символов кириллицы в них различны (отсюда и неприятные эффекты), кроме того, в ANSI присутствуют диакритические символы, которых нет в OEM, но в последней имеются символы псевдографики, незаменимые при изображении таблиц (интересно, это еще кем-то востребовано? На ум приходит только FAR). Впрочем, возможности для вывода текстовой информации у этих таблиц одинаковы, что в нашем случае позволяет говорить о взаимозаменяемости.

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

Работа в OEM-редакторе. Вместо борьбы с выводом «не тех» символов можно пойти иным путем – изначально готовить текст программы (точнее те его части, которые критичны к кодовой таблице) в редакторе, работающем в кодировке OEM. Решение простенькое, но на удивление эффективное, особенно при написании каких-либо локальных утилит, в которых, тем не менее, сильно востребован вывод информации.

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

Если же проект не содержит hard-coded (включенных непосредственно в код) строк, то возможно организовать вынесение всех строковых ресурсов в отдельные модули с последующей их локализацией под требуемую кодировку – утилит, меняющих кодировку файлов существует предостаточно.

Использование фильтрующих процедур. Windows API содержит функции для преобразования между кодировками OEM и ANSI OemToChar, CharToOem, которые и предлагается использовать при выводе текста, заменяя фрагменты.

Writeln('Delphi World - это круто!!!');

На:

procedure MyWriteln(const S: string);
var
  NewStr: string;
begin
  SetLengtn(NewStr, Length(S));
  CharToOem(PChar(S), PChar(NewStr));
  Writeln(NewStr);
end;
...
MyWriteln('Delphi World - это круто!!!');

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

Изменение кодовой страницы консоли. В принципе, для решения задачи есть документированный способ – изменение кодовой страницы консоли средствами Windows API. Проблема лишь в том, что в Win95/98 функция не работает. Впрочем, если приложение будет работать только в Windows NT, можно воспользоваться функцией SetConsoleOutputCP(866).

Перекрытие процедур вывода в RTL. Вывод в Pascal (еще в версиях от Borland для DOS) через Write-процедуры осуществляется посредством передачи выводимой информации в файл Output, который вполне можно подвергнуть легкой модификации с целью упростить себе жизнь.

Известно, что Write/Writeln без указания файла осуществляет вывод в файл Output. Output имеет тип TextFile, он же TTextRec, содержимое которого описано в SysUtils.pas. Есть там и поля, содержащие адреса процедур, в которые приходит на обработку поток выводимых приложением данных (в случае вывода). Не вдаваясь в подробности (желающие могут посмотреть устройство механизмов вывода в исходниках RTL), покажем, что происходит в процедуре, отвечающей за вывод (TTextRec.InOutFunc):

{ Реконструкция TextOut из Assign.asm }
function TextOut(var Text: TTextRec): Integer;
var
  Dummy: Cardinal;
  SavePos: Integer;
begin
  SavePos := Text.BufPos;
  if SavePos > 0 then
  begin
    Text.BufPos := 0;
    if WriteFile(Text.Handle, Text.BufPtr^, SavePos, Dummy, nil) then
      Result := 0
    else
      Result := GetLastError;
  end
  else
    Result := 0;
end;

Теперь видно, что нужно сделать для вывода символов в нужной кодовой таблице – перед выводом в файл средствами ОС модифицировать данные в выходном буфере структуры Text, вписав следующую строку:

CharToOemBuff(Text.BufPtr, Text.BufPtr, SavePos);

Модифицировать буфер можно, т.к. после операции записи в файл содержимое буфера фактически сбрасывается (когда в Text.BufPos записывается 0 – именно столько актуальных данных остается в буфере). Если не завязываться на эту особенность реализации, можно распределить буфер и модифицировать данные уже в нем. Впрочем, решение в любом случае достаточно сильно опирается на особенности реализации, поэтому проверить его пригодность при смене версии Delphi рекомендуется в любом случае. С другой стороны, вероятность отхода Borland от наработанного решения крайне мала.

Заметим, что кроме InOutFunc вывод в файл ОС происходит и в FlushFunc, которая в файле Output указывает на ту же функцию, что и InOutFunc. С учетом всего вышесказанного модуль, осуществляющий «русификацию» консольных приложений «на лету» будет совсем небольшим:

{
Модуль “русификации“ консольных приложений
(c) Eugene Kasnerik, 1999
e-mail: eugene1975@mail.ru
}
unit EsConsole;
interface
implementation
uses
  Windows;
{
Описание структуры приведено здесь с единственной целью –
не подключать SysUtils и, соответственно, код инициализации
этого модуля. Консольные приложения обычно малы и 25К кода
обработки исключений – несколько высокая плата за описание
единственной структуры.
}
type
  TTextRec = record
    Handle: Integer;
    Mode: Integer;
    BufSize: Cardinal;
    BufPos: Cardinal;
    BufEnd: Cardinal;
    BufPtr: PChar;
    OpenFunc: Pointer;
    InOutFunc: Pointer;
    FlushFunc: Pointer;
    CloseFunc: Pointer;
    UserData: array[1..32] of Byte;
    name: array[0..259] of Char;
    Buffer: array[0..127] of Char;
end;
function ConOutFunc(var Text: TTextRec): Integer;
var
  Dummy: Cardinal;
  SavePos: Integer;
begin
  SavePos := Text.BufPos;
  if SavePos > 0 then
  begin
    Text.BufPos := 0;
    CharToOemBuff(Text.BufPtr, Text.BufPtr, SavePos);
    if WriteFile(Text.Handle, Text.BufPtr^, SavePos, Dummy, nil) then
      Result := 0
    else
      Result := GetLastError;
  end
  else
    Result := 0;
end;
initialization
  Rewrite(Output); // Проводим инициализацию файла
  { И подменяем обработчики. Есть в этом что-то от
  хака, но цель оправдывает средства }
  TTextRec(Output).InOutFunc := @ConOutFunc;
  TTextRec(Output).FlushFunc := @ConOutFunc;
end.

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

Выравнивание текста по ширине с автоматическим переносом русских слов.

Оформил: DeeCo

Автор: Антон Григорьев.

Краткое описание :

Примечание:

Вставка рисунка в TRxRichEdit.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

uses
   RichEdit;
 // Stream Callback function 
type
   TEditStreamCallBack = function(dwCookie: Longint; pbBuff: PByte;
     cb: Longint; var pcb: Longint): DWORD;
   stdcall;
   TEditStream = record
     dwCookie: Longint;
     dwError: Longint;
     pfnCallback: TEditStreamCallBack;
   end;
 // RichEdit Type 
type
   TMyRichEdit = TRxRichEdit;
 // EditStreamInCallback callback function 
function EditStreamInCallback(dwCookie: Longint; pbBuff: PByte;
   cb: Longint; var pcb: Longint): DWORD; stdcall;
   // by P. Below 
var
   theStream: TStream;
   dataAvail: LongInt;
 begin
   theStream := TStream(dwCookie);
   with theStream do
   begin
     dataAvail := Size - Position;
     Result := 0;
     if dataAvail <= cb then
     begin
       pcb := read(pbBuff^, dataAvail);
       if pcb <> dataAvail then
         Result := UINT(E_FAIL);
     end
     else
     begin
       pcb := read(pbBuff^, cb);
       if pcb <> cb then
         Result := UINT(E_FAIL);
     end;
   end;
 end;
 // Insert Stream into RichEdit 
procedure PutRTFSelection(RichEdit: TMyRichEdit; SourceStream: TStream);
   // by P. Below 
var
   EditStream: TEditStream;
 begin
   with EditStream do
   begin
     dwCookie := Longint(SourceStream);
     dwError := 0;
     pfnCallback := EditStreamInCallBack;
   end;
   RichEdit.Perform(EM_STREAMIN, SF_RTF or SFF_SELECTION, Longint(@EditStream));
 end;
 // Convert Bitmap to RTF Code 
function BitmapToRTF(pict: TBitmap): string;
 // by D3k 
var
   bi, bb, rtf: string;
   bis, bbs: Cardinal;
   achar: ShortString;
   hexpict: string;
   I: Integer;
 begin
   GetDIBSizes(pict.Handle, bis, bbs);
   SetLength(bi, bis);
   SetLength(bb, bbs);
   GetDIB(pict.Handle, pict.Palette, PChar(bi)^, PChar(bb)^);
   rtf := '{\rtf1 {\pict\dibitmap ';
   SetLength(hexpict, (Length(bb) + Length(bi)) * 2);
   I := 2;
   for bis := 1 to Length(bi) do
   begin
     achar := Format('%x', [Integer(bi[bis])]);
     if Length(achar) = 1 then
       achar := '0' + achar;
     hexpict[I - 1] := achar[1];
     hexpict[I] := achar[2];
     Inc(I, 2);
   end;
   for bbs := 1 to Length(bb) do
   begin
     achar := Format('%x', [Integer(bb[bbs])]);
     if Length(achar) = 1 then
       achar := '0' + achar;
     hexpict[I - 1] := achar[1];
     hexpict[I] := achar[2];
     Inc(I, 2);
   end;
   rtf := rtf + hexpict + ' }}';
   Result := rtf;
 end;
 // Example to insert image from Image1 into RxRichEdit1 
procedure TForm1.Button1Click(Sender: TObject);
 var
   SS: TStringStream;
   BMP: TBitmap;
 begin
   BMP := TBitmap.Create;
   BMP := Image1.Picture.Bitmap;
   SS  := TStringStream.Create(BitmapToRTF(BMP));
   try
     PutRTFSelection(RxRichEdit1, SS);
   finally
     SS.Free;
   end;
 end;

Сохранение типа списка объектов.

unit Dates;
interface
uses
  SysUtils, Classes;
type
  TDate = class (TComponent)
  private
    FMonth, FDay, FYear: Integer;
    FOnChange: TNotifyEvent;
  protected
    function DaysInMonth: Integer;
    procedure SetMonth (Value: Integer);
    procedure SetYear (Value: Integer);
    procedure SetDay (Value: Integer);
    procedure DoChange; virtual;
  public
    constructor Create (AOwner: TComponent); override;
    constructor Init (m, d, y: Integer);
    procedure SetValue (m, d, y: Integer);
    function LeapYear: Boolean;
    procedure Increase;
    procedure Decrease;
    procedure Add (NumberOfDays: Integer);
    procedure Subtract (NumberOfDays: Integer);
    function GetText: string;
    // properties:
    property Text: string read GetText;
  published
    property Day: Integer read FDay write SetDay;
    property Month: Integer read FMonth write SetMonth;
    property Year: Integer read FYear write SetYear;
    // event:
    property OnChange: TNotifyEvent
      read FonChange write FOnChange;
  end;
// dates exception
type
  EDateOutOfRange = class (Exception);
procedure Register;
implementation
constructor TDate.Create (AOwner: TComponent);
var
  Y, D, M: Word;
begin
  inherited Create (AOwner);
  // today...
  DecodeDate (Now, Y, M, D);
  FYear := Y;
  FMonth := M;
  FDay := D;
end;
constructor TDate.Init (m, d, y: Integer);
begin
  SetValue (m, d, y);
end;
procedure TDate.DoChange;
begin
  if Assigned (FOnChange) then
    FOnChange (self);
end;
procedure TDate.SetValue (m, d, y: Integer);
var
  OldY, OldM: Integer;
begin
  // store the old value
  OldY := FYear;
  OldM := FMonth;
  // assing the new value
  try
    FYear := y;
    // check the ranges
    SetMonth (m);
    SetDay (d);
    DoChange;
  except
    on EDateOutOfRange do
    begin
      // reset the values
      FYear := OldY;
      FMonth := OldM;
      // let the error show up
      raise;
    end;
  end;
end;
procedure TDate.SetMonth (Value: Integer);
begin
  if (Value >= 1) and (Value <= 12) then
  begin
    FMonth := Value;
    DoChange;
  end
  else
    raise EDateOutOfRange.Create ('Month out of range');
end;
procedure TDate.SetYear (Value: Integer);
begin
  FYear := Value;
  DoChange;
end;
procedure TDate.SetDay (Value: Integer);
begin
  if (Value >= 1) and (Value <= DaysInMonth) then
  begin
    FDay := Value;
    DoChange;
  end
  else
    raise EDateOutOfRange.Create ('Day out of range');
end;
function TDate.LeapYear: Boolean;
begin
  // compute leap years, considering "exceptions"
  if (FYear mod 4 <> 0) then
    LeapYear := False
  else if (FYear mod 100 <> 0) then
    LeapYear := True
  else if (FYear mod 400 <> 0) then
    LeapYear := False
  else
    LeapYear := True;
end;
function TDate.DaysInMonth: Integer;
begin
  case FMonth of
    1, 3, 5, 7, 8, 10, 12:
      DaysInMonth := 31;
    4, 6, 9, 11:
      DaysInMonth := 30;
    2:
      if (LeapYear) then
        DaysInMonth := 29
      else
        DaysInMonth := 28;
    else
      // if the month is not correct
      DaysInMonth := 0;
  end;
end;
procedure TDate.Increase;
begin
  // if this day is not the last of the month
  if FDay < DaysInMonth then
    Inc (FDay) // increase the value by 1
  else
  // if it is not in December
    if FMonth < 12 then
    begin
      // Day 1 of next month
      Inc (FMonth);
      FDay := 1;
    end
    else
    begin
      // else it is next year New Year's Day
      Inc (FYear);
      FMonth := 1;
      FDay := 1;
    end;
  DoChange;
end;
// exactly the reverse of the Increase method
procedure TDate.Decrease;
begin
  if FDay > 1 then
    Dec (FDay) // decrease the value by 1
  else
    // it is the first of a month
    if FMonth > 1 then
    begin
      // assign last day of previous month
      Dec (FMonth);
      FDay := DaysInMOnth;
    end
    else
    // it is the first of January
    begin
      // assign last day of previous year
      Dec (FYear);
      FMonth := 12;
      FDay := DaysInMOnth;
    end;
  DoChange;
end;
function TDate.GetText: string;
begin
  GetText :=  Format ('%s %d, %d',
    [LongMonthNames[Month], Day, Year]);
end;
procedure TDate.Add (NumberOfDays: Integer);
var
  N: Integer;
begin
  // increase the day n times
  for N := 1 to NumberOfDays do
    Increase;
end;
procedure TDate.Subtract (NumberOfDays: Integer);
var
  N: Integer;
begin
  // decrease the day n times
  for N := 1 to NumberOfDays do
    Decrease;
end;
procedure Register;
begin
  RegisterComponents ('Md3', [TDate]);
end;
end.

unit SList;
interface
uses
  Classes;
type
  TSafeList = class
  private
    LType: TClass;
    FList: TList;
    function Get (Index: Integer): TObject;
    procedure Put (Index: Integer; Item: TObject);
    function GetCount: Integer;
  public
    constructor Create (CType: TClass);
    destructor Destroy; override;
    function Add (Item: TObject): Integer;
    function Equals(List: TSafeList): Boolean;
    property Count: Integer read GetCount;
    property Items [Index: Integer]: TObject
      read Get write Put; default;
  end;
implementation
uses
   SysUtils;
constructor TSafeList.Create (CType: TClass);
begin
  FList := TList.Create;
  LType := CType;
end;
destructor TSafeList.Destroy;
begin
  FList.Free;
  inherited Destroy;
end;
function TSafeList.Get(Index: Integer): TObject;
begin
  Result := FList [Index];
end;
function TSafeList.Add (Item: TObject): Integer;
var
  Test: Boolean;
begin
  try
    Test := Item is LType;
  except
    on Exception do
      raise EInvalidCast.Create (Format (
        'SafeList: Cannot add a non-object to a list of %s objects',
        [LType.ClassName]));
  end;
  if Test then
    Result := FList.Add (Item)
  else
    raise EInvalidCast.Create (Format (
      'SafeList: Cannot add a %s object to a list of %s objects',
      [Item.ClassName, LType.ClassName]));
end;
procedure TSafeList.Put(Index: Integer; Item: TObject);
var
  Test: Boolean;
begin
  try
    Test := Item is LType;
  except on Exception do
    raise EInvalidCast.Create (Format (
      'SafeList: Cannot put a non-object into a list of %s objects',
      [LType.ClassName]));
  end;
  if Test then
    FList [Index] := Item
  else
    raise EInvalidCast.Create (Format (
      'SafeList: Cannot put a %s object into a list of %s objects',
      [TObject(Item).ClassName, LType.ClassName]));
end;
function TSafeList.GetCount: Integer;
begin
  Result := FList.Count;
end;
function TSafeList.Equals(List: TSafeList): Boolean;
var
  I: Integer;
begin
  Result := False;
  if List.Count <> FList.Count then
    Exit;
  for I := 0 to List.Count - 1 do
    if List[I] <> FList[I] then
      Exit;
  Result := True;
end;
end.

unit SafeForm;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, SList;
type
  TForm1 = class(TForm)
    ButtonAddDates: TButton;
    ButtonAddButton: TButton;
    ButtonAddPointer: TButton;
    ButtonNewDate: TButton;
    ListBox1: TListBox;
    ButtonNewButton: TButton;
    ButtonNewPointer: TButton;
    procedure ButtonAddDatesClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure ButtonAddButtonClick(Sender: TObject);
    procedure ButtonAddPointerClick(Sender: TObject);
    procedure ButtonNewDateClick(Sender: TObject);
    procedure ButtonNewButtonClick(Sender: TObject);
    procedure ButtonNewPointerClick(Sender: TObject);
  private
    List: TSafeList;
  public
    procedure UpdateList;
  end;
var
  Form1: TForm1;
implementation
{$R *.DFM}
uses
  Dates;
procedure TForm1.ButtonAddDatesClick(Sender: TObject);
var
  I: Integer;
begin
  Randomize;
  try
    for I := 1 to 10 do
      List.Add (TDate.Init (
        1 + Random (12), 1 + Random (28),
        1900 + Random (200)));
  finally
    UpdateList;
  end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
  List := TSafeList.Create (TDate);
end;
procedure TForm1.ButtonAddButtonClick(Sender: TObject);
begin
  List.Add (Sender);
  UpdateList;
end;
procedure TForm1.ButtonAddPointerClick(Sender: TObject);
var
  P: Pointer;
begin
  P := @Form1;
  List.Add (P);
  UpdateList;
end;
procedure TForm1.UpdateList;
var
  I: Integer;
begin
  ListBox1.Clear;
  for I := 0 to List.Count - 1 do
    Listbox1.Items.Add ((
      TDate(List [I]).GetText));
end;
procedure TForm1.ButtonNewDateClick(Sender: TObject);
begin
  List [1] := TDate.Create (self);
  UpdateList;
end;
procedure TForm1.ButtonNewButtonClick(Sender: TObject);
begin
  List [1] := Sender;
  UpdateList;
end;
procedure TForm1.ButtonNewPointerClick(Sender: TObject);
var
  S: String;
begin
  S := 'Hi';
  List [1] := Pointer(S);
  UpdateList;
end;
end.

Загрузить весь проект

Как определить, что два слова имеют схожее произношение.

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

function Soundex(OriginalWord: string): string;
var
  Tempstring1, Tempstring2: string;
  Count: integer;
begin
  Tempstring1 := '';
  Tempstring2 := '';
  OriginalWord := Uppercase(OriginalWord);
    {Переводим исходное слово в верхний регистр}
  Appendstr(Tempstring1, OriginalWord[1]); {Используем первую букву слова}
  for Count := 2 to length(OriginalWord) do
    {Назначаем числовое значение каждой букве, за исключением первой}
    case OriginalWord[Count] of
      'B', 'F', 'P', 'V': Appendstr(Tempstring1, '1');
      'C', 'G', 'J', 'K', 'Q', 'S', 'X', 'Z': Appendstr(Tempstring1, '2');
      'D', 'T': Appendstr(Tempstring1, '3');
      'L': Appendstr(Tempstring1, '4');
      'M', 'N': Appendstr(Tempstring1, '5');
      'R': Appendstr(Tempstring1, '6');
      {Все другие буквы, цифры и знаки пунктуации игнорируются}
    end;
  Appendstr(Tempstring2, OriginalWord[1]);
  {Удаляем из результата все последовательно повторяющиеся цифры.}
  for Count := 2 to length(Tempstring1) do
    if Tempstring1[Count - 1] <> Tempstring1[Count] then
      Appendstr(Tempstring2, Tempstring1[Count]);
  Soundex := Tempstring2; {Это - значение soundex}
end;

SoundAlike - функция, проверяющая схожесть звучания двух слов. При схожести звучания она возвратит значение True и значение False в противном случае. Она демонстрирует пример использования функции Soundex.

function SoundAlike(Word1, Word2: string): boolean;
begin
  if (Word1 = '') and (Word2 = '') then
    result := True
  else if (Word1 = '') or (Word2 = '') then
    result := False
  else if (Soundex(Word1) = Soundex(Word2)) then
    result := True
  else
    result := False;
end;

    Андрей vs. Андрей - 6
    ндрей vs. Андрей - 5
    Анрей vs. Андрей - 5
    Андрей vs. Александр - 4
    Андрей vs. Иннокентий - 2
    АнХрей vs. Андрей - 3, но в то же время с другими словами результат
будет на уровне 0..2

O сохранении иконок 32хЗ2 в 256-цветном формате.

Кроме того, введено определение размера рисунка и если он не 32хЗ2, то процедура прекратит работу. Это произойдет и в случае если кому-то захочется использовать более 256 цветов. Тем, кто хочет узнать о структуре файлов ICO, читать после кода процедуры. Используя этот метод можно работать с любыми файлами, например, для открытия и побайтного изменения EXE-файлов. Для работы этой процедуры нужен рисунок 32хЗ2 на канве (у меня Image2), диалоговое окно SaveDialog1 (но не SavePictureDialog1) и все. Если нужно, измените имя канвы, оно встречается в двух строчках кода, и имя диалогового окна. Процедура с комментариями ниже:

//Записываем картинку как иконку (файл .ico)
{Так как стандартные функции не дают возможности создавать 256 цветные
иконки, мы пойдем другим путем, хоть он и медленнее и длиннее.
Создадим массив байт, который запишем как файл, это и будет
искомая иконка. Для этого создадим промежуточные массивы, иначе процедура
станет слишком навороченной, затем проверим количество используемых цветов
и, в зависимости от этого, создадим окончательный массив.}
procedure TForm1.ToolButton6Click(Sender: TObject);
var
  MAnd, MXor, MOsn, MCol: array of Byte;
  MPix, MOrg: array of TColor;
  a, b, c, n, m: integer;
  Bt, Bu, Indicator: Byte;
  p: TColor;
  k: boolean;
  F: file;
  LenOsn, LenXor, LenCol: integer;
begin
  if (Image2.Picture.Height <> 32) or (Image2.Picture.Width <> 32) then
  begin
    ShowMessage('Исходный рисунок не 32хЗ2');
    exit;
  end;
  {Создание массивов: MAnd - массив маски AND, MXor - массив маски Xor,
  основного массива MOsn - куда будет собираться вся информация,
  массив MPix - массив пикселов рисунка начиная с левого нижнего угла,
  MCol - массив таблицы цветов - палитры, MOrg - массив оригинальных цветов}
  {Заполнение массивов MPix и MAnd}
  {Активизация массивов}
  SetLength(MPix, 1024);
  SetLength(MAnd, 128);
  {Установка счетчиков}
  b := 0; //Счетчик битов
  a := 0; //Счетчик пикселов картинки
  c := 0; //Счетчик байтов маски MAnd
  Bt := 0; //Формируемый байт маски MAnd
  {Преобразование картинки в удобный формат, с началом от 0,
  и перенос ее в таком виде в массив MPix, меняя по пути белый -
  будущий прозрачный цвет - на черный, заодно заполняем массив MAnd}
  for m := 31 downto 0 do
    for n := 0 to 31 do
    begin
      MPix[a] := Image2.Canvas.Pixels[n, m];
      p := MPix[a];
      if p = RGB(255, 255, 255) then
      begin
        MPix[a] := RGB(0, 0, 0);
        if b = 0 then
          Bt := Bt + 128;
        if b = 1 then
          Bt := Bt + 64;
        if b = 2 then
          Bt := Bt + 32;
        if b = 3 then
          Bt := Bt + 16;
        if b = 4 then
          Bt := Bt + 8;
        if b = 5 then
          Bt := Bt + 4;
        if b = 6 then
          Bt := Bt + 2;
        if b = 7 then
          Bt := Bt + 1;
      end;
      b := b + 1;
      if b = 8 then
      begin
        MAnd[c] := Bt;
        Bt := 0;
        c := c + 1;
        b := 0;
      end;
      a := a + 1;
    end;
  {Заполнение маски MOrg нулями, предполагая 256 цветов}
  SetLength(MOrg, 256);
  for n := 0 to 255 do
    MOrg[n] := RGB(255, 255, 255);
  {Оцениваем количество цветов и от результата переделываем MOrg}
  a := 0; //Счетчик количества цветов
  for n := 0 to 1023 do
  begin
    p := MPix[n];
    k := false;
    for m := 0 to 255 do
    begin
      if k = false then
        if p = MOrg[m] then
          k := true;
    end;
    if k = false then
    begin
      if a > 255 then
      begin
        ShowMessage('Ваш рисунок имеет более 256 цветов');
        MOrg := nil;
        MPix := nil;
        MAnd := nil;
        exit;
      end;
      MOrg[a] := p;
      a := a + 1;
    end;
  end;
  LenOsn := 2238;
  LenXor := 1024;
  LenCol := 1024;
  Indicator := 1;
  if a < 15 then
  begin
    LenOsn := 766;
    LenXor := 512;
    Indicator := 0;
  end;
  {Заполняем маски нулями}
  SetLength(MXor, LenXor);
  SetLength(MCol, LenCol);
  for n := 0 to LenXor - 1 do
  begin
    MXor[n] := 0;
  end;
  for n := 0 to LenCol - 1 do
  begin
    MCol[n] := 0;
  end;
  {Заполнение массива MXor согласно массива MPix}
  Bu := 0;
  b := 0;
  c := 0;
  for n := 0 to 1023 do
  begin
    p := MPix[n];
    k := false;
    for Bt := 0 to 255 do
    begin
      if k = false then
        if p = MOrg[Bt] then
        begin
          k := true;
          if indicator = 1 then
            MXor[n] := Bt
          else if b = 1 then
          begin
            Bu := 16 * Bu + Bt;
            MXor[c] := Bu;
            c := c + 1;
            b := 0;
          end
          else
          begin
            Bu := Bt;
            b := 1;
          end;
        end;
    end;
  end;
  {Заполняем массив MCol согласно массива MOrg}
  begin
    a := 0;
    for n := 0 to 255 do
    begin
      p := MOrg[n];
      MCol[a] := GetBValue(p);
      MCol[a + 1] := GetGValue(p);
      MCol[a + 2] := GetRValue(p);
      a := a + 4;
    end;
  end;
  {Заполняем MOsn нулями}
  SetLength(MOsn, LenOsn);
  for n := 0 to LenOsn - 1 do
    MOsn[n] := 0;
  {Заполняем массив MOsn для 256 цветной иконки}
  if indicator = 1 then
  begin
    MOsn[2] := 1;
    MOsn[4] := 1;
    MOsn[6] := 32;
    MOsn[7] := 32;
    MOsn[14] := $A8;
    MOsn[15] := 8;
    MOsn[18] := $16;
    MOsn[22] := $28;
    MOsn[26] := 32;
    MOsn[30] := $40;
    MOsn[34] := 1;
    MOsn[36] := 8;
    MOsn[42] := $80;
    MOsn[43] := 4;
    MOsn[55] := 1;
    m := 0;
    for n := 62 to 1085 do
    begin
      MOsn[n] := MCol[m];
      m := m + 1;
    end;
    m := 0;
    for n := 1086 to 2109 do
    begin
      MOsn[n] := MXor[m];
      m := m + 1;
    end;
    m := 0;
    for n := 2110 to 2237 do
    begin
      MOsn[n] := MAnd[m];
      m := m + 1;
    end;
  end;
  {Заполняем массив MOsn для 16-цветной}
  if indicator = 0 then
  begin
    MOsn[2] := 1;
    MOsn[4] := 1;
    MOsn[6] := 32;
    MOsn[7] := 32;
    MOsn[8] := 4;
    MOsn[14] := $E8;
    MOsn[15] := 2;
    MOsn[18] := $16;
    MOsn[22] := $28;
    MOsn[26] := 32;
    MOsn[30] := 64;
    MOsn[34] := 1;
    MOsn[36] := 4;
    MOsn[43] := 2;
    MOsn[54] := 16;
    m := 0;
    for n := 62 to 125 do
    begin
      MOsn[n] := MCol[m];
      m := m + 1;
    end;
    m := 0;
    for n := 126 to 637 do
    begin
      MOsn[n] := MXor[m];
      m := m + 1;
    end;
    m := 0;
    for n := 638 to 765 do
    begin
      MOsn[n] := MAnd[m];
      m := m + 1;
    end;
  end;
  {Закрываем все массивы, кроме MOsn}
  MAnd := nil;
  MXor := nil;
  MOrg := nil;
  MCol := nil;
  MPix := nil;
  {Записываем массив MOsn в файл, для этого создаем нетипизированный файл,
  активизируем его и побайтно пишем в него данные из массива MOsn}
  if SaveDialog1.Execute then
  begin
    AssignFile(f, SaveDialog1.FileName + '.ico');
    Rewrite(f, 1);
    for n := 0 to LenOsn - 1 do
    begin
      Bt := MOsn[n];
      BlockWrite(f, Bt, 1);
    end;
    CloseFile(f);
    MOsn := nil;
  end;
end;

О структуре иконки. Информации немного в интернете, но кое-что я раскопал. Пришлось просмотреть коды разных иконок, чтобы иметь о них представление. Файл ICO очень похож на BMP: в начале файла заголовок BITMAPFILEHEADER, размером обычно 22 байта. В нем содержится информация о файле. За ним идет BITMAPINFOHEADER, 40 байт, содержит информацию о ширине и высоте иконки в пикселах, количество бит на пиксел в структуре картинки, занимаемое место таблицей цветов и другая информация. Для примера оба заголовка для 16-цветной иконки. В квадратных скобках номер байта в файле, далее эго значение.

[2]  := 1;   // Всегда 1 
[4]  := 1;   // Всегда 1 
[6]  := 32;  // Ширина и 
[7]  := 32;  // высота в пикселах? 
[8]  := 4    // Не знаю 
[14] := $E8; // Младший байт размера файла минус 22(размер BITMAPFILEHEADER) 
[15] := 2;   // Старший байт размера файла 
[18] := 22;  // Размер BITMAPFILEHEADER 
[22] := 40;  // Размер заголовка BITMAPINFOHEADER 
[26] := 32;  // Ширина в пикселах 
[30] := 64;  // Высота в пикселах обоих масок в сумме 
[34] := 1;   // Число плоскостей 
[36] := 4;   // бит/пиксел для таблицы пикселов 
[43] := 2;   // Старший байт размера таблицы пикселов (т.е.$200=512) 
[54] := 16;  // Число используемых цветов (не обязательно) 

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

Сохранение и выдёргивание ресурсов в DLL или EXE.

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

Далее рассмотрим, как создать файл ресурсов, содержащий корию какого-либо файла. После создания такого файла его можно легко прицепить к Вашему проекту директивой {$R}. Файл ресурсов, который мы будем создавать имеет следующий формат:

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

Заголовок ресурса выглядит следующим образом:

TResHeader = record
  DataSize: DWORD;        // размер данных
  HeaderSize: DWORD;      // размер этой записи
  ResType: DWORD;         // нижнее слово = $FFFF => ordinal
  ResId: DWORD;           // нижнее слово = $FFFF => ordinal
  DataVersion: DWORD;     // *
  MemoryFlags: WORD;
  LanguageId: WORD;       // *
  Version: DWORD;         // *
  Characteristics: DWORD; // *
end;

Поля помеченны звёздочкой Мы не будем использовать.

Приведённый код создаёт файл ресурсов и копирует его в данный файл:

procedure CreateResourceFile(
  DataFile, ResFile: string; // имена файлов
  ResID: Integer // id ресурсов
  );
var
  FS, RS: TFileStream;
  FileHeader, ResHeader: TResHeader;
  Padding: array [0..SizeOf(DWORD)-1] of Byte;
begin
  { Open input file and create resource file }
  FS := TFileStream.Create( // для чтения данных из файла
  DataFile, fmOpenRead);
  RS := TFileStream.Create( // для записи файла ресурсов
  ResFile, fmCreate);
  { Создаём заголовок файла ресурсов - все нули, за исключением
  HeaderSize, ResType и ResID }
  FillChar(FileHeader, SizeOf(FileHeader), #0);
  FileHeader.HeaderSize := SizeOf(FileHeader);
  FileHeader.ResId := $0000FFFF;
  FileHeader.ResType := $0000FFFF;
  { Создаём заголовок данных для RC_DATA файла
  Внимание: для создания более одного ресурса необходимо
  повторить следующий процесс, используя каждый раз различные
  ID ресурсов }
  FillChar(ResHeader, SizeOf(ResHeader), #0);
  ResHeader.HeaderSize := SizeOf(ResHeader);
  // id ресурса - FFFF означает "не строка!"
  ResHeader.ResId := $0000FFFF or (ResId shl 16);
  // тип ресурса - RT_RCDATA (from Windows unit)
  ResHeader.ResType := $0000FFFF
  or (WORD(RT_RCDATA) shl 16);
  // размер данных - есть размер файла
  ResHeader.DataSize := FS.Size;
  // Устанавливаем необходимые флаги памяти
  ResHeader.MemoryFlags := $0030;
  { Записываем заголовки в файл ресурсов }
  RS.WriteBuffer(FileHeader, sizeof(FileHeader));
  RS.WriteBuffer(ResHeader, sizeof(ResHeader));
  { Копируем файл в ресурс }
  RS.CopyFrom(FS, FS.Size);
  { Pad data out to DWORD boundary - any old
  rubbish will do!}
  if FS.Size mod SizeOf(DWORD) <> 0 then
    RS.WriteBuffer(Padding, SizeOf(DWORD) -
    FS.Size mod SizeOf(DWORD));
  { закрываем файлы } 
  FS.Free; 
  RS.Free;
end;

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

Извлечение ресурсов из EXE

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

Вся процедура заключается в создании потока ресурса, создании файлового потока и копировании из потока ресурса в поток файла.

procedure ExtractToFile(Instance:THandle; ResID:Integer; ResType, FileName:string);
var
  ResStream: TResourceStream;
  FileStream: TFileStream;
begin
  try
    ResStream := TResourceStream.CreateFromID(Instance, ResID, pChar(ResType));
    try
      //if FileExists(FileName) then
      //DeleteFile(pChar(FileName));
      FileStream := TFileStream.Create(FileName, fmCreate);
      try
        FileStream.CopyFrom(ResStream, 0);
      finally
        FileStream.Free;
      end;
    finally
      ResStream.Free;
    end;
  except
    on E:Exception do
    begin
      DeleteFile(FileName);
      raise;
    end;
  end;
end;

Всё, что требуется, это получить Instance exe-шника или dll (у Вашего приложения это Application.Instance или Application.Handle, для dll Вам придётся получить его самостоятельно :).

Запись массива на диск.

Скажем, ваша структура данных выглядит следующим образом:

type
  TMyRec = record
    SomeField: Integer;
    SomeOtherField: Double;
    TheRest: array[0..99] of Single;
  end;

И TBlobField имеет имя MyBlobField. TMyRec назван как MyRec. Для копирования содержимого MyRec в MyBlobField необходимо сделать следующее:

var
  Stream: TBlobStream;
begin
  Stream := TBlobStream.Create(MyBlobField, bmWrite);
  Stream.Write(MyRec, SizeOf(MyRec));
  Stream.Free;
end;

Есть другой путь:

var
  Stream: TBlobStream;
begin
  Stream := TBlobStream.Create(MyBlobField, bmRead);
  Stream.Read(MyRec, SizeOf(MyRec));
  Stream.Free;
end;

Сохранение массива c изображениями.

Реализация алгоритма весьма медленна, поэтому если вы имеете или найдете более быстрый алгоритм, пожалуйста, уведомите меня об этом. Если у вас есть любые вопросы, пожалуйста, свяжитесь со мной.

procedure TMainForm.SaveBoard;
var
  MemoryStream: TMemoryStream;
  FileStream: TFileStream;
  Writer: TWriter;
  Buffer: Pointer;
  Size: Longint;
  Column: Integer;
  Row: Integer;
begin
  MemoryStream := TMemoryStream.Create;
  FileStream := TFileStream.Create(SaveFilename, fmCreate);
  Writer := TWriter.Create(FileStream, $1000);
  try
    for Column := 0 to 4 do
      for Row := 0 to 4 do
      begin
        MemoryStream.Clear;
        Bitmaps[Column, Row].SaveToStream(MemoryStream);
        Buffer := MemoryStream.Memory;
        Size := MemoryStream.Size;
        Writer.WriteInteger(Size);
        Writer.Write(Buffer^, Size);
      end;
  finally
    Writer.Free;
    FileStream.Free;
    MemoryStream.Free;
  end;
end;
procedure TMainForm.Open1Click(Sender: TObject);
var
  MemoryStream: TMemoryStream;
  FileStream: TFileStream;
  Buffer: Pointer;
  Reader: TReader;
  Column: Integer;
  Row: Integer;
  Size: Longint;
begin
  OpenDialog2.Filename := SaveFilename;
  if not OpenDialog2.Execute then
    Exit;
  MemoryStream := TMemoryStream.Create;
  FileStream := TFileStream.Create(OpenDialog2.Filename, fmOpenRead);
  Reader := TReader.Create(FileStream, $1000);
  try
    for Column := 0 to 4 do
      for Row := 0 to 4 do
      begin
        Size := Reader.ReadInteger;
        MemoryStream.SetSize(Size);
        Buffer := MemoryStream.Memory;
        Reader.Read(Buffer^, Size);
        Bitmaps[Column, Row].LoadFromStream(MemoryStream);
      end;
  finally
    Reader.Free;
    FileStream.Free;
    MemoryStream.Free;
  end;
  DrawGrid1.Repaint;
  SaveFilename := OpenDialog2.Filename;
  Caption := 'Bingo-создатель - ' + ExtractFilename(SaveFilename);
end;

Сохранить содержимое буфера обмена или потока как картинку.

Напрямую, конечно, нет. вставь в richedit и так:

procedure TForm1.Button1Click(Sender: TObject);
var
  b : tbitmap;
  fr: TFormatRange;
  r : TRect;
begin
  b:=tbitmap.create;
  b.width:=rxrichedit1.width;
  b.height:=rxrichedit1.height;
  r:=rect(0,0,RXRichEdit1.Width*screen.Pixelsperinch,
    RXRichEdit1.Height*screen.Pixelsperinch);
  fr.hdc:=b.Canvas.handle;
  fr.hdctarget:=b.Canvas.handle;
  fr.rc:=r;
  fr.rcpage:=r;
  fr.chrg.cpMin:=0;
  fr.chrg.cpMax:=-1;
  Sendmessage(RXRichEdit1.handle,EM_FORMATRANGE,1,longint(@fr));
  image1.Picture.assign(b);
  b.free;
end;

Сохранение компонента в файле.

Как мне сохранить а потом загрузить целый TListView (ViewStyle=vsReport) со всеми ячейками в файле?

var f: TFileStream;
begin
  f := TFileStream.Create('c:\stream.vcl', fmcreate);
  f.WriteComponent(lb);
  f.Free;
end;
...
var
  f: TFileStream;
begin
  f := TFileStream.Create('c:\stream.vcl', fmOpenRead);
  f.ReadComponent(lvFiles);
  f.Free;

Сохранение состояния ВСЕХ компонентов.

Автор: Святослав WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Сохраняет состояние !!!ВСЕХ!!! компонентов (втч и вложенных, втч TYesOrNoDialog)
на форме в реестр. Знает кучу классов. Очень удобен, напримр, для руссификации приложения
(Создаете *.reg файл, с переведенными property text, caption и т.д.)
TStateSaver.RegistryPath:String - то мето в реестре, куда сохранять.
.WriteTop, .WriteLeft, .WriteHeight, ... :Boolean - сохранять ли соответствующее
Property (нет динамического списка, который можно было бы реализовать, используя
GetFieldAddress, по причине невозможности определить состояние ReadOnly :( )
property OnNewComponentSaving:TSaverEvent read _ONNC write _ONNC;
property OnNewComponentLoading:TSaverEvent read _ONNCL write _ONNCL; - еvеnt'ы
вызывающиеся при сохранении/загрузки состояния какого-то компонента.
Параметр DoIt:Boolean - сохранить/загрузить или нет.
procedure SaveComponentState(C:TComponent; preffix, postfix:String);
procedure LoadComponentState(C:TComponent; preffix, postfix:String);
-сохранить/загрузить состояние всех под-компонентов компонента C.
preffix и postfic - префикс и постфикс имени при сохранении в реестр.
Зависимости: Windows, Messages, SysUtils, Classes, Registry, Dialogs, Controls,
StdCtrls, ExtCtrls, Buttons, UBPFD.YesOrNoDialog, Menus;
Автор:       Святослав, lisin@asicdesign.ru, ICQ:138752432, Saint Petersburg
Copyright:   (C) NetBreaker666[AWD]<SP666>@Svjatoslav_Lisin - т.е. я сам
Дата:        11 августа 2002 г.
***************************************************** }
unit StateSaver;
interface
uses
  Windows, Messages, SysUtils, Classes, Registry, Dialogs, Controls, StdCtrls,
    ExtCtrls, Buttons, YesOrNoDialog, Menus;
type
  TSaverEvent = procedure(Sender: TObject; Target: TComponent; var DoIt: Boolean)
    of object;
  TStateSaver = class(TComponent)
  private
    { Private declarations }
    RegPath: string;
    RegRoot: string;
    RegRootHKEY: HKEY;
    WTOP, WLEFT, WWIDTH, WHEIGHT, WTAG: Boolean;
    WCAPTION, WTEXT, WCOLOR: Boolean;
    WEnabled, WVisible, WChecked: Boolean;
    _ONNC, _ONNCL: TSaverEvent;
    procedure SetRegRoot(S: string);
    procedure SetRegRootHKEY(HK: HKEY);
  protected
    { Protected declarations }
  public
    { Public declarations }
  published
    { Published declarations }
    property RegistryRoot: string read RegROOT write SetRegROOT;
    property RegistryRootHKEY: HKey read RegRootHKEY write SetRegRootHKEY default
      HKEY_CURRENT_USER;
    property RegistryPath: string read RegPath write RegPath;
    property WriteTop: Boolean read WTOP write WTOP;
    property WriteLeft: Boolean read WLeft write WLeft;
    property WriteWidth: Boolean read WWIDTH write WWidth;
    property WriteHeight: Boolean read WHEIGHT write WHeight;
    property WriteCaption: Boolean read WCaption write WCaption;
    property WriteText: Boolean read WText write WText;
    property WriteColor: boolean read WColor write WColor;
    property WriteTag: Boolean read WTAG write WTag;
    property WriteEnabled: Boolean read WEnabled write WEnabled;
    property WriteVisible: Boolean read WVisible write WVisible;
    property WriteChecked: Boolean read WChecked write WChecked;
    property OnNewComponentSaving: TSaverEvent read _ONNC write _ONNC;
    property OnNewComponentLoading: TSaverEvent read _ONNCL write _ONNCL;
    procedure SaveComponentState(C: TComponent; preffix, postfix: string);
    procedure LoadComponentState(C: TComponent; preffix, postfix: string);
  end;
  TUPC = class(TControl)
  public
    property Color;
    property Caption;
    property Text;
  end;
procedure Register;
implementation
procedure Register;
begin
  RegisterComponents('NetBreakers', [TStateSaver]);
end;
procedure TStateSaver.SetRegRoot(S: string);
begin
  S := UpperCase(S);
  if S = 'HKEY_LOCAL_MACHINE' then
  begin
    RegRootHKEY := HKEY_LOCAL_MACHINE;
    RegRoot := S;
    Exit;
  end;
  if S = 'HKEY_CURRENT_USER' then
  begin
    RegRootHKEY := HKEY_CURRENT_USER;
    RegRoot := S;
    Exit;
  end;
  if S = 'HKEY_CLASSES_ROOT' then
  begin
    RegRootHKEY := HKEY_CLASSES_ROOT;
    RegRoot := S;
    Exit;
  end;
  if S = 'HKEY_USERS' then
  begin
    RegRootHKEY := HKEY_USERS;
    RegRoot := S;
    Exit;
  end;
  if S = 'HKEY_PERFORMANCE_DATA' then
  begin
    RegRootHKEY := HKEY_PERFORMANCE_DATA;
    RegRoot := S;
    Exit;
  end;
  if S = 'HKEY_CURRENT_CONFIG' then
  begin
    RegRootHKEY := HKEY_CURRENT_CONFIG;
    RegRoot := S;
    Exit;
  end;
  if S = 'HKEY_DYN_DATA' then
  begin
    RegRootHKEY := HKEY_DYN_DATA;
    RegRoot := S;
    Exit;
  end;
  ShowMessage('Invalid registry key.');
end;
procedure TStateSaver.SetRegRootHKEY(HK: HKEY);
begin
  case HK of
    HKEY_LOCAL_MACHINE:
      begin
        RegRoot := 'HKEY_LOCAL_MACHINE';
      end;
    HKEY_CURRENT_USER:
      begin
        RegRoot := 'HKEY_CURRENT_USER';
      end;
    HKEY_CLASSES_ROOT:
      begin
        RegRoot := 'HKEY_CLASSES_ROOT';
      end;
    HKEY_USERS:
      begin
        RegRoot := 'HKEY_USERS';
      end;
    HKEY_PERFORMANCE_DATA:
      begin
        RegRoot := 'HKEY_PERFORMANCE_DATA';
      end;
    HKEY_CURRENT_CONFIG:
      begin
        RegRoot := 'HKEY_CURRENT_CONFIG';
      end;
    HKEY_DYN_DATA:
      begin
        RegRoot := 'HKEY_DYN_DATA';
      end;
  else
    begin
      ShowMessage('Unknown registry key.');
      Exit;
    end;
  end;
  RegRootHKEY := HK;
end;
procedure TStateSaver.SaveComponentState(C: TComponent; preffix, postfix:
  string);
var
  T: TControl;
  R: TRegistry;
  I: Integer;
  CC: Boolean;
begin
  CC := True;
  if Assigned(_ONNC) then
    _ONNC(self, C, CC);
  if CC then
  begin
    if C is TControl then
    begin
      T := C as TControl;
      R := TRegistry.Create;
      R.RootKey := RegRootHKEY;
      if R.OpenKey(RegPath, True) then
      begin
        try
          if WTOP then
            R.WriteInteger(preffix + C.GetNamePath + '.TOP' + postfix, T.Top);
        except
        end;
        try
          if WEnabled then
            R.WriteBool(preffix + C.GetNamePath + '.Enabled' + postfix,
              T.Enabled);
        except
        end;
        try
          if WVisible then
            R.WriteBool(preffix + C.GetNamePath + '.TOP' + postfix, T.Visible);
        except
        end;
        try
          if WLEFT then
            R.WriteInteger(preffix + C.GetNamePath + '.LEFT' + postfix, T.Left);
        except
        end;
        try
          if WTAG then
            R.WriteInteger(preffix + C.GetNamePath + '.TAG' + postfix, T.Tag);
        except
        end;
        try
          if WHEIGHT then
            R.WriteInteger(preffix + C.GetNamePath + '.HEIGHT' + postfix,
              T.Height);
        except
        end;
        try
          if WWIDTH then
            R.WriteInteger(preffix + C.GetNamePath + '.WIDTH' + postfix,
              T.Width);
        except
        end;
        if WTEXT then
        begin
          try
            R.WriteString(preffix + C.GetNamePath + '.Text' + postfix,
              TUPC(T).Text);
          except
            try
              if T is TCustomEdit then
                R.WriteString(preffix + C.GetNamePath + '.Text' + postfix,
                  TCustomEdit(T).Text);
            except
            end;
          end;
        end;
        if WCOLOR then
        begin
          try
            R.WriteInteger(preffix + C.GetNamePath + '.Color' + postfix,
              Integer(TUPC(T).color));
          except
          end;
        end;
        if WCAPTION then
        begin
          try
            R.WriteString(preffix + C.GetNamePath + '.Caption' + postfix,
              TUPC(T).caption);
          except
            try
              if T is TButton then
                R.WriteString(preffix + C.GetNamePath + '.Caption' + postfix,
                  TButton(T).Caption);
              if T is TCustomLabel then
                R.WriteString(preffix + C.GetNamePath + '.caption' + postfix,
                  TCustomLabel(T).Caption);
              if T is TCheckBox then
                R.WriteString(preffix + C.GetNamePath + '.Caption' + postfix,
                  TCheckBox(T).Caption);
              if T is TRadioButton then
                R.WriteString(preffix + C.GetNamePath + '.Caption' + postfix,
                  TRadioButton(T).Caption);
              if T is TGroupBox then
                R.WriteString(preffix + C.GetNamePath + '.Caption' + postfix,
                  TGroupBox(T).Caption);
              if T is TRadioGroup then
                R.WriteString(preffix + C.GetNamePath + '.Caption' + postfix,
                  TRadioGroup(T).Caption);
              if T is TPanel then
                R.WriteString(preffix + C.GetNamePath + '.Caption' + postfix,
                  TPanel(T).Caption);
              if T is TSpeedButton then
                R.WriteString(preffix + C.GetNamePath + '.Caption' + postfix,
                  TSpeedButton(T).Caption);
              if T is TStaticText then
                R.WriteString(preffix + C.GetNamePath + '.Caption' + postfix,
                  TStaticText(T).Caption);
            except
            end;
          end;
        end;
      end
      else
      begin
        //ShowMessage('Couldn''t open key "'+RegPath+'".');
        Exit;
      end;
      R.Free;
    end
    else
    begin
      if C is TYesOrNoDialog then
      begin
        R := TRegistry.Create;
        R.RootKey := RegRootHKEY;
        if R.OpenKey(RegPath, True) then
        begin
          if WCaption then
            R.WriteString(preffix + C.GetNamePath + '.Caption' + postfix,
              TYesOrNoDialog(C).caption);
          if WText then
            R.WriteString(preffix + C.GetNamePath + '.Text' + postfix,
              TYesOrNoDialog(C).Text);
        end;
        R.Free;
      end;
      if C is TPopupMenu then
      begin
        R := TRegistry.Create;
        R.RootKey := RegRootHKEY;
        if R.OpenKey(RegPath, True) then
        begin
          for I := 0 to TPopupMenu(C).Items.Count - 1 do
          begin
            if WCaption then
              R.WriteString(preffix + C.GetNamePath + '.Item[' + IntToStr(I) +
                '].Caption' + postfix, TPopupMenu(C).Items[I].caption);
            if WEnabled then
              R.WriteBool(preffix + C.GetNamePath + '.Item[' + IntToStr(I) +
                '].Enabled' + postfix, TPopupMenu(C).Items[I].Enabled);
            if WVisible then
              R.WriteBool(preffix + C.GetNamePath + '.Item[' + IntToStr(I) +
                '].Visible' + postfix, TPopupMenu(C).Items[I].Visible);
            if WChecked then
              R.WriteBool(preffix + C.GetNamePath + '.Item[' + IntToStr(I) +
                '].Checked' + postfix, TPopupMenu(C).Items[I].Checked);
          end;
        end;
        R.Free;
      end;
    end;
  end;
  for I := 0 to C.ComponentCount - 1 do
    SaveComponentState(C.Components[i], preffix + C.GetNamePath + '.', postfix);
end;
procedure TStateSaver.LoadComponentState(C: TComponent; preffix, postfix:
  string);
var
  T: TControl;
  R: TRegistry;
  I: Integer;
  CC: Boolean;
begin
  CC := True;
  if Assigned(_ONNCL) then
    _ONNCL(self, C, CC);
  if CC then
  begin
    if C is TControl then
    begin
      T := C as TControl;
      R := TRegistry.Create;
      R.RootKey := RegRootHKEY;
      if R.OpenKey(RegPath, False) then
      begin
        try
          if WTOP then
            if R.ValueExists(preffix + C.GetNamePath + '.TOP' + postfix) then
              T.Top := R.ReadInteger(preffix + C.GetNamePath + '.TOP' +
                postfix);
        except
        end;
        try
          if WEnabled then
            if R.ValueExists(preffix + C.GetNamePath + '.Enabled' + postfix)
              then
              T.Enabled := R.ReadBool(preffix + C.GetNamePath + '.Enabled' +
                postfix);
        except
        end;
        try
          if WVisible then
            if R.ValueExists(preffix + C.GetNamePath + '.TOP' + postfix) then
              T.Visible := R.ReadBool(preffix + C.GetNamePath + '.TOP' +
                postfix);
        except
        end;
        try
          if WLEFT then
            if R.ValueExists(preffix + C.GetNamePath + '.LEFT' + postfix) then
              T.Left := R.ReadInteger(preffix + C.GetNamePath + '.LEFT' +
                postfix);
        except
        end;
        try
          if WTAG then
            if R.ValueExists(preffix + C.GetNamePath + '.TAG' + postfix) then
              T.Tag := R.ReadInteger(preffix + C.GetNamePath + '.TAG' +
                postfix);
        except
        end;
        try
          if WHEIGHT then
            if R.ValueExists(preffix + C.GetNamePath + '.HEIGHT' + postfix) then
              T.Height := R.ReadInteger(preffix + C.GetNamePath + '.HEIGHT' +
                postfix);
        except
        end;
        try
          if WWIDTH then
            if R.ValueExists(preffix + C.GetNamePath + '.WIDTH' + postfix) then
              T.Width := R.ReadInteger(preffix + C.GetNamePath + '.WIDTH' +
                postfix);
        except
        end;
        if WTEXT then
          if R.ValueExists(preffix + C.GetNamePath + '.Text' + postfix) then
          begin
            try
              TUPC(T).Text := R.ReadString(preffix + C.GetNamePath + '.Text' +
                postfix);
            except
              try
                if T is TCustomEdit then
                  TCustomEdit(T).Text := R.ReadString(preffix + C.GetNamePath +
                    '.Text' + postfix);
              except
              end;
            end;
          end;
        if WCOLOR then
          if R.ValueExists(preffix + C.GetNamePath + '.Color' + postfix) then
          begin
            try
              TUPC(T).Color := R.ReadInteger(preffix + C.GetNamePath + '.Color'
                + postfix);
            except
            end;
          end;
        if WCaption then
          if R.ValueExists(preffix + C.GetNamePath + '.Caption' + postfix) then
          begin
            try
              TUPC(T).Caption := R.ReadString(preffix + C.GetNamePath +
                '.Caption' + postfix);
            except
              try
                if T is TButton then
                  TButton(T).Caption := R.ReadString(preffix + C.GetNamePath +
                    '.Caption' + postfix);
                if T is TCustomLabel then
                  TCustomLabel(T).Caption := R.ReadString(preffix + C.GetNamePath
                    + '.caption' + postfix);
                if T is TCheckBox then
                  TCheckBox(T).Caption := R.ReadString(preffix + C.GetNamePath +
                    '.Caption' + postfix);
                if T is TRadioButton then
                  TRadioButton(T).Caption := R.ReadString(preffix + C.GetNamePath
                    + '.Caption' + postfix);
                if T is TGroupBox then
                  TGroupBox(T).Caption := R.ReadString(preffix + C.GetNamePath +
                    '.Caption' + postfix);
                if T is TRadioGroup then
                  TRadioGroup(T).Caption := R.ReadString(preffix + C.GetNamePath
                    + '.Caption' + postfix);
                if T is TPanel then
                  TPanel(T).Caption := R.ReadString(preffix + C.GetNamePath +
                    '.Caption' + postfix);
                if T is TSpeedButton then
                  TSpeedButton(T).Caption := R.ReadString(preffix + C.GetNamePath
                    + '.Caption' + postfix);
                if T is TStaticText then
                  TStaticText(T).Caption := R.ReadString(preffix + C.GetNamePath
                    + '.Caption' + postfix);
              except
              end;
            end;
          end;
      end;
      R.Free;
    end
    else
    begin
      if C is TYesOrNoDialog then
      begin
        R := TRegistry.Create;
        R.RootKey := RegRootHKEY;
        if R.OpenKey(RegPath, False) then
        begin
          if WCaption then
            if R.ValueExists(preffix + C.GetNamePath + '.Caption' + postfix)
              then
              TYesOrNoDialog(C).caption := R.ReadString(preffix + C.GetNamePath +
                '.Caption' + postfix);
          if WText then
            if R.ValueExists(preffix + C.GetNamePath + '.Text' + postfix) then
              TYesOrNoDialog(C).text := R.ReadString(preffix + C.GetNamePath +
                '.Text' + postfix);
        end;
        R.Free;
      end;
      if C is TPopupMenu then
      begin
        R := TRegistry.Create;
        R.RootKey := RegRootHKEY;
        if R.OpenKey(RegPath, True) then
        begin
          for I := 0 to TPopupMenu(C).Items.Count - 1 do
          begin
            if WCaption then
              if R.ValueExists(preffix + C.GetNamePath + '.Item[' + IntToStr(I) +
                '].Caption' + postfix) then
                TPopupMenu(C).Items[I].caption := R.ReadString(preffix +
                  C.GetNamePath + '.Item[' + IntToStr(I) + '].Caption' + postfix);
            if WEnabled then
              if R.ValueExists(preffix + C.GetNamePath + '.Item[' + IntToStr(I) +
                '].Enabled' + postfix) then
                TPopupMenu(C).Items[I].Enabled := R.ReadBool(preffix +
                  C.GetNamePath + '.Item[' + IntToStr(I) + '].Enabled' + postfix);
            if WVisible then
              if R.ValueExists(preffix + C.GetNamePath + '.Item[' + IntToStr(I) +
                '].Visible' + postfix) then
                TPopupMenu(C).Items[I].Visible := R.ReadBool(preffix +
                  C.GetNamePath + '.Item[' + IntToStr(I) + '].Visible' + postfix);
            if WChecked then
              if R.ValueExists(preffix + C.GetNamePath + '.Item[' + IntToStr(I) +
                '].Checked' + postfix) then
                TPopupMenu(C).Items[I].Checked := R.ReadBool(preffix +
                  C.GetNamePath + '.Item[' + IntToStr(I) + '].Checked' + postfix);
          end;
        end;
        R.Free;
      end;
    end;
  end;
  for I := 0 to C.ComponentCount - 1 do
    LoadComponentState(C.Components[i], preffix + C.GetNamePath + '.', postfix);
end;
end.

Сохранение компонента полностью со всеми свойствами в БД.

Автор: Z-man WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Сохранение компонента полностью, со всеми свойствами в БД.
Данная функция использовалась и используется для сохранения отчетов,
формируемые пользователем, в базу данных. БД используется: Informix и Oracle,
под другие БД не пробовал. Отчеты строились в ReportBuilder5.5.
Для других компонентов не пробывал использовать
Зависимости: стандартные
Автор:       Z-man, nik7777@land.ru, ICQ:160236098, Astana
Copyright:   Z-man ®
Дата:        28 мая 2002 г.
***************************************************** }
function ComponentToString(Component: TComponent): string;
var
  BinStream: TMemoryStream;
  StrStream: TStringStream;
  s: string;
begin
  BinStream := TMemoryStream.Create;
  try
    StrStream := TStringStream.Create(s);
    try
      BinStream.WriteComponent(Component);
      BinStream.Seek(0, soFromBeginning);
      ObjectBinaryToText(BinStream, StrStream);
      StrStream.Seek(0, soFromBeginning);
      Result := StrStream.DataString;
    finally
      StrStream.Free;
    end;
  finally
    BinStream.Free
  end;
end;

Пример использования:

OraTReport.FieldByName('report').AsString := ComponentToString(rbReport);
//* где: *//
//* rbReport - ReportBuilder5 (желтый отчет)*//
//* OraTReport - TOraTable из пакета компонентов ODAC (визуальные *//
//* компоненты для прямого доступа к Oracle)*//

Сохранение данных в Clipboard.

[A:]Не только возможно, именно так поступают функции Clipboard.GetComponent и Clipboard.SetComponent. Сначала вы должны зарегистрировать свой собственный формат данных для Clipboard с помощью функции RegisterClipboardFormat:

     CF_MYFORMAT := RegisterClipboardFormat('My Format Description');

Пример:

     var
       hBuf: THandle;
       Bufptr: Pointer;
       MStream: TMemoryStream;
     begin
       MStream := TMemoryStream.Create;
       try
       { write your data to the stream }
         hBuf := GlobalAlloc(GMEM_MOVEABLE, MStream.Size);
         try
           BufPtr := GlobalLock(hBuf);
           try
             Move(MStream.Memory^, BufPtr^, MStream.Size);
             Clipboard.SetAsHandle(CF_MYFORMAT, hBuf);
           finally
             GlobalUnlock(hBuf);
           end;
         except
           GlobalFree(hBuf);
           raise;
         end;
       finally
         MStream.Free;
       end;
     end;

Для обратного получения потока и данных, сделайте что-нибудь вроде этого:

     var
       hBuf: THandle;
       BufPtr: Pointer;
       MStream: TMemoryStream;
     begin
       hBuf := Clipboard.GetAsHandle(CF_MYFORMAT);
       if hBuf <> 0 then
       begin
         BufPtr := GlobalLock(hBuf);
         if BufPtr <> nil then
         try
           MStream := TMemoryStream.Create;
           try
             MStream.WriteBuffer(BufPtr^, GlobalSize(hBuf));
             MStream.Position := 0;
           { read your data from the stream }
           finally
             MStream.Free;
           end;
         finally
           GlobalUnlock(hBuf);
         end;
       end;
     end;

Сохранить порядок колонок в DBGrid, после того как пользовать их перестроил.

procedure TMainForm.NewIni(const NomeIni: string);
var F: System.Text;
    i: Byte;
begin
  System.Assign(F, NomeIni);
  System.ReWrite(F);
  System.WriteLn(F, '[Campi_Ordine]');
  for i:=1 to Table1.FieldCount do
    System.WriteLn(F, 'Campo',i,'=',Table1.Fields[i-1].FieldName);
  System.WriteLn(F, '');
  System.WriteLn(F, '[Campi_Size]');
  for i:=1 to Table1.FieldCount do
    System.WriteLn(F, 'Campo',i,'=',Table1.Fields[i-1].DisplayWidth);
  System.Close(F);
end;
procedure TMainForm.SaveIni(const FN: String);
var Ini: TIniFile;
    i: Integer;
begin
  NewIni(FN);
  Ini := TIniFile.Create(FN);
  with Ini do
  begin
    for i:=1 to Table1.FieldCount do
    begin
      S:= Table1.Fields[i-1].FieldName;
      WriteString('Campi_Ordine', 'Campo'+IntToStr(i),
        Table1.Fields[i-1].FieldName);
      WriteInteger('Campi_Size', 'Campo'+IntToStr(i),
        Table1.Fields[i-1].DisplayWidth);
    end;
  end;
  Ini.Free;
end;
procedure TMainForm.LoadIni(const FN: String);
var Ini: TIniFile;
    i: Integer;
    j: Longint;
    S: String;
    function MyReadInteger(const Section, Ident: string): Longint;
    begin
      result := Ini.ReadInteger(Section, Ident, -1);
      if result=-1 then
        raise Exception.Create('Errore nel file di configurazione.');
    end;
    function MyReadString(const Section, Ident: string): String;
    begin
      result := Ini.ReadString(Section, Ident, '');
      if result='' then
        raise Exception.Create('Errore nel file di configurazione.');
    end;
begin
  Ini := TIniFile.Create(FN);
  try
    with Ini do
    begin
      for i:=1 to Table1.FieldCount do
      begin
        S:= MyReadString('Campi_Ordine', 'Campo'+IntToStr(i));
        j:= MyReadInteger('Campi_Size', 'Campo'+IntToStr(i));
        Table1.FieldByName(S).Index := i-1;
        Table1.FieldByName(S).DisplayWidth := j;
      end;
    end;
  finally
    Ini.Free;
  end;
end; 

Сохранить Excel файл как текстовый.

uses 
  ComObj; 
function ExcelSaveAsText(ExcelFile, TextFile: TFileName): Boolean; 
const 
  xlText = -4158; 
var 
  ExcelApp: OleVariant; 
  vTemp1, vTemp2, vTemp3: OLEVariant; 
begin 
  Result := False; 
  try 
    ExcelApp := CreateOleObject('Excel.Application'); 
  except 
    // Fehler beim цffnеn von Excel... 
    // Error occured... 
    Exit; 
  end; 
  try 
    ExcelApp.Workbooks.Open(ExcelFile); 
    ExcelApp.DisplayAlerts := False; 
    vTemp3 := False; 
    vTemp2 := xlText; 
    vTemp1 := TextFile;
    ExcelApp.ActiveWorkbook.SaveAs(vTemp1, vTemp2, vTemp3); 
    Result := True; 
  finally 
    ExcelApp.Quit; 
    ExcelApp := Unassigned; 
  end; 
end; 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  ExcelSaveAsText('C:\YouExcelFile.xls','C:\YourTextFile.txt'); 
end;

Сохранение размеров, позиции и состояния окна.

В MainForm.Create, инициализируйте глобальный объект WinRestorer следующим образом (он должен предварительно быть объявлен, но еще не инициализирован):

GlobalWinRestorer := TWinRestorer.create( Application, TRUE, WHATSAVE_ALL);

Или так:

GlobalWinRestorer := TWinRestorer.create( Application, TRUE, [location, size, state]);

Затем в MainForm.Destroy вы должны разрушить глобальный объект WinRestorer следующим образом:

GlobalWinRestorer.free; 

Хорошее место для сохранения статуса формы - в обработчике события queryclose или в специально созданной кнопке или пункте меню. Я обычно создаю этот пункт в меню "Файл" с именем '&Сохранение рабочей области' и обрабатываю следующим образом:

GlobalWinRestorer.SaveChildren(Self, [default]);

И при закрытии основной формы необходимо сделать следующее:

GlobalWinRestorer.SaveWin(Self, [WHATSAVE_ALL]);

Восстановить состояние дочерних форм можно следующим образом:

GlobalWinRestorer.RestoreWin(Self, [default]);

Я же переместил данный код в обработчик события show моей главной формы:

GlobalWinRestorer.RestoreWin(Self, [default]);
GlobalWinRestorer.RestoreChildren(Self, [default]);

Подсказки: Если вы установили TForm.Position в poScreenCenter или что-то подобное, данный модуль вам не поможет. poDesigned кажется, работает как положено. Можно добавить обработку исключения, если вы пытаетесь установить верхнюю или левую позицию при значении формы poScreenCentere, но при этом вы должны быть осторожными при использовании WinRestoreChildren. Я не проверял это со значениями координат (позиции) и оставил это на усмотрение разработчиков.

unit WinRstor;
interface
uses SysUtils, Forms;
type
  {=============================================================}
  {------------------------------------------------------------------
  Восстановитель окон классовых объектов и связанных типов.
  -------------------------------------------------------------------}
  EWinRestorer = class(Exception);
  TWhatSave = (default, size, location, state);
  STWhatSave = set of TWhatSave;
  TWinRestorer = class(TObject)
  protected
    mIniFile: string;
    mIniSect: string[80];
    mIsInitialized: boolean;
    mDefaultWhat: STWhatSave;
  public
    constructor Create(TheApp: TApplication;
      LocalDir: boolean; DefaultWhatSave: STWhatSave);
    {Если localDir = true, каталог ini = каталогу приложения.
    Else, ini dir is the windows dir.}
    procedure SaveWin(TheForm: TForm; What: STWhatSave);
    procedure SaveChildren(TheMDIForm: TForm; What: STWhatSave);
    procedure RestoreWin(TheForm: TForm; What: STWhatSave);
    procedure RestoreChildren(TheMDIForm: TForm; What: STWhatSave);
    property IniFileName: string read mIniFile;
  end;
const
  WHATSAVE_ALL = [size, location, state];
var
  GlobalWinRestorer: TWinRestorer;
implementation
uses IniFiles;
constructor TWinRestorer.create;
var
  fname, path: string[100];
begin
  inherited create;
  {Получаем имя ini-файла}
  if default in DefaultWhatSave then
    raise EWinRestorer.create(
      'Попытка инициализации параметров с позицией окна по умолчанию ' +
      ' с установленным элементом [default]. ' +
      'Параметры по умолчанию могут содержать только установленные элементы -
      [size, location, state]. ')
  else
    mDefaultWhat := DefaultWhatSave;
  fname := ChangeFileExt(ExtractFileName(TheApp.exeName), '.INI');
  if LocalDir then
  begin {вычисляем путь и добавляем к нему имя файла}
    path := ExtractFilePath(TheApp.exeName);
    if path[length(path)] <> '\' then
      path := path + '\';
    fname := path + fname;
  end;
  {заполняем поля объекта}
  mIniFile := fname;
  mIniSect := 'WindowsRestorer';
  {Для культуры напишем некоторое примечание
  в секцию с именем [WinRestorer Notes]}
end;
procedure TWinRestorer.RestoreWin;
var
  FormNm, SectionNm: string[80];
  ini: TIniFile;
  n, l, t, w, h: integer; {Left, Top Width, Height}
begin
  ini := TIniFile.create(mIniFile);
  try
    SectionNm := mIniSect;
    FormNm := TheForm.classname;
    if default in What then
      What := mDefaultWhat;
    {При необходимости обновляем состояние окна}
    if state in What then
      n := ini.ReadInteger(SectionNm, FormNm + '_WindowState', 0);
    case n of
      1: TheForm.WindowState := wsMinimized;
      2: TheForm.WindowState := wsNormal;
      3: TheForm.WindowState := wsMaximized;
    end;
    {При необходимости обновляем размеры и позицию.}
    with TheForm do
    begin
      l := left;
      t := top;
      h := height;
      w := width;
    end; {Сохраняем текущие значения.}
    if size in What then
    begin
      w := ini.ReadInteger(SectionNm, FormNm + '_Width', w);
      h := ini.ReadInteger(SectionNm, FormNm + '_Height', h);
    end;
    if location in What then
    begin
      t := ini.ReadInteger(SectionNm, FormNm + '_Top', t);
      l := ini.ReadInteger(SectionNm, FormNm + '_Left', l);
    end;
    TheForm.SetBounds(l, t, w, h);
  finally
    ini.free;
  end;
end;
procedure TWinRestorer.RestoreChildren;
var
  i: integer;
begin
  if TheMDIForm.formstyle <> fsMDIForm then
    raise
      EWinRestorer.create('Попытка сохранения размеров дочернего
        окна для не-MDI окна родителя.')
  else
    for i := 0 to TheMDIForm.MDIChildCount - 1 do
      RestoreWin(TheMDIForm.MDIChildren[i], what);
end;
procedure TWinRestorer.SaveWin;
var
  FormNm, SectionNm: string[80];
  w: STWhatsave;
  ini: TIniFile;
begin
  ini := TIniFile.create(mIniFile);
  try
    SectionNm := mIniSect;
    FormNm := TheForm.ClassName;
    if default in What then
      w := mDefaultWhat
    else
      w := mDefaultWhat;
    if size in w then
    begin
      ini.WriteInteger(SectionNm, FormNm + '_Width', TheForm.Width);
      ini.WriteInteger(SectionNm, FormNm + '_Height', TheForm.Height);
    end;
    if location in w then
    begin
      ini.WriteInteger(SectionNm, FormNm + '_Top', TheForm.Top);
      ini.WriteInteger(SectionNm, FormNm + '_Left', TheForm.Left);
    end;
    if state in w then
      case TheForm.WindowState of
        wsMinimized: ini.WriteInteger(SectionNm, FormNm + '_WindowState', 1);
        wsNormal: ini.WriteInteger(SectionNm, FormNm + '_WindowState', 2);
        wsMaximized: ini.WriteInteger(SectionNm, FormNm + '_WindowState', 3);
      end;
  finally
    ini.free;
  end;
end;
procedure TWinRestorer.SaveChildren;
var
  i: integer;
begin
  if TheMDIForm.formstyle <> fsMDIForm then
    raise
      EWinRestorer.create('Попытка восстановления размеров дочернего
        окна для не-MDI окна родителя.')
  else
    for i := 0 to TheMDIForm.MDIChildCount - 1 do
      SaveWin(TheMDIForm.MDIChildren[i], what);
end;
initialization
end.

Сохранение в файле и загрузка из файла формы с компонентами.

unit Cref_f;
interface
uses
  SysUtils, WinTypes, WinProcs, Messages, Classes,
  Graphics, Controls, Forms, Dialogs, StdCtrls,
  ExtCtrls, Menus;
type
  CRefType = class of TControl;
  TForm1 = class(TForm)
    MainMenu1: TMainMenu;
    File1: TMenuItem;
    Exit1: TMenuItem;
    N1: TMenuItem;
    SaveAs1: TMenuItem;
    Open1: TMenuItem;
    New1: TMenuItem;
    Help1: TMenuItem;
    About1: TMenuItem;
    Panel1: TPanel;
    RadioRadioButton: TRadioButton;
    ButtonRadioButton: TRadioButton;
    EditRadioButton: TRadioButton;
    OpenDialog1: TOpenDialog;
    SaveDialog1: TSaveDialog;
    SaveAs2: TMenuItem;
    N2: TMenuItem;
    SaveDialog2: TSaveDialog;
    MemoRadioButton: TRadioButton;
    procedure RadioButtonRadioClick(Sender: TObject);
    procedure RadioButtonButtonClick(Sender: TObject);
    procedure RadioButtonEditClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormMouseDown(Sender: TObject;
      Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure New1Click(Sender: TObject);
    procedure Open1Click(Sender: TObject);
    procedure SaveAs1Click(Sender: TObject);
    procedure About1Click(Sender: TObject);
    procedure Exit1Click(Sender: TObject);
    procedure SaveAs2Click(Sender: TObject);
    procedure MemoRadioButtonClick(Sender: TObject);
  private
    ClassRef: CRefType;
    Counter: Integer;
  end;
var
  Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.RadioButtonRadioClick(Sender: TObject);
begin
  ClassRef := TRadioButton;
end;
procedure TForm1.RadioButtonButtonClick(Sender: TObject);
begin
  ClassRef := TButton;
end;
procedure TForm1.RadioButtonEditClick(Sender: TObject);
begin
  ClassRef := TEdit;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
  ClassRef := TRadioButton;
  Counter := 0;
end;
procedure TForm1.FormMouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
  MyObj: TControl;
  MyName: String;
begin
  {create an object using the current class reference}
  MyObj := ClassRef.Create (self);
  MyObj.Visible := False;
  MyObj.Parent := self;
  MyObj.Left := X;
  MyObj.Top := Y;
  Inc (Counter);
  {define the name using the class name, without the
  initial T, and the number of the Counter}
  MyName := ClassRef.ClassName + IntToStr (Counter);
  Delete (MyName, 1, 1);
  MyObj.Name := MyName;
  MyObj.Visible := True;
end;
procedure TForm1.New1Click(Sender: TObject);
var
  I: Integer;
begin
  {delete all existing components, except the panel}
  for I := ControlCount - 1 downto 0 do
    if Controls[I].ClassName <> 'TPanel' then
      Controls[I].Free;
  Counter := 0;
end;
procedure TForm1.Open1Click(Sender: TObject);
var
  S: TFileStream;
  New: TComponent;
  Reader1: TReader; // new line
begin
  if OpenDialog1.Execute then
  begin
    {remove existing controls}
    New1Click (self);
    {open the stream}
    S := TFileStream.Create (OpenDialog1.FileName,
      fmOpenRead);
    try
      while S.Position < S.Size do
      begin
        {read a component and add it to the form}
        // old code:
//        New := S.ReadComponent (nil);
//        InsertControl (New as TControl);
        // new code:
        Reader1 := TReader.Create (S, 4096);
        try
          Reader1.Parent := self;
          New := Reader1.ReadRootComponent (nil);
          InsertComponent (New);
        finally
          Reader1.Free;
        end;
        Inc (Counter);
      end;
    finally
      S.Free;
    end;
  end;
end;
procedure TForm1.SaveAs1Click(Sender: TObject);
var
  S: TFileStream;
  I: Integer;
begin
  if SaveDialog1.Execute then
  begin
    {open or create the stream file}
    S := TFileStream.Create (SaveDialog1.FileName,
      fmOpenWrite or fmCreate);
    try
      {save each component except the panel}
      for I := 0 to ControlCount - 1 do
        if Controls[I].ClassName <> 'TPanel' then
          S.WriteComponent (Controls[I]);
    finally
      S.Free;
    end;
  end;
end;
procedure TForm1.About1Click(Sender: TObject);
begin
  MessageDlg ('CREF2 Example: Save components to file' +
    Chr(13) + 'From "Mastering Delphi", by Marco Саntщ',
    mtInformation, [mbOk], 0);
end;
procedure TForm1.Exit1Click(Sender: TObject);
begin
  Close;
end;
{save form file}
procedure TForm1.SaveAs2Click(Sender: TObject);
begin
  if SaveDialog2.Execute then
    WriteComponentResFile
      (SaveDialog2.Filename, self);
end;
procedure TForm1.MemoRadioButtonClick(Sender: TObject);
begin
  ClassRef := TMemo;
end;
initialization
  {register the classes of the components; this code is
  required by the stream loader}
  RegisterClasses ([TRadioButton, TEdit, TButton, TMemo]);
end.

Загрузить весь проект

Сохранить изображение в формате JPEG.

В комплект поставки Delphi входит модуль JPEG. Он позволяет работать с изображениями в формате JPEG. Эта программа сохраняет изображение экрана в файле C:\Screen.jpg.

uses Jpeg;
procedure TForm1.Button1Click(Sender: TObject);
var
  JpegIm: TJpegImage;
  bm: TBitMap;
begin
  bm := TBitMap.Create;
  bm.Width := Screen.Width;
  bm.Height := Screen.Height;
  BitBlt(bm.Canvas.Handle, 0, 0,
  bm.Width, bm.Height,
  GetDC(0), 0, 0, SRCCOPY);
  JpegIm := TJpegImage.Create;
  JpegIm.Assign(bm);
  JpegIm.CompressionQuality := 20;
  JpegIm.Compress;
  JpegIm.SaveToFile('C:\Screen.jpg');
  bm.Destroy;
  JpegIm.Destroy;
end;

Сохранение и загрузка данных в объекты на примере коллекций.

Если в Вашей программе используются классы для описания объектов некоторой предметной области, то данные, их инициализирующие, можно хранить и в базе данных. Но можно выбрать гораздо более продуктивный подход, который доступен в Delphi/C++ Builder. Среда разработки Delphi/C++ Builder хранит ресурсы всех форм в двоичных или текстовых файлах и эта возможность доступна и для разрабатываемых с ее помощью программ. В данном случае, для оценки удобств такого подхода лучше всего рассмотреть конкретный пример.

Необходимо реализовать хранение информации о некоей службе рассылки и ее подписчиках. Будем хранить данные о почтовом сервере и список подписчиков. Каждая запись о подписчике хранит его личные данные и адрес, а также список тем(или каталогов), на которые он подписан. Как большие поклонники Гради Буча (Grady Booch), а также будучи заинтересованы в удобной организации кода, мы организуем информацию о подписчиках в виде объектов. В Delphi для данной задачи идеально подходит класс TCollection, реализующий всю необходимую функциональность для работы со списками типизированных объектов. Для этого мы наследуемся от TCollection, называя новый класс TMailList, а также создаем наследника от TCollectionItem - TMailClient. Последний будет содержать все необходимые данные о подписчике, а также реализовывать необходимые функции для работы с ним.

Начнем с TMailClient.

type
  TMailClient = class(TCollectionItem)
  private
    FName: string;
    FAddress: string;
    FEnabled: boolean;
    FFolders: TStringList;
  public
    Files: TStringList;
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure PickFiles;
  published
    property name: string read FName write FName;
    property Address: string read FAddress write FAddress;
    property Enabled: boolean read FEnabled write FEnabled default true;
    property Folders: TStringList read FFolders write FFolders;
  end;

Класс содержит сведения о имени клиента, его адресе, его статусе(Enabled), а также список каталогов, на которые он подписан. Процедура PickFiles составляет список файлов к отправке и сохраняет его в свойстве Files. Класс TMailList, хранящий объекты класса TMailClient, приведен ниже.

  TMailList = class(TCollection)
  public
   function GetMailClient(index: Integer): TMailClient;
   procedure SetMailClient(index: Integer; Value: TMailClient);
  public
   function Add: TMailClient;
   property Items[index: Integer]: TMailClient read GetMailClient
   write SetMailClient; default;
  end;

Теперь поместим класс TMailList в класс TMailer, содержащий также и данные о параметрах доступа к почтовому серверу для отправки почты.

  TMailer = class(TComponent)
  private
    name: string;
    EMail: string;
    FMailList: TMailList;
    FLastActivated: TDateTime;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property MailList: TMailList read FMailList write FMailList;
    property LastActivated: TDateTime read FLastActivated write FLastActivated;
  end;

В данном случае мы наследуемся от класса TComponent, для того, чтобы была возможности записи данных объекта в файл. Свойство MailList содержит уже объект класса TMailList, а свойство LastActivated - дату последнего запуска программы рассылки.

Реализация всех приведенных классов приведена ниже.

constructor TMailClient.Create(Collection: TCollection);
begin
  inherited;
  Folders := TStringList.Create;
  Files := TStringList.Create;
  FEnabled := true;
end;
destructor TMailClient.Destroy;
begin
  Folders.Free;
  Files.Free;
  inherited;
end;
procedure TMailClient.PickFiles;
var
  i: integer;
begin
  for i := 0 to Folders.Count - 1 do
    CreateFileList(Files, Folders[i]);
end;
function TMailList.GetMailClient(index: Integer): TMailClient;
begin
  Result := TMailClient(inherited Items[index]);
end;
procedure TMailList.SetMailClient(index: Integer; Value: TMailClient);
begin
  Items[index].Assign(Value);
end;
function TMailList.Add: TMailClient;
begin
  Result := TMailClient(inherited Add);
end;
constructor TMailer.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  MailList := TMailList.Create(TMailClient);
  FLastActivated := now;
end;
destructor TMailer.Destroy;
begin
  MailList.Free;
  inherited;
end;

Функция CreateFileList создает по каким-либо правилам список файлов на основе переданного ей списка каталогов, обходя их рекурсивно.

procedure CreateFileList(sl: TStringList; FilePath: string);
var
  sr: TSearchRec;
  procedure ProcessFile;
  begin
    if (sr.name = '.') or(sr.name = '..') then
      exit;
    if sr.Attr <> faDirectory then
      sl.Add(FilePath + '\' + sr.name);
    if sr.Attr = faDirectory then
      CreateFileList(sl, FilePath + '\' + sr.name);
  end;
begin
  if not DirectoryExists(FilePath) then
    exit;
  if FindFirst(FilePath + '\' + Settings.IncludeFileMasks,
  faAnyFile , sr) = 0 then
    ProcessFile;
  while FindNext(sr) = 0 do
    ProcessFile;
  FindClose(sr);
end;

В итоге мы располагаем классом TMailer, содержащим всю необходимую нам информацию. Теперь перейдем к созданию объекта, их сохранению и загрузке.

var
  sDataFile: string;
  MLN: TMailLateNight;
begin
  MLN := TMailLateNight.Create(nil);
  sDataFile := ExtractFilePath(ParamStr(0)) + 'users.dat';
  //...загрузка данных из файла
  if FileExists(sDatsFile) then
    LoadUsersFromTextFile(MLN, sDatsFile);
  ...
  //...работа с объектами
  for i:=0 to MLN.MailList.Count-1 do
  begin
    s := MLN.MailList[i].name;
    s := MLN.MailList[i].Address;
    MLN.MailList[i].PickFiles;
    for j:=0 to MLN.Files.Count-1 do
    begin
      s := MLN.MailList[i].Files[j];
      ...
      //...сохранение данных в файл
      SaveComponentToTextFile(MLN, sDataFile);

Хранение данных в файле позволяет оказаться от использования БД, если объем данных не слишком велик и нет необходимости в совместном доступе к данным.

Самое главное - мы организуем все данные в виде набора удобных для работы классов и не тратим время на их сохранение и инициализацию из БД.

Далее приведен код функций для сохранения/чтения компонента.

//...процедура удаляет все дочерние компоненты из формы
procedure DeleteComponents(Form: TForm);
var
  i: integer;
begin
  for i := Form.ComponentCount - 1 downto 0 do
    Form.Components[i].Free;
end;
// ...процедура загружает(инициализирует)
// компонент из текстового файла с ресурсом
procedure LoadComponentFromTextFile(Component: TComponent;
FileName: string);
var
  ms: TMemoryStream;
  fs: TFileStream;
begin
  ms := TMemoryStream.Create;
  fs := TFileStream.Create(FileName, fmOpenRead);
  try
    ObjectTextToBinary(fs, ms);
    ms.position := 0;
    ms.ReadComponent(Component);
  finally
    ms.Free;
    fs.free;
  end;
end;
//...процедура сохраняет компонент в текстовый файл
procedure SaveComponentToTextFile(Component: TComponent;
FileName: string);
var
  ms: TMemoryStream;
  fs: TFileStream;
begin
  fs := TFileStream.Create(FileName, fmCreate or fmOpenWrite);
  ms := TMemoryStream.Create;
  try
    ms.WriteComponent(Component);
    ms.position := 0;
    ObjectBinaryToText(ms, fs);
  finally
    ms.Free;
    fs.free;
  end;
end;

Сохранение и чтение TStringGrid.

procedure SaveGrid;
var
  f: textfile;
  x, y: integer;
begin
  assignfile(f, 'Filename');
  rewrite(f);
  writeln(f, stringgrid.colcount);
  writeln(f, stringgrid.rowcount);
  for X := 0 to stringgrid.colcount - 1 do
    for y := 0 to stringgrid.rowcount - 1 do
      writeln(F, stringgrid.cells[x, y]);
  closefile(f);
end;
procedure LoadGrid;
var
  f: textfile;
  temp, x, y: integer;
  tempstr: string;
begin
  assignfile(f, 'Filename');
  reset(f);
  readln(f, temp);
  stringgrid.colcount := temp;
  readln(f, temp);
  stringgrid.rowcount := temp;
  for X := 0 to stringgrid.colcount - 1 do
    for y := 0 to stringgrid.rowcount - 1 do
    begin
      readln(F, tempstr);
      stringgrid.cells[x, y] := tempstr;
    end;
  closefile(f);
end;

При чтении почты POP3 отделять Attachment и сохранять в файл.

Почту читаю, используя компонент TNMPOP3 (стандартный в поставке D5), еще пробовал использовать библитеку Indy, но не помогло. А проблема заключается в том, что после прочтения письма, невозможно отделить аттачмент от тела. Но это происходит не со всеми письмами. Если я отправлю письмо с аттачем, то я могу его нормально читать и разбирать, а если отправляет Заказчик, то получается то, что я описал. Причем, Outlook и theBat, эти письма нормально читают и аттач МОЖНО сохранить.

for intIndex := 0 to Pred(Msg.MessageParts.Count) do
begin
  if (Msg.MessageParts.Items[intIndex] is TIdAttachment) then
  begin //general attachment
    TIdAttachment(Msg.MessageParts.Items[intIndex]).SaveToFile(
      TIdAttachment(Msg.MessageParts.Items[intIndex]).Filename);
    TIdAttachment.Create(Msg1.MessageParts,
      TIdAttachment(Msg.MessageParts.Items[intIndex]).Filename);
  end
  else
  begin //body text
    if Msg.MessageParts.Items[intIndex] is TIdText then
    begin
      Memo1.Lines.Clear;
      Memo1.Lines.AddStrings(TIdText(Msg.MessageParts.Items[intIndex]).Body);
    end
  end;
end;

Сохранить несколько контролов в один файл.

{ 
 -> Question: 
 How can I store some TRichEdit components and TEdit Components in a single file? 
 -> Answer: 
 Use a filestream and a reader or writer object. 
 These ease the tasks of writing strings to a binary stream and reading them back. 
} 
{ 
 -> Frage: 
 Wie kann ich den Inhalt einiger TRichEdit und TEdit Komponenten in einer einzigen 
 Datei  speichern? 
 -> Antwort: 
 Verwende einen FileStraem und ein Reader/Writer Objekt. 
 Damit kann man leicht strings in einen ьinдгеn Stream speichern und zигьск1еsеn. 
} 
// Save routine 
// Speichern Routine 
procedure SaveEditcontrols(const FileName: string; const Controls: array of TCustomEdit); 
var 
  fs: TFilestream; 
  writer: TWriter; 
  i: Integer; 
  ss: TStringstream; 
begin 
  fs := TFilestream.Create(FileName, fmCreate); 
  try 
    writer := TWriter.Create(fs, 4096); 
    try 
      for i := Low(Controls) to High(Controls) do 
        if Controls[i] is TCustomRichedit then  
        begin 
          ss := TStringstream.Create(EmptyStr); 
          try 
            with TRichedit(Controls[i]) do  
            begin 
              Plaintext := False; 
              Lines.SaveToStream(ss); 
            end; 
            writer.WriteString(ss.Datastring); 
          finally 
            ss.Free; 
          end; 
        end 
      else 
        writer.WriteString(Controls[i].Text); 
    finally 
      writer.Free; 
    end; 
  finally 
    fs.Free; 
  end; 
end; 
// Load routine 
// Lade Routine 
procedure LoadEditcontrols(const FileName: string; const Controls: array of TCustomEdit); 
var 
  fs: TFilestream; 
  reader: Treader; 
  i: Integer; 
  ss: TStringstream; 
begin 
  fs := TFilestream.Create(FileName, fmOpenread or fmShareDenyWrite); 
  try 
    reader := Treader.Create(fs, 4096); 
    try 
      for i := Low(Controls) to High(Controls) do 
        if Controls[i] is TCustomRichedit then  
        begin 
          ss := TStringstream.Create(reader.ReadString); 
          try 
            with TRichedit(Controls[i]) do  
            begin 
              Plaintext := False; 
              Lines.LoadfromStream(ss); 
            end; 
          finally 
            ss.Free; 
          end; 
        end 
      else 
        Controls[i].Text := reader.ReadString; 
    finally 
      reader.Free; 
    end; 
  finally 
    fs.Free; 
  end; 
end; 
// Example to store 2 TRichEdits and 3 Edit Controls to one file 
// Beispiel, um  3 TRichEdits und 3 TEdit Controls in einer Datei zu speichern 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  SaveEditControls('C:\temp\temp.dat', 
    [richedit1, richedit2, edit1, edit2, edit3]); 
end;

Как хранить настройки для программы. Работа с INI-файлами.

var
  IniFile: TIniFile;
  //конкретные переменные - мои - храню их в инишке
  IniPortItem: integer;
  IniRTSChecked: boolean;
const
  //значения по умолчанию
  DefPortItem = 1;
  DefRTSChecked = false;
procedure ReadIni;
var
  IniPath: string;
  FileName: string;
begin
  GetDir(0,IniPath);
  FileName:=IniPath+'\muk.ini';
  IniFile:=TIniFile.Create(FileName);
  IniPortItem:=IniFile.ReadInteger('Port','Number',DefPortItem);
  IniRTSChecked:=IniFile.ReadBool('Port','RTS/CTS',DefRTSChecked);
  IniFile.Free;
end;
procedure SaveIni;
var
  IniPath: string;
  FileName: string;
begin
  GetDir(0,IniPath);
  FileName:=IniPath+'\muk.ini';
  IniFile:=TIniFile.Create(FileName);
  IniFile.WriteInteger('Port','Number',IniPortItem);
  IniFile.WriteBool('Port','RTS/CTS',IniRTSChecked);
  IniFile.Free;
end;

Сохранять настройки в ini-файле.

Этот пример показывает, как можно сохранять настройки с помощью ini-файла. Ini-файлы удобны тем, что после удаления программы без деинсталяции в реестре не остается "следов". Еще это удобно тем, что для "сброса" настроек программы достаточно удалить ini-файл.

Эта программа сохраняет позицию и размер окна, содержимое поля ввода Edit1, число, введенное в Edit2, флажок CheckBox1, а также содержимое ListBox1 (добавить в него строчку можно, нажав на кнопку).

uses IniFiles;
procedure TForm1.FormCreate(Sender: TObject);
var
  F: TIniFile;
  names: TStringList;
  i: integer;
begin
  F := TIniFile.Create(ExtractFilePath(ParamStr(0)) + 'window.ini');
  Form1.Left := F.ReadInteger('position', 'left', 0);
  Form1.Width := F.ReadInteger('position', 'width', 200);
  Form1.Top := F.ReadInteger('position', 'top', 0);
  Form1.Height := F.ReadInteger('position', 'height', 200);
  Edit1.Text := F.ReadString('tools', 'edit1', 'no text');
  Edit2.Text := IntToStr(F.ReadInteger('tools', 'koef', 0));
  CheckBox1.Checked := F.ReadBool('tools', 'check', true);
  names := TStringList.Create;
  F.ReadSection('files', names);
  for i := 0 to Names.Count - 1 do
    ListBox1.Items.Add(F.ReadString('files', names.Strings[i], ''));
  names.Destroy;
  F.Destroy;
end;
procedure TForm1.FormDestroy(Sender: TObject);
var
  F: TIniFile;
  i: integer;
begin
  F := TIniFile.Create(ExtractFilePath(ParamStr(0)) + 'window.ini');
  F.WriteInteger('position', 'left', Form1.Left);
  F.WriteInteger('position', 'width', Form1.Width);
  F.WriteInteger('position', 'top', Form1.Top);
  F.WriteInteger('position', 'height', Form1.Height);
  F.WriteString('tools', 'edit1', Edit1.Text);
  F.WriteInteger('tools', 'koef', StrToIntDef(Edit2.Text, 0));
  F.WriteBool('tools', 'check', CheckBox1.Checked);
  for i := 0 to ListBox1.Items.Count - 1 do
    F.WriteString('files', 'file' + IntToStr(i+1), ListBox1.Items.Strings[i]);
  F.Free;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
  ListBox1.Items.Add(Edit1.Text);
end;

Сохранение прикреплений Outlook.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

{ 
  Won’t some backups of your outlook attachments are filtered 
  some incoming log files? Here's the function. 
}
 uses
   ComObj;
 {...}
 function ManageAttachments(SendersName, AttachmentPath: string;
   MailDelete: Boolean): Boolean;
 var
   oApp: Variant;
   oNs: Variant;
   oFolder: Variant;
   oMsg: Variant;
   AtC: Variant;
   AttFilename: Variant;
   FileName: string;
   CheckSender: string;
   Counter: integer;
   MailCounter: integer;
 begin
   try
     oApp := CreateOLEObject('outlook.application');
     try
       oNs         := oApp.GetNamespace('MAPI');
       ofolder     := oNS.GetDefaultFolder(6); // FolderTypeEnum  (olFolderInbox) 
      MailCounter := 1;
       // If there is any email in the Inbox 
      if ofolder.Items.Count > 0 then
       begin
         repeat
           // Get the first Email 
          oMsg := ofolder.Items(MailCounter);
           // Check the name or Email 
          //   Use CheckSender := oMsg.subject to search on Subject; 
          CheckSender := oMsg.sendername;
           if CheckSender = SendersName then
           //  Remove this line to backup all your attachments. 
          begin
             // Check how many attachments 
            atc := oMsg.Attachments.Count;
             if atc > 0 then
             begin
               // Get all the attachments and save them 
              for Counter := 1 to atc do
               begin
                 AttFilename := oMsg.Attachments.item(Counter).FileName;
                 //filename := IncludeTrailingBackslash(AttachmentPath)+AttFilename; {Use this line for D5)} 
                FileName := AttachmentPath + '\' + AttFilename;
                 oMsg.Attachments.Item(Counter).SaveAsFile(FileName);
               end;
             end;
             if MailDelete then
             begin
               oMsg.Delete;
               // There's 1 Email less, so MailCounter - 1 
              Dec(MailCounter);
             end;
           end;
           // Get the next Email 
          Inc(MailCounter);
           // Do until there is no more Email to check 
        until MailCounter > ofolder.Items.Count;
       end;
     finally
       oApp.quit;
     end;
   except
     Result := False;
     Exit;
   end;
   Result := True;
 end;
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   // ManageAttachments(Email or name, Backup directory, MailDelete yes or no) 
  ManageAttachments('info@cleys.com', 'F:\test', False);
 end;
 { 
  Warning! 
  All your selected Email will be deleted if MailDelete = true 
  Achtung! 
  Alle E-Mails werden geloscht, wenn MailDelete = true ist. 
}

Как сохранить значение свойства в поток.

A TList doesn't have any intrinsic streaming capability built into it, but it is very easy to stream anything that you want with a little elbow grease. Think about it: a stream is data. Classes have properties, whose values are data. It isn't too hard to write property data to a stream. Here's a simple example to get you going. This is but just one of many possible approaches to saving object property data to a stream:

unit uStreamableExample;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
    StdCtrls, Contnrs;
type
  TStreamableObject = class(TPersistent)
  protected
    function ReadString(Stream: TStream): string;
    function ReadLongInt(Stream: TStream): LongInt;
    function ReadDateTime(Stream: TStream): TDateTime;
    function ReadCurrency(Stream: TStream): Currency;
    function ReadClassName(Stream: TStream): ShortString;
    procedure WriteString(Stream: TStream; const Value: string);
    procedure WriteLongInt(Stream: TStream; const Value: LongInt);
    procedure WriteDateTime(Stream: TStream; const Value: TDateTime);
    procedure WriteCurrency(Stream: TStream; const Value: Currency);
    procedure WriteClassName(Stream: TStream; const Value: ShortString);
  public
    constructor CreateFromStream(Stream: TStream);
    procedure LoadFromStream(Stream: TStream); virtual; abstract;
    procedure SaveToStream(Stream: TStream); virtual; abstract;
  end;
  TStreamableObjectClass = class of TStreamableObject;
  TPerson = class(TStreamableObject)
  private
    FName: string;
    FBirthDate: TDateTime;
  public
    constructor Create(const AName: string; ABirthDate: TDateTime);
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    property Name: string read FName write FName;
    property BirthDate: TDateTime read FBirthDate write FBirthDate;
  end;
  TCompany = class(TStreamableObject)
  private
    FName: string;
    FRevenues: Currency;
    FEmployeeCount: LongInt;
  public
    constructor Create(const AName: string; ARevenues: Currency; AEmployeeCount:
      LongInt);
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    property Name: string read FName write FName;
    property Revenues: Currency read FRevenues write FRevenues;
    property EmployeeCount: LongInt read FEmployeeCount write FEmployeeCount;
  end;
  TStreamableList = class(TStreamableObject)
  private
    FItems: TObjectList;
    function Get_Count: LongInt;
    function Get_Objects(Index: LongInt): TStreamableObject;
  public
    constructor Create;
    destructor Destroy; override;
    function FindClass(const AClassName: string): TStreamableObjectClass;
    procedure Add(Item: TStreamableObject);
    procedure Delete(Index: LongInt);
    procedure Clear;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    property Objects[Index: LongInt]: TStreamableObject read Get_Objects;
      default;
    property Count: LongInt read Get_Count;
  end;
  TForm1 = class(TForm)
    SaveButton: TButton;
    LoadButton: TButton;
    procedure SaveButtonClick(Sender: TObject);
    procedure LoadButtonClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    Path: string;
  end;
var
  Form1: TForm1;
implementation
{$R *.DFM}
resourcestring
  DEFAULT_FILENAME = 'test.dat';
procedure TForm1.SaveButtonClick(Sender: TObject);
var
  List: TStreamableList;
  Stream: TStream;
begin
  List := TStreamableList.Create;
  try
    List.Add(TPerson.Create('Rick Rogers', StrToDate('05/20/68')));
    List.Add(TCompany.Create('Fenestra', 1000000, 7));
    Stream := TFileStream.Create(Path + DEFAULT_FILENAME, fmCreate);
    try
      List.SaveToStream(Stream);
    finally
      Stream.Free;
    end;
  finally
    List.Free;
  end;
end;
{ TPerson }
constructor TPerson.Create(const AName: string; ABirthDate: TDateTime);
begin
  inherited Create;
  FName := AName;
  FBirthDate := ABirthDate;
end;
procedure TPerson.LoadFromStream(Stream: TStream);
begin
  FName := ReadString(Stream);
  FBirthDate := ReadDateTime(Stream);
end;
procedure TPerson.SaveToStream(Stream: TStream);
begin
  WriteString(Stream, FName);
  WriteDateTime(Stream, FBirthDate);
end;
{ TStreamableList }
procedure TStreamableList.Add(Item: TStreamableObject);
begin
  FItems.Add(Item);
end;
procedure TStreamableList.Clear;
begin
  FItems.Clear;
end;
constructor TStreamableList.Create;
begin
  FItems := TObjectList.Create;
end;
procedure TStreamableList.Delete(Index: LongInt);
begin
  FItems.Delete(Index);
end;
destructor TStreamableList.Destroy;
begin
  FItems.Free;
  inherited;
end;
function TStreamableList.FindClass(const AClassName: string):
  TStreamableObjectClass;
begin
  Result := TStreamableObjectClass(Classes.FindClass(AClassName));
end;
function TStreamableList.Get_Count: LongInt;
begin
  Result := FItems.Count;
end;
function TStreamableList.Get_Objects(Index: LongInt): TStreamableObject;
begin
  Result := FItems[Index] as TStreamableObject;
end;
procedure TStreamableList.LoadFromStream(Stream: TStream);
var
  StreamCount: LongInt;
  I: Integer;
  S: string;
  ClassRef: TStreamableObjectClass;
begin
  StreamCount := ReadLongInt(Stream);
  for I := 0 to StreamCount - 1 do
  begin
    S := ReadClassName(Stream);
    ClassRef := FindClass(S);
    Add(ClassRef.CreateFromStream(Stream));
  end;
end;
procedure TStreamableList.SaveToStream(Stream: TStream);
var
  I: Integer;
begin
  WriteLongInt(Stream, Count);
  for I := 0 to Count - 1 do
  begin
    WriteClassName(Stream, Objects[I].ClassName);
    Objects[I].SaveToStream(Stream);
  end;
end;
{ TStreamableObject }
constructor TStreamableObject.CreateFromStream(Stream: TStream);
begin
  inherited Create;
  LoadFromStream(Stream);
end;
function TStreamableObject.ReadClassName(Stream: TStream): ShortString;
begin
  Result := ReadString(Stream);
end;
function TStreamableObject.ReadCurrency(Stream: TStream): Currency;
begin
  Stream.Read(Result, SizeOf(Currency));
end;
function TStreamableObject.ReadDateTime(Stream: TStream): TDateTime;
begin
  Stream.Read(Result, SizeOf(TDateTime));
end;
function TStreamableObject.ReadLongInt(Stream: TStream): LongInt;
begin
  Stream.Read(Result, SizeOf(LongInt));
end;
function TStreamableObject.ReadString(Stream: TStream): string;
var
  L: LongInt;
begin
  L := ReadLongInt(Stream);
  SetLength(Result, L);
  Stream.Read(Result[1], L);
end;
procedure TStreamableObject.WriteClassName(Stream: TStream; const Value:
  ShortString);
begin
  WriteString(Stream, Value);
end;
procedure TStreamableObject.WriteCurrency(Stream: TStream; const Value:
  Currency);
begin
  Stream.Write(Value, SizeOf(Currency));
end;
procedure TStreamableObject.WriteDateTime(Stream: TStream; const Value:
  TDateTime);
begin
  Stream.Write(Value, SizeOf(TDateTime));
end;
procedure TStreamableObject.WriteLongInt(Stream: TStream; const Value: LongInt);
begin
  Stream.Write(Value, SizeOf(LongInt));
end;
procedure TStreamableObject.WriteString(Stream: TStream; const Value: string);
var
  L: LongInt;
begin
  L := Length(Value);
  WriteLongInt(Stream, L);
  Stream.Write(Value[1], L);
end;
{ TCompany }
constructor TCompany.Create(const AName: string; ARevenues: Currency;
  AEmployeeCount: Integer);
begin
  FName := AName;
  FRevenues := ARevenues;
  FEmployeeCount := AEmployeeCount;
end;
procedure TCompany.LoadFromStream(Stream: TStream);
begin
  FName := ReadString(Stream);
  FRevenues := ReadCurrency(Stream);
  FEmployeeCount := ReadLongInt(Stream);
end;
procedure TCompany.SaveToStream(Stream: TStream);
begin
  WriteString(Stream, FName);
  WriteCurrency(Stream, FRevenues);
  WriteLongInt(Stream, FEmployeeCount);
end;
procedure TForm1.LoadButtonClick(Sender: TObject);
var
  List: TStreamableList;
  Stream: TStream;
  Instance: TStreamableObject;
  I: Integer;
begin
  Stream := TFileStream.Create(Path + DEFAULT_FILENAME, fmOpenRead);
  try
    List := TStreamableList.Create;
    try
      List.LoadFromStream(Stream);
      for I := 0 to List.Count - 1 do
      begin
        Instance := List[I];
        if Instance is TPerson then
          ShowMessage(TPerson(Instance).Name);
        if Instance is TCompany then
          ShowMessage(TCompany(Instance).Name);
      end;
    finally
      List.Free;
    end;
  finally
    Stream.Free;
  end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
  Path := ExtractFilePath(Application.ExeName);
end;
initialization
  RegisterClasses([TPerson, TCompany]);
end.

Как сохранить значение свойства в поток 2.

Notes: This class does not support working within the delphi IDE like TCollection. All objects inheriting from TUmbCollectionItem must be registered using the Classes.RegisterClass function. All objects inheriting from TUmbCollectionItem must implement the assign function. By default, the TUmbCollection owns its items (frees them when the collection is freed), but this functionality can be changed.

unit UmbCollection;
interface
uses
  Windows, Messages, SysUtils, Classes, contnrs;
type
  TUmbCollectionItemClass = class of TUmbCollectionItem;
  TUmbCollectionItem = class(TCollectionItem)
  private
    FPosition: Integer;
  public
    {when overriding this method, you must call the inherited assign.}
    procedure Assign(Source: TPersistent); override;
  published
    {the position property is used by the streaming mechanism to place the object in the
    right position when reading the items. do not use this property.}
    property Position: Integer read FPosition write FPosition;
  end;
  TUmbCollection = class(TObjectList)
  private
    procedure SetItems(Index: Integer; Value: TUmbCollectionItem);
    function GetItems(Index: Integer): TUmbCollectionItem;
  public
    function Add(AObject: TUmbCollectionItem): Integer;
    function Remove(AObject: TUmbCollectionItem): Integer;
    function IndexOf(AObject: TUmbCollectionItem): Integer;
    function FindInstanceOf(AClass: TUmbCollectionItemClass; AExact: Boolean =
      True;
      AStartAt: Integer = 0): Integer;
    procedure Insert(Index: Integer; AObject: TUmbCollectionItem);
    procedure WriteToStream(AStream: TStream); virtual;
    procedure ReadFromStream(AStream: TStream); virtual;
    property Items[Index: Integer]: TUmbCollectionItem read GetItems write
      SetItems; default;
  published
    property OwnsObjects;
  end;
implementation
{ TUmbCollection }
function ItemsCompare(Item1, Item2: Pointer): Integer;
begin
  Result := TUmbCollectionItem(Item1).Position -
    TUmbCollectionItem(Item2).Position;
end;
function TUmbCollection.Add(AObject: TUmbCollectionItem): Integer;
begin
  Result := inherited Add(AObject);
end;
function TUmbCollection.FindInstanceOf(AClass: TUmbCollectionItemClass;
  AExact: Boolean; AStartAt: Integer): Integer;
begin
  Result := inherited FindInstanceOf(AClass, AExact, AStartAt);
end;
function TUmbCollection.GetItems(Index: Integer): TUmbCollectionItem;
begin
  Result := inherited Items[Index] as TUmbCollectionItem;
end;
function TUmbCollection.IndexOf(AObject: TUmbCollectionItem): Integer;
begin
  Result := inherited IndexOf(AObject);
end;
procedure TUmbCollection.Insert(Index: Integer; AObject: TUmbCollectionItem);
begin
  inherited Insert(Index, AObject);
end;
procedure TUmbCollection.ReadFromStream(AStream: TStream);
var
  Reader: TReader;
  Collection: TCollection;
  ItemClassName: string;
  ItemClass: TUmbCollectionItemClass;
  Item: TUmbCollectionItem;
  i: Integer;
begin
  Clear;
  Reader := TReader.Create(AStream, 1024);
  try
    Reader.ReadListBegin;
    while not Reader.EndOfList do
    begin
      ItemClassName := Reader.ReadString;
      ItemClass := TUmbCollectionItemClass(FindClass(ItemClassName));
      Collection := TCollection.Create(ItemClass);
      try
        Reader.ReadValue;
        Reader.ReadCollection(Collection);
        for i := 0 to Collection.Count - 1 do
        begin
          item := ItemClass.Create(nil);
          item.Assign(Collection.Items[i]);
          Add(Item);
        end;
      finally
        Collection.Free;
      end;
    end;
    Sort(ItemsCompare);
    Reader.ReadListEnd;
  finally
    Reader.Free;
  end;
end;
function TUmbCollection.Remove(AObject: TUmbCollectionItem): Integer;
begin
  Result := inherited Remove(AObject);
end;
procedure TUmbCollection.SetItems(Index: Integer; Value: TUmbCollectionItem);
begin
  inherited Items[Index] := Value;
end;
procedure TUmbCollection.WriteToStream(AStream: TStream);
var
  Writer: TWriter;
  CollectionList: TObjectList;
  Collection: TCollection;
  ItemClass: TUmbCollectionItemClass;
  ObjectWritten: array of Boolean;
  i, j: Integer;
begin
  Writer := TWriter.Create(AStream, 1024);
  CollectionList := TObjectList.Create(True);
  try
    Writer.WriteListBegin;
    {init the flag array and the position property of the TCollectionItem objects.}
    SetLength(ObjectWritten, Count);
    for i := 0 to Count - 1 do
    begin
      ObjectWritten[i] := False;
      Items[i].Position := i;
    end;
    {write the TCollectionItem objects. we write first the name of the objects class,
    then write all the object of the same class.}
    for i := 0 to Count - 1 do
    begin
      if ObjectWritten[i] then
        Continue;
      ItemClass := TUmbCollectionItemClass(Items[i].ClassType);
      Collection := TCollection.Create(ItemClass);
      CollectionList.Add(Collection);
      {write the items class name}
      Writer.WriteString(Items[i].ClassName);
      {insert the items to the collection}
      for j := i to Count - 1 do
        if ItemClass = Items[j].ClassType then
        begin
          ObjectWritten[j] := True;
          (Collection.Add as ItemClass).Assign(Items[j]);
        end;
      {write the collection}
      Writer.WriteCollection(Collection);
    end;
  finally
    CollectionList.Free;
    Writer.WriteListEnd;
    Writer.Free;
  end;
end;
{ TUmbCollectionItem }
procedure TUmbCollectionItem.Assign(Source: TPersistent);
begin
  if Source is TUmbCollectionItem then
    Position := (Source as TUmbCollectionItem).Position
  else
    inherited;
end;
end.

Сохранение точных размеров при печати.

Пример также демонстрирует вывод на печать синусной кривой в конкретной позиции печати с заданными в дюймах размерами. Я думаю вы без труда разберетесь как перейти на метрическую систему размеров.

unit Tstpr2fm;
{Пример использования объекта Printer из модуля TPrinter.
Приведен избыточный стиль программирования для облегчения
восприятия материала.
Демонстрация величин, возвращаемых функцией Windows API GetDeviceCaps.}
interface
uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, ExtCtrls;
type
  TForm1 = class(TForm)
    Print: TButton;
    Image1: TImage;
    procedure PrintClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
var
  Form1: TForm1;
implementation
uses
  Printers;
{Константы WINAPI GetDeviceCaps получены из C++ windows.h и wingdi.h}
{Отдельные константы здесь приведены только для информации о их наличии}
const
  DRIVERVERSION = 0;
  TECHNOLOGY = 2; {Смотри windows.h для значения маски}
  HORZSIZE = 4;
  VERTSIZE = 6;
  HORZRES = 8;
  VERTRES = 10;
  BITSPIXEL = 12;
  PLANES = 14;
  NUMBRUSHES = 16;
  NUMPENS = 18;
  NUMMARKERS = 20;
  NUMFONTS = 22;
  NUMCOLORS = 24;
  PDEVICESIZE = 26;
  CURVECAPS = 28; {Смотри windows.h для значения маски}
  LINECAPS = 30; {Смотри windows.h для значения маски}
  POLYGONALCAPS = 32; {Смотри windows.h для значения маски}
  TEXTCAPS = 34; {Смотри windows.h для значения маски}
  CLIPCAPS = 36; {Смотри windows.h для значения маски}
  RASTERCAPS = 38; {Смотри windows.h для значения маски}
  ASPECTX = 40;
  ASPECTY = 42;
  ASPECTXY = 44;
  LOGPIXELSX = 88;
  LOGPIXELSY = 90;
  SIZEPALETTE = 104;
  NUMRESERVED = 106;
  COLORRES = 108;
  PHYSICALWIDTH = 110; {Смотри определение в windows.h}
  PHYSICALHEIGHT = 111; {Смотри определение в windows.h}
  PHYSICALOFFSETX = 112; {Смотри определение в windows.h}
  PHYSICALOFFSETY = 113; {Смотри определение в windows.h}
  SCALINGFACTORX = 114; {Смотри определение в windows.h}
  SCALINGFACTORY = 115; {Смотри определение в windows.h}
  DeviceCapsString: array[1..34] of string =
  ('DRIVERVERSION', 'TECHNOLOGY', 'HORZSIZE',
    'VERTSIZE', 'HORZRES', 'VERTRES',
    'BITSPIXEL', 'PLANES', 'NUMBRUSHES',
    'NUMPENS', 'NUMMARKERS', 'NUMFONTS',
    'NUMCOLORS', 'PDEVICESIZE', 'CURVECAPS',
    'LINECAPS', 'POLYGONALCAPS', 'TEXTCAPS',
    'CLIPCAPS', 'RASTERCAPS', 'ASPECTX',
    'ASPECTY', 'ASPECTXY', 'LOGPIXELSX',
    'LOGPIXELSY', 'SIZEPALETTE', 'NUMRESERVED',
    'COLORRES', 'PHYSICALWIDTH', 'PHYSICALHEIGHT',
    'PHYSICALOFFSETX', 'PHYSICALOFFSETY', 'SCALINGFACTORX',
    'SCALINGFACTORY');
  DeviceCapsIndex: array[1..34] of INTEGER =
  (0, 2, 4, 6, 8, 10, 12, 14, 16, 18,
    20, 22, 24, 26, 28, 30, 32, 34, 36, 38,
    40, 42, 44, 88, 90, 104, 106, 108, 110, 111,
    112, 113, 114, 115);
{$R *.DFM}
function iPosition(const i: INTEGER): INTEGER;
begin
  RESULT := Integer(i * LongInt(Printer.PageWidth) div 1000)
end {iPosition};
function jPosition(const j: INTEGER): INTEGER;
begin
  RESULT := Integer(j * LongInt(Printer.PageHeight) div 1000)
end {jPosition};
procedure TForm1.PrintClick(Sender: TObject);
var
  DestinationRectangle: TRect;
  GraphicAspectRatio: DOUBLE;
  i: INTEGER;
  j: INTEGER;
  iBase: INTEGER;
  iPixelsPerInch: WORD;
  jBase: INTEGER;
  jDelta: INTEGER;
  jPixelsPerInch: WORD;
  OffScreen: TBitMap;
  PixelAspectRatio: DOUBLE;
  SourceRectangle: TRect;
  TargetRectangle: TRect;
  value: INTEGER;
  x: DOUBLE;
  y: DOUBLE;
begin
  Printer.Orientation := poLandscape;
  Printer.BeginDoc;
  {Делаем прямоугольник для показа полей}
  Printer.Canvas.Rectangle(0, 0, Printer.PageWidth, Printer.PageHeight);
  {Свойства принтера и страницы}
  Printer.Canvas.Font.Name := 'Times New Roman';
  Printer.Canvas.Font.Size := 12;
  Printer.Canvas.Font.Style := [fsBold];
  Printer.Canvas.TextOut(iPosition(50), jPosition(40),
    'Свойства принтера и страницы');
  Printer.Canvas.Font.Style := [];
  Printer.Canvas.Font.Size := 10;
  iBase := iPosition(50);
  jBase := 60;
  jDelta := 18;
  Printer.Canvas.TextOut(iPosition(50), jPosition(jBase),
    Printer.Printers.Strings[Printer.PrinterIndex]);
  INC(jBase, jDelta);
  Printer.Canvas.TextOut(iBase, jPosition(jBase),
    'Пикселей:  ' + IntToStr(Printer.PageWidth) + ' X ' +
    IntToStr(Printer.PageHeight));
  INC(jBase, jDelta);
  Printer.Canvas.TextOut(iBase, jPosition(jBase),
    'Дюймов:  ' + FormatFloat('0.000',
    Printer.PageWidth / Printer.Canvas.Font.PixelsPerInch) + ' X ' +
    FormatFloat('0.000',
    Printer.PageHeight / Printer.Canvas.Font.PixelsPerInch));
  INC(jBase, 2 * jDelta);
  Printer.Canvas.TextOut(iBase, jPosition(jBase),
    'Шрифт:  ' + Printer.Canvas.Font.Name + '   Размер:  ' +
    IntToStr(Printer.Canvas.Font.Size));
  INC(jBase, jDelta);
  Printer.Canvas.TextOut(iBase, jPosition(jBase),
    'Пикселей в дюйме:  ' + IntToStr(Printer.Canvas.Font.PixelsPerInch));
  INC(jBase, jDelta);
  Printer.Canvas.TextOut(iBase, jPosition(jBase),
    '''ТЕКСТ'':  ' + IntToStr(Printer.Canvas.TextWidth('ТЕКСТ')) + ' X ' +
    IntToStr(Printer.Canvas.TextHeight('ТЕКСТ')) + '
    пикселей');
    {Значения GetDeviceCaps}
    INC(jBase, 2 * jDelta);
    Printer.Canvas.Font.Size := 12;
    Printer.Canvas.Font.Style := [fsBold];
    Printer.Canvas.TextOut(iBase, jPosition(jBase), 'GetDeviceCaps');
    INC(jBase, jDelta);
    Printer.Canvas.Font.Size := 10;
    Printer.Canvas.Font.Style := [];
    for j := LOW(DeviceCapsIndex) to HIGH(DeviceCapsIndex) do
    begin
      value := GetDeviceCaps(Printer.Handle, DeviceCapsIndex[j]);
      Printer.Canvas.TextOut(iBase, jPosition(jBase), DeviceCapsString[j]);
      if (DeviceCapsIndex[j] < 28) or (DeviceCapsIndex[j] > 38) then
        Printer.Canvas.TextOut(iPosition(250), jPosition(jBase), Format('%-8d',
          [value]))
      else
        Printer.Canvas.TextOut(iPosition(250), jPosition(jBase), Format('%.4x',
          [value]));
      INC(jBase, jDelta);
    end;
    {Помещаем изображение в левый нижний угол}
    Printer.Canvas.Draw(iPosition(300), jPosition(100),
    Form1.Image1.Picture.Graphic);
    {Помещаем то же изображение, имеющее ширину 1" и пропорциональную
    высоту в позиции 4"-правее и 1"-ниже верхнего левого угла}
    GraphicAspectRatio := Form1.Image1.Picture.Height /
    Form1.Image1.Picture.Width;
    iPixelsPerInch := GetDeviceCaps(Printer.Handle, LOGPIXELSX);
    jPixelsPerInch := GetDeviceCaps(Printer.Handle, LOGPIXELSY);
    PixelAspectRatio := jPixelsPerInch / iPixelsPerInch;
    TargetRectangle := Rect(4 * iPixelsPerInch, {4"}
    jPixelsPerInch, {1"}
    6 * iPixelsPerInch, {6" -- 2" ширина}
    jPixelsPerInch +
    TRUNC(2 * iPixelsPerInch * GraphicAspectRatio *
    PixelAspectRatio));
    Printer.Canvas.TextOut(4 * iPixelsPerInch, jPixelsPerInch -
    Printer.Canvas.TextHeight('X'),
    '2" ширина от (4", 1")');
    Printer.Canvas.StretchDraw(TargetRectangle, Form1.Image1.Picture.Graphic);
    {Создаем изображение в памяти и затем копируем его на холст принтера}
    SourceRectangle := Rect(0, 0, 3 * iPixelsPerInch - 1, 2 * jPixelsPerInch -
      1);
    {Это не должно работать!  Rectangle = Left, Top, Right, Bottom
    Top и Bottom считаются зарезервированными?}
    DestinationRectangle := Rect(4 * iPixelsPerInch, 6 * jPixelsPerInch,
    7 * iPixelsPerInch - 1, 4 * jPixelsPerinch - 1);
    Printer.Canvas.TextOut(4 * iPixelsPerInch, 4 * jPixelsPerInch -
    Printer.Canvas.TextHeight('X'),
    IntToStr(3 * iPixelsPerInch) + ' пикселей на ' +
    IntToStr(2 * jPixelsPerInch) + ' пикселей -- ' +
    '3"-на-2" в (4",4")');
    OffScreen := TBitMap.Create;
    try
      OffScreen.Width := SourceRectangle.Right + 1;
      OffScreen.Height := SourceRectangle.Bottom + 1;
      with OffScreen.Canvas do
      begin
        Pen.Color := clBlack;
        Brush.Color := clWhite;
        Rectangle(0, 0, 3 * iPixelsPerInch - 1, 2 * jPixelsPerInch - 1);
        Brush.Color := clRed;
        MoveTo(0, 0);
        LineTo(3 * iPixelsPerInch - 1, 2 * jPixelsPerInch - 1);
        Brush.Color := clBlue;
        MoveTo(0, 0);
        for i := 0 to 3 * iPixelsPerInch - 1 do
        begin
          x := 12 * PI * (i / (3 * iPixelsPerInch - 1));
          y := jPixelsPerInch + jPixelsPerInch * SIN(x);
          LineTo(i, TRUNC(y));
        end
      end;
      Printer.Canvas.CopyRect(DestinationRectangle, OffScreen.Canvas,
        SourceRectangle);
    finally
      OffScreen.Free
    end;
    {Список шрифтов для данного принтера}
    iBase := iPosition(750);
    Printer.Canvas.Font.Name := 'Times New Roman';
    Printer.Canvas.Font.Size := 12;
    Printer.Canvas.Font.Style := [fsBold];
    Printer.Canvas.TextOut(iBase, jPosition(40), 'Шрифты');
    Printer.Canvas.Font.Style := [];
    Printer.Canvas.Font.Size := 10;
    jDelta := 16;
    for j := 0 to Printer.Fonts.Count - 1 do
    begin
      Printer.Canvas.TextOut(iBase, jPosition(60 + jDelta * j),
        Printer.Fonts.Strings[j])
    end;
    Printer.EndDoc;
end;
end.

Сохранение пользовательских настроек.

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

const
  FileName = 'Form1.stm';
constructor TForm1.Create(AOwner: TComponent);
begin
  if FileExists(FileName) then
  begin
    CreateNew(AOwner);
    ReadComponentResFile(FileName, Self);
  end
  else
    inherited Create(AOwner);
  { поместите здесь код в стиле 'OnCreate' }
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
  WriteComponentResFile(FileName, Self);
end;

Имейте в виду, что это не вызывает OnCreate. В действительности, вам OnCreate и не нужен, поскольку сюда вы можете поместить код, необходимый в обработчике OnCreate; данный код следует поместить после конструктора Create, как и указано в комментарии.

Как сохранить исходник HTML из TWebBrowser.Document на диск.

TWebBrowser.Document включает в себя IPersistStreamInit который содержит метод Save(). Всё, что нам нужно знать, это как использовать данный метод с объектом, который включён в IStream. Для этого мы просто воспользуемся TStreamAdapter.

Обратите внимание, что интерфейсы IPersistStreamInit и IStream объявлены внутри ActiveX unit.

Итак, вот так это выглядит.

procedure TForm1.SaveHTMLSourceToFile(const FileName: string;
WB: TWebBrowser);
var
  PersistStream: IPersistStreamInit;
  FileStream: TFileStream;
  Stream: IStream;
  SaveResult: HRESULT;
begin
  PersistStream := WB.Document as IPersistStreamInit;
  FileStream := TFileStream.Create(FileName, fmCreate);
  try
    Stream := TStreamAdapter.Create(FileStream, soReference) as IStream;
    SaveResult := PersistStream.Save(Stream, True);
    if FAILED(SaveResult) then
      MessageBox(Handle, 'Fail to save HTML source', 'Error', 0);
  finally
    { В ответ на уничтожение объекта TFileStream, передаём
    soReference в конструктор TStreamAdapter. }
    FileStream.Free;
  end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
  if SaveDialog1.Execute then
    SaveHTMLSourceToFile(SaveDialog1.FileName, WebBrowser1);
end;

А как сохранить вместе с исходником все файлы (.CSS, JPG, GIF и т.д...) ?

try 
  WebBrowser1.ExecWB(4, 0); 
except 
  on E: Exception do 
    msError := true; 
end; 

Сохранение и восстановление положения и размеров окон.

Автор: Desdechado WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Сохранение и восстановление положения и размеров окон
Процедуры SaveWndPos и SetWndPos работают в паре.
Сохраняют для конкретного пользователя Windows в реестре местоположение,
размер окон (и прочих Соntrоl'ов при явном указании),
а также ширины и порядок расположения колонок в DВGrid'ах на форме.
Не дает "потерять" колонки совсем.
Возможные проблемы:
1. С записью в реестр без прав (в некую левую ветку).
2. При изменении имен и количества полей в DВGrid'е.
3. С окнами неизменяемого размера, если его в Design-time поменяли.
Комментарии:
1. Статус колонки DBGrid (visible, readonly) не сохраняется, но сделать
это несложно.
2. Для формы, которая используются для разных целей, но хотелось бы
сохранить ее характеристики для каждой цели отдельно, можно явно
указывать УНИКАЛЬНЫЙ класс.
Важное уточнение:
Сохранение параметров DBGrid происходит ТОЛЬКО при статически
описанных колонках в самом гриде.
Еще комментарий:
параметр lSetSize в SetWndPos применяется только к размерам формы, а
не к ширине колонок. Но можно и это учесть.
Зависимости: Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, ExtCtrls, Buttons, Registry, Math, DB, DbTables, dbGrids
Автор:       Александр Хабаров aka Desdechado, x_a_u@mail.ru, Феодосия
Copyright:   Александр Хабаров
Дата:        13 мая 2002 г.
***************************************************** }
const
  cRegKey = '\Sоftwаrе\СооlSоft\Настройки\';
procedure SaveWndPos(frm: TControl; cClass: string = '');
var
  rct: TRect;
  oReg: TRegistry;
  grid: TDBGrid;
  i, j: Integer;
begin
  {--- определить параметры ---}
  rct := frm.BoundsRect;
  if (cClass = '') then
    cClass := frm.ClassName;
  {--- сохранить в реестре ---}
  oReg := TRegistry.Create();
  with (oReg) do
  try
    RootKey := HKEY_CURRENT_USER;
    {--- ... размер окна ---}
    if (OpenKey(cRegKey + cClass, True)) then
    begin
      if (frm is TForm) then
        WriteInteger('Show', Ord((frm as TForm).WindowState));
      if (not (frm is TForm) or
        ((frm as TForm).WindowState = wsNormal)) then
      begin
        WriteInteger('Left', rct.Left);
        WriteInteger('Top', rct.Top);
        WriteInteger('Right', rct.Right);
        WriteInteger('Bottom', rct.Bottom);
      end;
    end;
    CloseKey();
    {--- ... размеры и положение колонок в Grid'ах ---}
    for i := 0 to frm.ComponentCount - 1 do
      if (frm.Components[i].ClassName = D
        if (frm.Components[i].ClassName = 'TDBGrid') then
        begin
          grid := TDBGrid(frm.Components[i]);
          for j := 0 to grid.Columns.Count - 1 do
          begin
            if (OpenKey(cRegKey + cClass + '\' + grid.Name + '\' +
              IntToStr(j), True)) then
            begin
              WriteString('Name', grid.Columns[j].FieldName);
              WriteInteger('Width', grid.Columns[j].Width);
            end;
            CloseKey();
          end; // for( j )
        end;
  finally
    CloseKey();
    Free;
  end;
end;
procedure SetWndPos(frm: TControl; lSetSize: Boolean = True;
  cClass: string = '');
var
  rct: TRect;
  oReg: TRegistry;
  nShow, i, j, k: Integer;
  grid: TDBGrid;
  cName: string;
begin
  nShow := Ord(wsNormal);
  {--- текущие параметры (на случай, если нет в реестре) ---}
  rct := frm.BoundsRect;
  if (cClass = '') then
    cClass := frm.ClassName;
  if (frm is TForm) then
    nShow := Ord((frm as TForm).WindowState);
  {--- считать из реестра ---}
  oReg := TRegistry.Create();
  with (oReg) do
  try
    RootKey := HKEY_CURRENT_USER;
    {--- ... размер окна ---}
    if (OpenKeyReadOnly(cRegKey + cClass)) then
    begin
      if (frm is TForm) then
        nShow := ReadInteger('Show');
      if (ValueExists('Left')) then
        rct.Left := ReadInteger('Left');
      if (ValueExists('Top')) then
        rct.Top := ReadInteger('Top');
      if (ValueExists('Right')) then
        rct.Right := ReadInteger('Right');
      if (ValueExists('Bottom')) then
        rct.Bottom := ReadInteger('Bottom');
    end;
    CloseKey();
    {--- ... размеры и положение колонок в Grid'ах ---}
    for i := 0 to frm.ComponentCount - 1 do
      if (frm.Components[i].ClassName = 'TDBGrid') then
      begin
        grid := TDBGrid(frm.Components[i]);
        for j := 0 to grid.Columns.Count - 1 do
        begin
          if (OpenKeyReadOnly(cRegKey + cClass + '\' + grid.Name + '\' +
            IntToStr(j))) then
          begin
            cName := ReadString('Name');
            for k := 0 to grid.Columns.Count - 1 do
              if (grid.Columns[k].FieldName = cName) then
              begin
                grid.Columns[k].Index := j;
                break;
              end;
            grid.Columns[j].Width := ReadInteger('Width');
          end;
          CloseKey();
          {--- экстремальные ширины - нормировать ---}
          grid.Columns[j].Width := Max(grid.Columns[j].Width, 3);
          grid.Columns[j].Width := Min(grid.Columns[j].Width,
            grid.ClientWidth - 3);
        end; // for( j )
      end;
  finally
    CloseKey();
    Free;
  end;
  {--- применить считанное к окну ---}
  if (lSetSize) then
    frm.BoundsRect := rct
  else
  begin
    frm.Top := rct.Top;
    frm.Left := rct.Left;
  end;
  if ((frm is TForm) and (nShow = Ord(wsMaximized))) then
    (frm as TForm).WindowState := wsMaximized;
end;
procedure FitDeskTop(frm: TControl);
var
  rct: TRect;
begin
  rct := frm.BoundsRect;
  if (rct.Top < 0) then
    rct.Top := 0
  else if (rct.Bottom >= Screen.DeskTopHeight) then
    rct.Top := rct.Top + Screen.DeskTopHeight - rct.Bottom - 1;
  if (rct.Left < 0) then
    rct.Left := 0
  else if (rct.Right >= Screen.DeskTopWidth) then
    rct.Left := rct.Left + Screen.DeskTopWidth - rct.Right - 1;
  rct.Bottom := rct.Top + frm.Height;
  rct.Right := rct.Left + frm.Width;
  frm.BoundsRect := rct;
end;

Пример использования:

{
0. не забудьте поменять константу для СВОЕЙ ветки в реестре
1. после создания окна перед Show
2. перед frm.Release (удалением) надо вызывать SaveWndPos
}
procedure TfrmCard.FormCreate(Sender: TObject);
begin
  // прочий код здесь
  SetWndPos(Self);
end;
procedure TfrmCard.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  // прочий код здесь
  SaveWndPos(Self);
  Action := caFree;
end;

Сохранить документ Word как RTF.

uses 
  ComObj; 
function ConvertDoc2Rtf(var FileName: string) : Boolean;
var 
  oWord: OleVariant; 
  oDoc: OleVariant; 
begin 
  Result := False; 
  try 
    oWord := GetActiveOleObject('Word.Application'); 
  except 
    oWord := CreateOleObject('Word.Application'); 
  end; 
  oWord.Documents.Open(FileName); 
  oDoc  := oWord.ActiveDocument; 
  FileName := ChangeFileExt(FileName, '.rtf'); 
  oDoc.SaveAs(FileName); 
  oWord.ActiveDocument.Close(wdDoNotSaveChanges, EmptyParam, EmptyParam); 
  oWord.Quit(EmptyParam, EmptyParam, EmptyParam); 
  oDoc := VarNull; 
  oWord := VarNull; 
  Result := True; 
end; 
procedure TForm1.Button1Click(Sender: TObject); 
const 
  FileName = 'c:\Document.doc'; 
begin 
  if ConvertDoc2Rtf(FileName) then 
  begin 
    ShowMessage('Word document has been converted to .rtf'); 
    RichEdit1.Lines.LoadFromFile(FileName); 
  end; 
end;

Изменить шрифт TStatusBar.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

{ 
  To use this example, you need a TStatusBar and at least one Panel. 
  Then change the style of StatusBar1.Panels[0] to 
  psOwnerDraw and add the code below to the OnDrawPanel handler. 
  Es wird eine TStatusBar fur dieses Beispiel benotigt mit 
  mindestens einem Panel. 
  Der Style von StatusBar1.Panels[0] muss zu psOwnerDraw 
  geandert werden. 
  Fuge dann folgenden Code im OnDrawPanel Ereignis hinzu: 
}
 procedure TForm1.StatusBar1DrawPanel(StatusBar: TStatusBar;
   Panel: TStatusPanel; const Rect: TRect);
 var
   SomeText: string;
 begin
   if Panel = StatusBar1.Panels[0] then
   begin
     SomeText    := 'Hello!';
     Panel.Width := Trunc(StatusBar1.Canvas.TextWidth(SomeText) * 1.5);
     with StatusBar.Canvas do
      begin
       Brush.Color := clWhite;
       FillRect(Rect);
       Font.Name  := 'Arial';
       Font.Color := clRed;
       Font.Style := Font.Style + [fsItalic, fsBold];
       TextRect(Rect, Rect.Left + 1, Rect.Top, SomeText);
     end;
   end;
 end;

Из ресурсов поочередно загружать глифы для кнопок SpeedButton.

Например, если в вашем проекте используется TDBGrid, то иконки кнопок компонента DBNavigator могут линковаться вашей программой, и их можно загрузить для использования в ваших speedbutton следующим образом:

SpeedButton.Caption := '';
SpeedButton1.Glyph.LoadFromResourcename(HInstance,'DBN_REFRESH');
SpeedButton1.NumGlyphs := 2;

Все имена должны использовать верхний регистр.

Прокрутка TScrollBox с помощью стрелок вверх и вниз.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

private
   procedure CMDialogKey(var Msg: TCMDialogKey); message CM_DIALOGKEY;
 end;
 implementation
 procedure TForm1.CMDialogkey;
 begin
   with Scrollbox1.VertScrollBar do
   begin
     case Msg.CharCode of
       // Delphi takes care of Position < 0 or Position > Range 
      VK_DWON: Position := Position + Increment; // down arrow key 
      VK_Up: Position   := Position - Increment; // up arrow key 
      else
         inherited;
     end;
   end;
 end;

Масштабирование окна.

Автор: Andrey Kozlov.

implementation
const
  ScreenWidth: Integer = 800; {Я разрабатывал свою форму в режиме 800x600.}
  ScreenHeight: Integer = 600;
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
var
  x, y: LongInt; {Тип Integer не достаточно большой для наших значений.}
begin
  form1.scaled := true;
  x := getSystemMetrics(SM_CXSCREEN);
  y := getSystemMetrics(SM_CYSCREEN);
  if (x <> ScreenHeight) or (y <> ScreenWidth) then
  begin
    form1.height := form1.height * x div ScreenWidth;
    form1.width := form1.width * y div ScreenHeight;
  end;
  if x <> ScreenWidth then
    scaleBy(x, ScreenWidth);
end;

Файл DELSEQ07.FAQ содержит код примера отображения форм в различных разрешениях. К сожалению, он не учитывал ширину границы окна. Я публикую изменение, масштабирующее компоненты вне зависимости от разрешения экрана и ширины границ окон. Включите нижеследующий модуль в секцию uses каждого модуля и вызывайте ScaleForm в обработчике формы OnCreate, передавая в качестве параметра имя формы. Я надеюсь что помог тем, кто столкнулся с данной проблемой.

unit scale;
interface
uses
  Forms, WinTypes, WinProcs, SysUtils;
procedure ScaleForm(Sender: TObject);
implementation
procedure ScaleForm(Sender: TObject);
const
  {измените это так, чтобы это соответствовало
  режиму разрешения во время разработки}
  DesignScrY: LongInt = 480;
  DesignScrX: LongInt = 640;
  DesignBorder: LongInt = 4; {значение в Панели Управления + 1}
var
  SystemScrY: LongInt;
  SystemScrX: LongInt;
  SystemBorder: LongInt;
  OldHeight: LongInt;
  OldWidth: LongInt;
begin
  SystemScrY := GetSystemMetrics(SM_CYSCREEN);
  SystemScrX := GetSystemMetrics(SM_CXSCREEN);
  SystemBorder := GetSystemMetrics(SM_CYFRAME);
  with Sender as TForm do
  begin
    Scaled := True;
    AutoScroll := False;
    Top := Top * SystemScrX div DesignScrX;
    Left := Left * SystemScrX div DesignScrX;
    OldHeight := Height + (DesignBorder - SystemBorder) * 2;
    OldWidth := Width + (DesignBorder - SystemBorder) * 2;
    ScaleBy((OldWidth * SystemScrX div DesignScrX - SystemBorder * 2),
      (OldWidth - DesignBorder * 2));
    {
    Для форм не имеющих границ измените предшествующие
    три строки следующим способом:
    OldHeight := Height;
    OldWidth  := Width;
    ScaleBy(SystemScrX, DesignScrX);
    }
    Height := OldHeight * SystemScrY div DesignScrY;
    Width := OldWidth * SystemScrX div DesignScrX;
  end;
end;
begin
end.

Масштабирование окна 2.

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

implementation
const
  ScreenWidth: LongInt = 800; {Я разрабатывал мою форму в режиме 800x600.}
  ScreenHeight: LongInt = 600;
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
  scaled := true;
  if (screen.width <> ScreenWidth) then
  begin
    height := longint(height) * longint(screen.height) div ScreenHeight;
    width := longint(width) * longint(screen.width) div ScreenWidth;
    scaleBy(screen.width, ScreenWidth);
  end;
end;

Затем, вероятно, вы захотите иметь нечто, проверяющее размер шрифтов, OK. Прежде, чем вы измените размер шрифта, вам необходимо убедиться, что объект имеет свойство font. Это может быть сделано следующим образом:

uses typinfo;
var
  i: integer;
begin
  for i := componentCount - 1 downtto 0 do
    with components[i] do
    begin
      if GetPropInfo(ClassInfo, 'font') <> nil  then
        font.size := (NewFormWidth DIV OldFormWidth) * font.size;
    end;
end;

Масштабирование размера формы и размера шрифтов.

Попробуй следующий код. Он масштабирует как размер формы, так и размер шрифтов. Вызывай его в Form.FormCreate. Надеюсь это поможет.

unit geScale;
interface
uses Forms, Controls;
procedure geAutoScale(MForm: TForm);
implementation
type
  TFooClass = class(TControl); { необходимо выяснить защищенность }
  { свойства Font }
procedure geAutoScale(MForm: TForm);
const
  cScreenWidth: integer = 800;
  cScreenHeight: integer = 600;
  cPixelsPerInch: integer = 96;
  cFontHeight: integer = -11; {В режиме проектирование значение из Font.Height}
var
  i: integer;
begin
  {
  ВАЖНО!! : Установите в Инспекторе Объектов свойство Scaled TForm в FALSE.
  Следующая программа масштабирует форму так, чтобы она выглядела одинаково
  внезависимости от размера экрана и пикселей на дюйм. Расположенный ниже
  участок кода проверяет, отличается ли размер экрана во время выполнения
  от размера во время проектирования. Если да, Scaled устанавливается в True
  и компоненты снова масштабируются так, чтобы они выводились в той же
  позиции экрана, что и во время проектирования.
  }
  if (Screen.width &; lt > cScreenWidth) or (Screen.PixelsPerInch <>
    cPixelsPerInch) then
  begin
    MForm.scaled := TRUE;
    MForm.height := MForm.height * screen.Height div cScreenHeight;
    MForm.width := MForm.width * screen.width div cScreenWidth;
    MForm.ScaleBy(screen.width, cScreenWidth);
  end;
  {
  Этот код проверяет, отличается ли размер шрифта во времы выполнения от
  размера во время проектирования. Если во время выполнения pixelsperinch
  формы отличается от pixelsperinch во время проектирования, шрифты снова
  масштабируются так, чтобы форма не отличалась от той, которая была во
  время разработки. Масштабирование производится исходя из коэффициента,
  получаемого путем деления значения font.height во время проектирования
  на font.height во время выполнения. Font.size в этом случае работать не
  будет, так как это может дать результат больший, чем текущие размеры
  компонентов, при этом текст может оказаться за границами области компонента.
  Например, форма создана при размерах экрана 800x600 с установленными
  маленькими шрифтами, имеющими размер font.size = 8. Когда вы запускаете
  в системе с 800x600 и большими шрифтами, font.size также будет равен 8,
  но текст будет бОльшим чем при работе в системе с маленькими шрифтами.
  Данное масштабирование позволяет иметь один и тот же размер шрифтов
  при различных установках системы.
  }
  if (Screen.PixelsPerInch <> cPixelsPerInch) then
  begin
    for i := MForm.ControlCount - 1 downto 0 do
      TFooClass(MForm.Controls[i]).Font.Height :=
        (MForm.Font.Height div cFontHeight) *
        TFooClass(MForm.Controls[i]).Font.Height;
  end;
end;
end.

Технология без интересного имени или как работать со сканером.

Упрощенная схема действия приложения использующего TWAIN:

Для облегчения обработки полученных DIB данных в библиотеке имеется несколько сервисных функций:

TWAIN_DibWidth(hDib: HBitmap): Integer;
 // Получает ширину изображения в пикселях
 TWAIN_DibHeight(hDib: HBitmap): Integer;
// Получает высоту изображения в пикселях
 TWAIN_CreateDibPalette(hdib: HBitmap): Integer;
// Получает цветовую палитру изображения
 TWAIN_DrawDibToDC(hDC: HDC;
  dx, dy, w, h: Integer;
  hDib: HBitmap;
  sx, sy: Integer);
// Передает DIB данные в формате совместимым
// с указанным контекстом устройства.

Полный текст примера можно взять отсюда. Мы рассмотрим только функцию получения данных с TWAIN устройства:

procedure TForm1.Accquire1Click(Sender: TObject);
var
  dat: hBitMap;
  PInfo: PBitMapInfoHeader;
  Height, Width: integer;
  {Функция возведения 2 в степень s}
  function stp2(s: byte): longint;
  var
    m: longint;
    i: byte;
  begin
    m := 2;
    for i := 2 to s do
      m := m * 2;
    stp2 := m;
  end;
begin
  {Получаем указатель на графические данные}
  dat := TWAIN_AcquireNative(Handle, 0);
  if dat <> 0 then
  begin
    {Получаем указатель на область памяти содержащей DIB
     данные и блокируем область памяти}
    PInfo := GlobalLock(dat);
    {Анализируем полученные данные}
    Height := PInfo.biHeight;
    Width := PInfo.biWidth;
    {Узнаем размер полученного изображения в сантиметрах}
    Wcm.Caption := floatToStrF(100 / PInfo.biXPelsPerMeter * Width, ffNumber, 8,
      3)
      + ' cm';
    Hcm.Caption := floatToStrF(100 / PInfo.biYPelsPerMeter * Height, ffNumber,
      8, 3)
      + ' cm';
    {Определяем число цветов в изображении}
    Colors.Caption := floatToStrF(stp2(PInfo.biBitCount), ffNumber, 8, 0) +
      ' цветов';
    {Разблокируем память}
    GlobalUnlock(dat);
    {Передаем в битовую матрицу графические данные}
    {И устанавливаем перехват ошибок}
    try
      MyBitMap.Palette := TWAIN_CreateDibPalette(dat);
      MyBitMap.Width := Width;
      MyBitMap.Height := Height;
      TWAIN_DrawDibToDC(MyBitMap.Canvas.Handle, 0, 0, Width, Height, dat, 0, 0);
    except
      // Обрабатываем наиболее вероятную ошибку связанную
      // с не хваткой ресурсов для загрузки изображения
      on EOutOFResources do
        MessageDlg('TBitMap: Нет ресурсов для загрузки изображения!',
          mtError, [mbOk], 0);
    end;
    {Отображаем графические данные}
    Image1.Picture.Graphic := MyBitMap;
    {Освобождаем память занятую графическими данными}
    TWAIN_FreeNative(dat);
  end;
end;

Приведенный здесь пример тестировался на сканере Umax 2000P с драйвером VistaScan32 V3.52. При получении изображений следует помнить, что максимальный размер блока памяти, который может распределить Windows, составляет 2 Гб и при попытке сканировании страниц формата АЧ с высоким разрешением можно превысить этот предел. Кроме того, достаточно простой в обращении объект TBitMap имеет куда более серьезные ограничения на размер загружаемых изображений, что требует непосредственной работы с DIB данными. Но это уже тема для отдельной статьи. Если у Вас появились вопросы или предложения пишите мне: speclab@4unet.ru.

Сканирование версии структуры базы данных.

Очевидно, BDE содержит номер версии структуры, по крайней мере для файлов Paradox. (Я не могу поручиться за dBase и другие форматы.) Всякий раз при изменении структуры (например, в Database Desktop) BDE увеличивает номер версии. Следующий модуль содержит функцию, которая возвращает версию структуры базы данных:

(*****************************************************************************
* DbUtils.pas
*
* Утилита для работы с базами данных
*
* Создана 09/20/96
*****************************************************************************)
unit Dbutils;
(****************************************************************************)
(****************************************************************************)
interface
(****************************************************************************)
(****************************************************************************)
uses DbTables;
function DbGetVersion(table: TTable): LongInt;
(****************************************************************************)
(****************************************************************************)
implementation
(****************************************************************************)
(****************************************************************************)
uses
  Db, DbiProcs, DbiTypes, {DbiErrs,}
  SysUtils;
{---------------------------------------------------------------------------}
(*
* Цель:                    определение номера версии структуры таблицы
* Параметры:               table (I) - интересующая нас таблица
* Возвращаемая величина:   номер версии
* Исключительная ситуация: EDatabaseError
*)
function DbGetVersion(table: TTable): LongInt;
var
  hCursor: hDBICur;
  tableDesc: TBLFullDesc;
  cName: array[0..255] of Char;
begin
  { копируем имя таблицы в строку 'с' }
  StrPCopy(cName, table.TableName);
  { просим BDE создать запись, содержащую информацию об определенной таблице }
  Check(DbiOpenTableList(table.DBHandle, True, False, cName, hCursor));
  { получаем запись, содержащую информацию о структуре }
  Check(DbiGetNextRecord(hCursor, dbiNOLOCK, @tableDesc, nil));
  { возвращаем поле записи, содержащее номер версии структуры нашей таблицы }
  Result := tableDesc.tblExt.iRestrVersion;
  Check(DbiCloseCursor(hCursor));
end;
end.

Рекурсивный проход дерева каталогов.

Автор: Vit WEB-сайт: http://forum.vingrad.ru

procedure ScanDir(Dir: string);
var
  SearchRec: TSearchRec;
begin
  if Dir <> '' then
    if Dir[length(Dir)] <> '\' then
      Dir := Dir + '\';
  if FindFirst(Dir + '*.*', faAnyFile, SearchRec) = 0 then
    repeat
      if (SearchRec.name = '.') or (SearchRec.name = '..') then
        continue;
      if (SearchRec.Attr and faDirectory) <> 0 then
        ScanDir(Dir + SearchRec.name)
          //we found Directory: "Dir+SearchRec.name"
      else
        Showmessage(Dir + SearchRec.name);
      //we found File: "Dir+SearchRec.name"
    until
      FindNext(SearchRec) <> 0;
  FindClose(SearchRec);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
  ScanDir('c:');
end;

Как получить список файлов со всеми подкаталогами.

Оформил: DeeCo

Автор: Анатолий Подгорецкий.

procedure ScanDir(StartDir: string; Mask: string; List: TStrings);
var
  SearchRec: TSearchRec;
begin
  if Mask = '' then
    Mask := '*.*';
  if StartDir[Length(StartDir)] <> '\' then
    StartDir := StartDir + '\';
  if FindFirst(StartDir + Mask, faAnyFile, SearchRec) = 0 then
  begin
    repeat Application.ProcessMessages;
      if (SearchRec.Attr and faDirectory) <> faDirectory then
        List.Add(StartDir + SearchRec.Name)
      else if (SearchRec.Name <> '..') and (SearchRec.Name <> '.')thenbegin
        List.Add(StartDir + SearchRec.Name + '\');
      ScanDir(StartDir + SearchRec.Name + '\', Mask, List);
  end;
until FindNext(SearchRec) <> 0;
FindClose(SearchRec);
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ListBox1.Items.Clear;
  ScanDir('c:', '', ListBox1.Items);
  Label1.Caption := IntToStr(ListBox1.Items.Count);
end;

Сканируем файл в поисках текста.

function ScanFile(const FileName: string; 
  const forString: string; 
  caseSensitive: Boolean): Longint; 
  { returns position of string in file or -1, if not found } 
const 
  BufferSize = $8001;  { 32K+1 bytes } 
var 
  pBuf, pEnd, pScan, pPos: PChar; 
  filesize: LongInt; 
  bytesRemaining: LongInt; 
  bytesToRead: Word; 
  F: file; 
  SearchFor: PChar; 
  oldMode: Word; 
begin 
  Result := -1;  { assume failure } 
  if (Length(forString) = 0) or (Length(FileName) = 0) then Exit; 
  SearchFor := nil; 
  pBuf      := nil; 
  { open file as binary, 1 byte recordsize } 
  AssignFile(F, FileName); 
  oldMode  := FileMode; 
  FileMode := 0;    { read-only access } 
  Reset(F, 1); 
  FileMode := oldMode; 
  try { allocate memory for buffer and pchar search string } 
    SearchFor := StrAlloc(Length(forString) + 1); 
    StrPCopy(SearchFor, forString); 
    if not caseSensitive then  { convert to upper case } 
      AnsiUpper(SearchFor); 
    GetMem(pBuf, BufferSize); 
    filesize       := System.Filesize(F); 
    bytesRemaining := filesize; 
    pPos           := nil; 
    while bytesRemaining > 0 do  
    begin 
      { calc how many bytes to read this round } 
      if bytesRemaining >= BufferSize then 
        bytesToRead := Pred(BufferSize) 
      else 
        bytesToRead := bytesRemaining; 
      { read a buffer full and zero-terminate the buffer } 
      BlockRead(F, pBuf^, bytesToRead, bytesToRead); 
      pEnd  := @pBuf[bytesToRead]; 
      pEnd^ := #0; 
       { scan the buffer. Problem: buffer may contain #0 chars! So we 
         treat it as a concatenation of zero-terminated strings. } 
      pScan := pBuf; 
      while pScan < pEnd do  
      begin 
        if not caseSensitive then { convert to upper case } 
          AnsiUpper(pScan); 
        pPos := StrPos(pScan, SearchFor);  { search for substring } 
        if pPos <> nil then  
        begin { Found it! } 
          Result := FileSize - bytesRemaining + 
            Longint(pPos) - Longint(pBuf); 
          Break; 
        end; 
        pScan := StrEnd(pScan); 
        Inc(pScan); 
      end; 
      if pPos <> nil then Break; 
      bytesRemaining := bytesRemaining - bytesToRead; 
      if bytesRemaining > 0 then  
      begin 
       { no luck in this buffers load. We need to handle the case of 
         the search string spanning two chunks of file now. We simply 
         go back a bit in the file and read from there, thus inspecting 
         some characters twice 
       } 
        Seek(F, FilePos(F) - Length(forString)); 
        bytesRemaining := bytesRemaining + Length(forString); 
      end; 
    end; { While } 
  finally 
    CloseFile(F); 
    if SearchFor <> nil then StrDispose(SearchFor); 
    if pBuf <> nil then FreeMem(pBuf, BufferSize); 
  end; 
end; { ScanFile }

Сканирование shared-ресурсов.

Оформил: DeeCo

В результате экспериментов с NetBIOS был реализован метод сканирования Internet в поисках открытых для записи разделяемых (shared) ресурсов. Подобная идея уже применялась в Legion, но простое дополнение этой схемы простейшим алгоритмом подбора паролей позволило добиться неожиданно "хороших" результатов.

Сканирование выполняется параллельно для каждого из заданных адресов (при наличии достаточных ресурсов у атакующего). Сканируется сеть класса C, кроме 1.2.3.0 и 1.2.3.255.

Первая стадия - сбор данных.

Вторая стадия - подбор паролей. Все имена пользователей, полученные на первой стадии, объединяются в один список, что позволяет учесть доменную архитектуру систем на базе Windows NT. На этой стадии проверяются соединения типа net use \\1.2.3.4\IPC$ password /user:username. Если соединение успешно, то проверяются все возможность подключения ко всем shared resources, и, когда подключение успешно, возможность записи.

(1) Null session - анонимное соединение (с пустым именем и паролем). То же, что и net use \\1.2.3.4\IPC$ "" /user:"" (2) Это не совсем верно. Правильным вариантом было бы все равно проверять все имена, и каждый раз отслеживать изменения прав доступа к shared resources.

Атака может быть предотвращена следующими методами:

Введение account lockout смысла, скорее всего, не имеет, поскольку проводятся всего две попытки угадать пароль.

Стандартное протоколирование доступа методами NT не позволяет установить IP атакующего (только NetBIOS имя машины и домен, которые могут быть произвольно изменены). Однако протокол позволяет идентифицировать прошедшую атаку: сначала идет одна запись об успешном входе в систему пользователя ANONYMOUS, а потом (после паузы около минуты) серия записей о неуспешных попытках входа с разными именами пользователей (в том числе и тех, которых нет на этой машине; по две записи на имя). Если среди них есть хотя бы одна запись об успешном входе, систему следует считать скомпрометированной.

Для проверки метода была написана программа, реализующая вышеописанный алгоритм (это заняло около 6 часов вместе с тестированием и перерывами на покурить). Тестовые сканирования проводились на Dual Celeron 400MHz 96Mb RAM с одновременным запуском до 128 потоков.

Был проведен ряд экспериментальных сканирований. В качестве источника адресов подсетей был использован Intruders list, полученный при помощи BlackICE, однако разработка алгорима быстрого определения "населенных" подсетей не представляет никакой сложности. Сканирование 254 адресов занимает от двух до десяти минут в зависимости от качества связи и общего количества имен пользователей в сети.

Кратко сформулированный результат такой:

Кроме того: за два часа не очень напряженной работы можно найти три машины с Windows NT, к которым можно подключиться по сети с правами администратора (CONNECT: Administrator : <NO PASSWORD> :).

Детальная статистика:

Всего адресов просканировано 1524 100% На ping ответило 442 29% Null session установлено с 102 6.7% Guest разрешен(1) 57 3.7% Уязвимых машин(2) 45 3.0%

(1) Т.е. возможно подключение к IPC$ со случайным именем (2) Уязвимыми считались все машины, которые позволяли подключить разделяемый ресурс хотя бы на чтение.

Распределение платформ. Всего успешных запросов 102 100% Windows 95/98 58 57% Windows NT или SAMBA 44 43%

Пользователи. Всего имен проверено 177 100% С пустым паролем 10 6% С паролем, совпадающим с именем 10 6%

Shared resources. Всего директорий 278 100% Доступно на чтение 171 62% Доступно на запись 91 33%

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

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

Как получить Регистрационный Номер для Sceleton ScreenSaver.

Оформил: DeeCo Автор: http://www.cracklab.narod.ru

lea edx,[ebp-08]
lea eax,[ebp-020C] ;в eax введенный нами РН
call 0040791C
mov edx,[ebp-08]  ;в edx введенный нами РН
mov eax,[ebp-04]  ;в eax введенное нами имя
call 0043A7F4     ;вызов функции генерации и проверки РН
Зайдем в эту функцию (F8) и вывалимся тут:
push ebp
mov ebp, esp
add esp, -10
push ebx
xor ecx, ecx

call 0043A6FC ;здесь и "куют" нужный нам РН
mov eax,[ebp-0C] ;здесь нужный нам РН! нажимай d eax и он твой! (1)
mov edx,[ebp-08] ;а это введенный нами (2)
call 00403BB0    ;а это проверка наших РН'ов

s ds:0 l ffffffff "123321" и рядом в памяти валялся бы нужный нам номер!

Выключение компьютера в заданное время.

Оформил: DeeCo

Автор: Олег Агранович.

procedure ShutdownComputer;
var
  ph: THandle;
  tp, prevst: TTokenPrivileges;
  rl: DWORD;
begin
  OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES or
    TOKEN_QUERY, ph);
  LookupPrivilegeValue(nil, 'SeShutdownPrivilege', tp.Privileges[0].Luid);
  tp.PrivilegeCount := 1;
  tp.Privileges[0].Attributes := 2;
  AdjustTokenPrivileges(ph, FALSE, tp, SizeOf(prevst), prevst, rl);
  ExitWindowsEx(EWX_SHUTDOWN or EWX_POWEROFF, 0);
end;

ScreenMate.

P.s К сожалению вам надо позаботиться о кадрах анимации этого персонажа самим т.к рисунки я послать немогу...

{*******************************************************}
                                                      { }
                           { Delphi VCL Extensions (RX) }
                                                      { }
                    { Copyright (c) 1995, 1996 AO ROSNO }
                 { Copyright (c) 1997, 1998 Master-Bank }
                                                      { }
{*******************************************************}
unit Animate;
interface
{$I RX.INC}
uses Messages, {$IFDEF WIN32}Windows, {$ELSE}WinTypes, WinProcs,
{$ENDIF}
  SysUtils, Classes, Graphics, Controls, Forms, StdCtrls, Menus,
  ExtCtrls;
type
  TGlyphOrientation = (goHorizontal, goVertical);
  { TRxImageControl }
  TRxImageControl = class(TGraphicControl)
  private
    FDrawing: Boolean;
  protected
    FGraphic: TGraphic;
    function DoPaletteChange: Boolean;
    procedure DoPaintImage; virtual; abstract;
    procedure PaintDesignRect;
    procedure PaintImage;
    procedure PictureChanged;
  public
    constructor Create(AOwner: TComponent); override;
  end;
  { TAnimatedImage }
  TAnimatedImage = class(TRxImageControl)
  private
    { Private declarations }
    FActive: Boolean;
    FAutoSize: Boolean;
    FGlyph: TBitmap;
    FImageWidth: Integer;
    FImageHeight: Integer;
    FInactiveGlyph: Integer;
    FOrientation: TGlyphOrientation;
    FTimer: TTimer;
    FNumGlyphs: Integer;
    FGlyphNum: Integer;
    FStretch: Boolean;
    FTransparentColor: TColor;
    FOpaque: Boolean;
    FTimerRepaint: Boolean;
    FOnFrameChanged: TNotifyEvent;
    FOnStart: TNotifyEvent;
    FOnStop: TNotifyEvent;
    procedure DefineBitmapSize;
    procedure ResetImageBounds;
    procedure AdjustBounds;
    function GetInterval: Cardinal;
    procedure SetAutoSize(Value: Boolean);
    procedure SetInterval(Value: Cardinal);
    procedure SetActive(Value: Boolean);
    procedure SetOrientation(Value: TGlyphOrientation);
    procedure SetGlyph(Value: TBitmap);
    procedure SetGlyphNum(Value: Integer);
    procedure SetInactiveGlyph(Value: Integer);
    procedure SetNumGlyphs(Value: Integer);
    procedure SetStretch(Value: Boolean);
    procedure SetTransparentColor(Value: TColor);
    procedure SetOpaque(Value: Boolean);
    procedure ImageChanged(Sender: TObject);
    procedure UpdateInactive;
    procedure TimerExpired(Sender: TObject);
    function TransparentStored: Boolean;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
  protected
    { Protected declarations }
    function GetPalette: HPALETTE; override;
    procedure Loaded; override;
    procedure Paint; override;
    procedure DoPaintImage; override;
    procedure FrameChanged; dynamic;
    procedure Start; dynamic;
    procedure Stop; dynamic;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure DoPaintImageOn(Mycanvas: Tcanvas; x, y: integer);
      virtual;
  published
    { Published declarations }
    property Active: Boolean read FActive write SetActive default
      False;
    property Align;
    property AutoSize: Boolean read FAutoSize write SetAutoSize
      default True;
    property Orientation: TGlyphOrientation read FOrientation write
      SetOrientation
      default goHorizontal;
    property Glyph: TBitmap read FGlyph write SetGlyph;
    property GlyphNum: Integer read FGlyphNum write SetGlyphNum
      default 0;
    property Interval: Cardinal read GetInterval write SetInterval
      default 100;
    property NumGlyphs: Integer read FNumGlyphs write SetNumGlyphs
      default 1;
    property InactiveGlyph: Integer read FInactiveGlyph write
      SetInactiveGlyph default -1;
    property TransparentColor: TColor read FTransparentColor write
      SetTransparentColor
      stored TransparentStored;
    property Opaque: Boolean read FOpaque write SetOpaque default
      False;
    property Color;
    property Cursor;
    property DragCursor;
    property DragMode;
    property ParentColor default True;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Stretch: Boolean read FStretch write SetStretch default
      True;
    property Visible;
    property OnClick;
    property OnDblClick;
    property OnMouseMove;
    property OnMouseDown;
    property OnMouseUp;
    property OnDragOver;
    property OnDragDrop;
    property OnEndDrag;
{$IFDEF WIN32}
    property OnStartDrag;
{$ENDIF}
    property OnFrameChanged: TNotifyEvent read FOnFrameChanged write
      FOnFrameChanged;
    property OnStart: TNotifyEvent read FOnStart write FOnStart;
    property OnStop: TNotifyEvent read FOnStop write FOnStop;
  end;
implementation
uses RxConst, VCLUtils;
{ TRxImageControl }
constructor TRxImageControl.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := [csClickEvents, csCaptureMouse, csOpaque,
{$IFDEF WIN32}csReplicatable, {$ENDIF}csDoubleClicks];
  Height := 105;
  Width := 105;
  ParentColor := True;
end;
procedure TRxImageControl.PaintImage;
var
  Save: Boolean;
begin
  Save := FDrawing;
  FDrawing := True;
  try
    DoPaintImage;
  finally
    FDrawing := Save;
  end;
end;
procedure TRxImageControl.PaintDesignRect;
begin
  if csDesigning in ComponentState then
    with Canvas do
    begin
      Pen.Style := psDash;
      Brush.Style := bsClear;
      Rectangle(0, 0, Width, Height);
    end;
end;
function TRxImageControl.DoPaletteChange: Boolean;
var
  ParentForm: TCustomForm;
  Tmp: TGraphic;
begin
  Result := False;
  Tmp := FGraphic;
  if Visible and (not (csLoading in ComponentState)) and (Tmp <>
    nil)
{$IFDEF RX_D3} and (Tmp.PaletteModified){$ENDIF} then
  begin
    if (GetPalette <> 0) then
    begin
      ParentForm := GetParentForm(Self);
      if Assigned(ParentForm) and ParentForm.Active and
        Parentform.HandleAllocated then
      begin
        if FDrawing then
          ParentForm.Perform(WM_QUERYNEWPALETTE, 0, 0)
        else
          PostMessage(ParentForm.Handle, WM_QUERYNEWPALETTE, 0, 0);
        Result := True;
{$IFDEF RX_D3}
        Tmp.PaletteModified := False;
{$ENDIF}
      end;
    end
{$IFDEF RX_D3}
    else
    begin
      Tmp.PaletteModified := False;
    end;
{$ENDIF}
  end;
end;
procedure TRxImageControl.PictureChanged;
begin
  if (FGraphic <> nil) then
    if DoPaletteChange and FDrawing then
      Update;
  if not FDrawing then
    Invalidate;
end;
{ TAnimatedImage }
constructor TAnimatedImage.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FTimer := TTimer.Create(Self);
  Interval := 100;
  FGlyph := TBitmap.Create;
  FGraphic := FGlyph;
  FGlyph.OnChange := ImageChanged;
  FGlyphNum := 0;
  FNumGlyphs := 1;
  FInactiveGlyph := -1;
  FTransparentColor := clNone;
  FOrientation := goHorizontal;
  FAutoSize := True;
  FStretch := True;
  Width := 32;
  Height := 32;
end;
destructor TAnimatedImage.Destroy;
begin
  FOnFrameChanged := nil;
  FOnStart := nil;
  FOnStop := nil;
  FGlyph.OnChange := nil;
  Active := False;
  FGlyph.Free;
  inherited Destroy;
end;
procedure TAnimatedImage.Loaded;
begin
  inherited Loaded;
  ResetImageBounds;
  UpdateInactive;
end;
function TAnimatedImage.GetPalette: HPALETTE;
begin
  Result := 0;
  if not FGlyph.Empty then
    Result := FGlyph.Palette;
end;
procedure TAnimatedImage.ImageChanged(Sender: TObject);
begin
  FTransparentColor := FGlyph.TransparentColor and not PaletteMask;
  DefineBitmapSize;
  AdjustBounds;
  PictureChanged;
end;
procedure TAnimatedImage.UpdateInactive;
begin
  if (not Active) and (FInactiveGlyph >= 0) and
    (FInactiveGlyph < FNumGlyphs) and (FGlyphNum <> FInactiveGlyph) then
  begin
    FGlyphNum := FInactiveGlyph;
  end;
end;
function TAnimatedImage.TransparentStored: Boolean;
begin
  Result := (FGlyph.Empty and (FTransparentColor <> clNone)) or
    ((FGlyph.TransparentColor and not PaletteMask) <>
    FTransparentColor);
end;
procedure TAnimatedImage.SetOpaque(Value: Boolean);
begin
  if Value <> FOpaque then
  begin
    FOpaque := Value;
    PictureChanged;
  end;
end;
procedure TAnimatedImage.SetTransparentColor(Value: TColor);
begin
  if Value <> TransparentColor then
  begin
    FTransparentColor := Value;
    PictureChanged;
  end;
end;
procedure TAnimatedImage.SetOrientation(Value: TGlyphOrientation);
begin
  if FOrientation <> Value then
  begin
    FOrientation := Value;
    DefineBitmapSize;
    AdjustBounds;
    Invalidate;
  end;
end;
procedure TAnimatedImage.SetGlyph(Value: TBitmap);
begin
  FGlyph.Assign(Value);
end;
procedure TAnimatedImage.SetStretch(Value: Boolean);
begin
  if Value <> FStretch then
  begin
    FStretch := Value;
    PictureChanged;
    if Active then
      Repaint;
  end;
end;
procedure TAnimatedImage.SetGlyphNum(Value: Integer);
begin
  if Value <> FGlyphNum then
  begin
    if (Value < FNumGlyphs) and (Value >= 0) then
    begin
      FGlyphNum := Value;
      UpdateInactive;
      FrameChanged;
      PictureChanged;
    end;
  end;
end;
procedure TAnimatedImage.SetInactiveGlyph(Value: Integer);
begin
  if Value < 0 then
    Value := -1;
  if Value <> FInactiveGlyph then
  begin
    if (Value < FNumGlyphs) or (csLoading in ComponentState) then
    begin
      FInactiveGlyph := Value;
      UpdateInactive;
      FrameChanged;
      PictureChanged;
    end;
  end;
end;
procedure TAnimatedImage.SetNumGlyphs(Value: Integer);
begin
  FNumGlyphs := Value;
  if FInactiveGlyph >= FNumGlyphs then
  begin
    FInactiveGlyph := -1;
    FGlyphNum := 0;
  end
  else
    UpdateInactive;
  FrameChanged;
  ResetImageBounds;
  AdjustBounds;
  PictureChanged;
end;
procedure TAnimatedImage.DefineBitmapSize;
begin
  FNumGlyphs := 1;
  FGlyphNum := 0;
  FImageWidth := 0;
  FImageHeight := 0;
  if (FOrientation = goHorizontal) and (FGlyph.Height > 0) and
    (FGlyph.Width mod FGlyph.Height = 0) then
    FNumGlyphs := FGlyph.Width div FGlyph.Height
  else if (FOrientation = goVertical) and (FGlyph.Width > 0) and
    (FGlyph.Height mod FGlyph.Width = 0) then
    FNumGlyphs := FGlyph.Height div FGlyph.Width;
  ResetImageBounds;
end;
procedure TAnimatedImage.ResetImageBounds;
begin
  if FNumGlyphs < 1 then
    FNumGlyphs := 1;
  if FOrientation = goHorizontal then
  begin
    FImageHeight := FGlyph.Height;
    FImageWidth := FGlyph.Width div FNumGlyphs;
  end
  else {if Orientation = goVertical then}
  begin
    FImageWidth := FGlyph.Width;
    FImageHeight := FGlyph.Height div FNumGlyphs;
  end;
end;
procedure TAnimatedImage.AdjustBounds;
begin
  if not (csReading in ComponentState) then
  begin
    if FAutoSize and (FImageWidth > 0) and (FImageHeight > 0) then
      SetBounds(Left, Top, FImageWidth, FImageHeight);
  end;
end;
type
  TParentControl = class(TWinControl);

Создание хранителя экрана (Screen Saver).

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

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

Прежде всего создайте новый, пустой проект, выбрав пункт New Project из меню File. (Если вы находитесь в репозитарии, выберите "Blank project".).

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

BorderIcons     [biSystemMenu]
  biSystemMenu  True
  biMinimize    False
  biMaximize    False
BorderStyle     bsDialog
Caption         Configuration
Height          162
Name            CfgFrm
Position        poScreenCenter
Visible         False
Width           266

Нам необходимо предоставить возможность изменять максимальное количество сфер, выводимых на экране, их размер и скорость рисования. Для того, чтобы это сделать, добавьте следующие три компонента Label (из палитры Standard) и компонент SpinEdit (из палитры Samples): (Примечание: Для быстрого размещения этих компонентов на форме скопируйте этот текст в буфер обмена и замените текст описания формы, выводимый при нажатии на пункт меню "View as Text" контекстного меню формы.).

object Label1: TLabel
Left = 16
Top = 19
Width = 58
Height = 16
Alignment = taRightJustify
Caption = 'Сфер:'
end
object Label2: TLabel
Left = 41
Top = 59
Width = 33
Height = 16
Alignment = taRightJustify
Caption = 'Размер:'
end
object Label3: TLabel
Left = 29
Top = 99
Width = 45
Height = 16
Alignment = taRightJustify
Caption = 'Скорость:'
end
object spnSpheres: TSpinEdit
Left = 84
Top = 15
Width = 53
Height = 26
MaxValue = 500
MinValue = 1
TabOrder = 0
Value = 50
end
object spnSize: TSpinEdit
Left = 84
Top = 55
Width = 53
Height = 26
MaxValue = 250
MinValue = 50
TabOrder = 1
Value = 100
end
object spnSpeed: TSpinEdit
Left = 84
Top = 95
Width = 53
Height = 26
MaxValue = 10
MinValue = 1
TabOrder = 2
Value = 10
end

Наконец, нам необходимы три кнопки -- OK, Отмена и Тест. Кнопка Тест не является стандартной для диалогов настройки хранителей экрана, но она позволяет удобно и легко проверить сделанные изменения. Добавьте следующие три кнопки, используя компоненты BitBtn из палитры "Additional":

object btnOK: TBitBtn
Left = 153
Top = 11
Width = 89
Height = 34
TabOrder = 3
Kind = bkOK
end
object btnCancel: TBitBtn
Left = 153
Top = 51
Width = 89
Height = 34
TabOrder = 4
Kind = bkCancel
end
object btnTest: TBitBtn
Left = 153
Top = 91
Width = 89
Height = 34
Caption = 'Тест...'
TabOrder = 5
Kind = bkIgnore
end

Перейдите к редактору кода модуля Setup и добавьте следующее объявление в секции используемых модулей:

uses
  IniFiles;

Затем добавьте следующие объявления процедур в секцию private модуля TCfgFrm:

procedure LoadConfig;
procedure SaveConfig;

Теперь создайте код самих процедур после секции uses в разреле реализации:

const
CfgFile = 'SPHERES.INI';
procedure TCfgFrm.LoadConfig;
var
inifile : TIniFile;
begin
inifile := TIniFile.Create(CfgFile);
try
with inifile do begin
spnSpheres.Value := ReadInteger('Config', 'Spheres', 50);
spnSize.Value    := ReadInteger('Config', 'Size', 100);
spnSpeed.Value   := ReadInteger('Config', 'Speed', 10);
end;
finally
inifile.Free;
end;
end; {TCfgFrm.LoadConfig}
procedure TCfgFrm.SaveConfig;
var
inifile : TIniFile;
begin
inifile := TIniFile.Create(CfgFile);
try
with inifile do begin
WriteInteger('Config', 'Spheres', spnSpheres.Value);
WriteInteger('Config', 'Size', spnSize.Value);
WriteInteger('Config', 'Speed', spnSpeed.Value);
end;
finally
inifile.Free;
end;
end; {TCfgFrm.SaveConfig}

Для обеспечения необходимой функциональности нашей формы нам необходимо создать обработчики некоторых событий, чтобы правильно и в нужный момент загрузить или сохранить конфигурацию. Сначала, в момент запуска программы, нам необходимо автоматически загрузить сохраненную конфигурацию. Для этого нам нужно обработать событие событие OnCreate нашей конфигурационной формы. Дважды щелкните на событии OnCreate в Инспекторе Объектов и введите следующий код:

procedure TCfgFrm.FormCreate(Sender: TObject);
begin
  LoadConfig;
end; {TCfgFrm.FormCreate}

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

procedure TCfgFrm.btnOKClick(Sender: TObject);
begin
  SaveConfig;
  Close;
end; {TCfgFrm.btnOKClick}

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

procedure TCfgFrm.btnCancelClick(Sender: TObject);
begin
  Close;
end; {TCfgFrm.btnCancelClick}

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

procedure TCfgFrm.btnTestClick(Sender: TObject);
begin
  ScrnFrm.Show;
end; {TCfgFrm.btnTestClick}

Затем добавьте "Scrn" в список используемых модулей в секции реализации. Scrn - это модуль формы хранителя экрана, который мы создадим в следующем шаге. Ну а пока сохраните созданный нами модуль с именем "Cfg", выбрав пункт "Save File As" в меню "File".

Сам хранитель экрана будет просто большой, черной формой без заголовка, занимающей весь экран, на котором и будет разворачиваться наше представление. Для того, чтобы создать вторую форму, выберите пункт New Form в меню File или "Blank form" в репозитарии.

BorderIcons     []
  biSystemMenu  False
  biMinimize    False
  biMaximize    False
BorderStyle     bsNone
Color           clBlack
FormStyle       fsStayOnTop
Name            ScrnFrm
Visible         False

Расположите на форме единственный Delphi компонент - таймер из палитры System. Установите его свойства как указано ниже:

object tmrTick: TTimer
  Enabled = False
  OnTimer = tmrTickTimer
  Left = 199
  Top = 122
end

Больше никаких компонентов для этой формы не потребуется. Тем не менее мы должны добавить некоторый код, осуществляющий рисование затененных сфер. Переключитесь в редактор кода на модуль формы ScrnFrm. В секции private TScrnFrm добавьте следующее объявление процедуры:

procedure DrawSphere(x, y, size : integer; color : TColor);

Теперь, в секции реализации модуля, добавьте код для данной процедуры:

procedure TScrnFrm.DrawSphere(x, y, size : integer; color : TColor);
var
i, dw    : integer;
cx, cy   : integer;
xy1, xy2 : integer;
r, g, b  : byte;
begin
with Canvas do begin
{Заполняем установки карандаша и кисти.}
Pen.Style := psClear;
Brush.Style := bsSolid;
Brush.Color := color;
{Подготовим цвета для сфер.}
r := GetRValue(color);
g := GetGValue(color);
b := GetBValue(color);
{Рисуем сферу.}
dw := size div 16;
for i := 0 to 15 do begin
xy1 := (i * dw) div 2;
xy2 := size - xy1;
Brush.Color := RGB(Min(r + (i * 8), 255), Min(g + (i * 8), 255),
Min(b + (i * 8), 255));
Ellipse(x + xy1, y + xy1, x + xy2, y + xy2);
end;
end;
end; {TScrnFrm.DrawSphere}

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

Наверняка вы также обратили внимание на то, что функция периодически обращается другой функции, именуемой Min(). Так как это функция не является стандартной функцией Delphi, мы должны добавить ее объявление к данному модулю, выше объявления DrawSphere().

function Min(a, b : integer) : integer;
begin
if b < a then
Result := b
else
Result := a;
end; {Min}

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

procedure TScrnFrm.tmrTickTimer(Sender: TObject);
const
sphcount : integer = 0;
var
x, y    : integer;
size    : integer;
r, g, b : byte;
color   : TColor;
begin
if sphcount > CfgFrm.spnSpheres.Value then begin
Refresh;
sphcount := 0;
end;
Inc(sphcount);
x := Random(ClientWidth);
y := Random(ClientHeight);
size := CfgFrm.spnSize.Value + Random(50) - 25;
x := x - size div 2;
y := y - size div 2;
r := Random($80);
g := Random($80);
b := Random($80);
DrawSphere(x, y, size, RGB(r, g, b));
end; {TScrnFrm.tmrTickTimer}

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

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

uses
  Cfg;

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

Для начала добавьте следующее объявление переменной в секции реализации модуля:

var
  crs : TPoint;

Эта переменная необходима для хранения оригинальной позиции курсора мыши для ее последующего сравнения. Теперь добавьте следующее объявление в секции private модуля TScrnFrm:

procedure DeactivateScrnSaver(var Msg : TMsg; var Handled : boolean);

Добавьте соответствующий код в секцию реализации модуля:

procedure TScrnFrm.DeactivateScrnSaver(var Msg : TMsg; var Handled : boolean);
var
done : boolean;
begin
if Msg.message = WM_MOUSEMOVE then
done := (Abs(LOWORD(Msg.lParam) - crs.x) > 5) or
(Abs(HIWORD(Msg.lParam) - crs.y) > 5)
else
done := (Msg.message = WM_KEYDOWN) or (Msg.message = WM_ACTIVATE) or
(Msg.message = WM_ACTIVATEAPP) or (Msg.message = WM_NCACTIVATE);
if done then
Close;
end; {TScrnFrm.DeactivateScrnSaver}

При получении системного сообщения WM_MOUSEMOVE мы сравниваем новые координаты мыши с оригинальными. Если перемещение мыши превысило допустимое значение (в нашем случае порог составляет 5 пикселей), закрываем хранитель экрана. Далее проверяем нажатие клавиши или передачу фокуса другому окну или диалогу, и в этом случае также закрываем хранитель.

procedure TScrnFrm.FormShow(Sender: TObject);
begin
GetCursorPos(crs);
tmrTick.Interval      := 1000 - CfgFrm.spnSpeed.Value * 90;
tmrTick.Enabled       := true;
Application.OnMessage := DeactivateScrnSaver;
ShowCursor(false);
end; {TScrnFrm.FormShow}

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

procedure TScrnFrm.FormHide(Sender: TObject);
begin
Application.OnMessage := nil;
tmrTick.Enabled       := false;
ShowCursor(true);
end; {TScrnFrm.FormHide}

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

procedure TScrnFrm.FormActivate(Sender: TObject);
begin
WindowState := wsMaximized;
end; {TScrnFrm.FormActivate}

Сохраните созданный нами модуль ScrnFrm под именем "SCRN.PAS", выбрав пункт Save File в меню File.

Вы можете определить текст, который появится в списке хранителей экранов в Control Panel / Desktop, добавив директиву {$D текст} к исходному файлу проекта. Директива $D вставляет текст в описание модуля выполняемого файла. Чтобы Панель Управления "поняла" этот текст и принадлежность файла к хранителям экрана, описание должно начинаться с зарезервированного слова "SCRNSAVE".

Выберите пункт Project Source из меню View для редактирования исходного кода проекта. Под директивой "{$R *.RES}" добавьте следующую строчку:

{$D SCRNSAVE Spheres Screen Saver} 

Теперь при выводе списка доступных хранителей экранов в Контрольной Панели вы увидите текст "Spheres Screen Saver", позволяющий выбрать ваш маленький шедевр.

Windows запускает программу хранителя экрана при двух возможных условиях: 1) при активизации хранителя экрана, и 2) когда необходимо изменить его настройки. В обоих случаях Windows запускает одну и ту же программу. Для запуска программы в одном из двух режимов предусмотрен параметр командной строки - "/s" для активного режима и "/c" для режима конфигурации. Для корректной работы с Панелью управления наш хранитель экрана должен проверять командную строку на предмет наличия одного из ключа.

Когда хранитель экрана стартует в активном режиме (/s), нам необходимо создать и показать именно форму хранителя экрана. Но при этом нам также необходимо создать и форму конфигурации, поскольку она содержит все конфигурационные настройки. При закрытии формы хранителя экрана программа завершает свою работу. В этом режиме форма хранителя экрана является главной формой приложения - она запускается при старте приложения и при ее закрытии приложение завершается.

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

В нашем случае нам необходимо идентифицировать ScrnFrm как главную форму приложения, если в командной строке присутствовал параметр /s, в противном случае главной формой приложения должна быть форма CfgFrm. Чтобы это сделать, необходимо знать одну недокументированную характеристику VCL объекта TApplication: главной формой приложения становится первая форма, создаваемая вызовом Application.CreateForm(). Таким образом, для определения главной формы приложения согласно параметрам, передаваемым во время выполнения программы, следует отредактировать исходный код проекта следующим образом:

begin
if (ParamCount > 0) and (UpperCase(ParamStr(1)) = '/S') then begin
{ScrnFrm должна быть главной формой.}
Application.CreateForm(TScrnFrm, ScrnFrm);
Application.CreateForm(TCfgFrm, CfgFrm);
end else begin
{CfgFrm должна быть главной формой.}
Application.CreateForm(TCfgFrm, CfgFrm);
Application.CreateForm(TScrnFrm, ScrnFrm);
end;
Application.Run;
end.

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

(Примечание: для обеспечения показанной выше функциональности необходимо выключить опцию "Complete boolean eval" в пункте меню Options | Project | Compiler settings. В противном случае при отсутствии параметров командной строки будет возникать ошибка.).

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

uses
  Forms, SysUtils,
  Scrn in 'SCRN.PAS' {ScrnFrm},
  Cfg in 'CFG.PAS' {CfgFrm};

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

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

begin
{Возможен запуск только одной копии.}
if hPrevInst = 0 then begin
if (ParamCount > 0) and (UpperCase(ParamStr(1)) = '/S') then begin
...
end;
Application.Run;
end;
end;

Переменная hPrevInst является глобальной переменной, определенной в Delphi для ссылки на запущенные копиии текущей программы. Ее значение будет равно нулю, если хранитель экрана еще не был запущен.

Теперь сохраните файл проекта с именем "SPHERES.DPR" и скомпилируйте программу. Вот мы и получили хранитель экрана, полностью удовлетворяющий всем нашим требованиям. В случае отсутствия параметров в командной строке программа переходит в режим конфигурации, заданный по умолчанию. Вы можете протестировать активный режим, передавая в командной строке первым параметр "/s". (Смотри Run | Parameters...).

После отладки и проверки хранителя экрана вы уже можете его установить и использовать в системе. Для этого скопируйте исполняемый файл (SPHERES.EXE) в директорию Windows и измените его расширение на .SCR, в результате чего вы получите файл с именем SPHERES.SCR. Затем, войдя в Панель Управления, дважды щелкните на иконке Desktop, и выберите Screen Saver | Name. Вы должны увидеть "Spheres Screen Saver" в списке доступных хранителей экрана. Выбрав его и нажав на кнопку ОК, вы тем самым сделаете его активным системным хранителем.

Cfg.dfm

// Cfg.dfm
object CfgFrm: TCfgFrm
  Left = 196
    Top = 124
    BorderIcons = [biSystemMenu]
    BorderStyle = bsDialog
    Caption = 'Конфигурация'
    ClientHeight = 135
    ClientWidth = 258
    Font.Color = clWindowText
    Font.Height = -13
    Font.Name = 'System'
    Font.Style = []
    PixelsPerInch = 96
    Position = poScreenCenter
    OnCreate = FormCreate
    TextHeight = 16
    object Label1: TLabel
    Left = 16
      Top = 19
      Width = 58
      Height = 16
      Alignment = taRightJustify
      Caption = 'Сфер:'
  end
  object Label2: TLabel
    Left = 41
      Top = 59
      Width = 33
      Height = 16
      Alignment = taRightJustify
      Caption = 'Размер:'
  end
  object Label3: TLabel
    Left = 29
      Top = 99
      Width = 45
      Height = 16
      Alignment = taRightJustify
      Caption = 'Скорость:'
  end
  object spnSpheres: TSpinEdit
    Left = 84
      Top = 15
      Width = 53
      Height = 26
      MaxValue = 500
      MinValue = 1
      TabOrder = 0
      Value = 50
  end
  object spnSize: TSpinEdit
    Left = 84
      Top = 55
      Width = 53
      Height = 26
      MaxValue = 250
      MinValue = 50
      TabOrder = 1
      Value = 100
  end
  object spnSpeed: TSpinEdit
    Left = 84
      Top = 95
      Width = 53
      Height = 26
      MaxValue = 10
      MinValue = 1
      TabOrder = 2
      Value = 10
  end
  object btnOK: TBitBtn
    Left = 153
      Top = 11
      Width = 89
      Height = 34
      TabOrder = 3
      OnClick = btnOKClick
      Kind = bkOK
  end
  object btnCancel: TBitBtn
    Left = 153
      Top = 51
      Width = 89
      Height = 34
      TabOrder = 4
      OnClick = btnCancelClick
      Kind = bkCancel
  end
  object btnTest: TBitBtn
    Left = 153
      Top = 91
      Width = 89
      Height = 34
      Caption = 'Тест...'
      TabOrder = 5
      OnClick = btnTestClick
      Kind = bkIgnore
  end
end
// Cfg.pas
unit Cfg;
interface
uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, Buttons, Spin;
type
  TCfgFrm = class(TForm)
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    spnSpheres: TSpinEdit;
    spnSize: TSpinEdit;
    spnSpeed: TSpinEdit;
    btnOK: TBitBtn;
    btnCancel: TBitBtn;
    btnTest: TBitBtn;
    procedure FormCreate(Sender: TObject);
    procedure btnOKClick(Sender: TObject);
    procedure btnCancelClick(Sender: TObject);
    procedure btnTestClick(Sender: TObject);
  private
    { Private declarations }
    procedure LoadConfig;
    procedure SaveConfig;
  public
    { Public declarations }
  end;
var
  CfgFrm: TCfgFrm;
implementation
{$R *.DFM}
uses
  Scrn,
  IniFiles;
const
  CfgFile = 'SPHERES.INI';
procedure TCfgFrm.LoadConfig;
var
  inifile: TIniFile;
begin
  inifile := TIniFile.Create(CfgFile);
  try
    with inifile do
    begin
      spnSpheres.Value := ReadInteger('Config', 'Spheres', 50);
      spnSize.Value := ReadInteger('Config', 'Size', 100);
      spnSpeed.Value := ReadInteger('Config', 'Speed', 10);
    end;
  finally
    inifile.Free;
  end;
end; {TCfgFrm.LoadConfig}
procedure TCfgFrm.SaveConfig;
var
  inifile: TIniFile;
begin
  inifile := TIniFile.Create(CfgFile);
  try
    with inifile do
    begin
      WriteInteger('Config', 'Spheres', spnSpheres.Value);
      WriteInteger('Config', 'Size', spnSize.Value);
      WriteInteger('Config', 'Speed', spnSpeed.Value);
    end;
  finally
    inifile.Free;
  end;
end; {TCfgFrm.SaveConfig}
procedure TCfgFrm.FormCreate(Sender: TObject);
begin
  LoadConfig;
end; {TCfgFrm.FormCreate}
procedure TCfgFrm.btnOKClick(Sender: TObject);
begin
  SaveConfig;
  Close;
end; {TCfgFrm.btnOKClick}
procedure TCfgFrm.btnCancelClick(Sender: TObject);
begin
  Close;
end; {TCfgFrm.btnCancelClick}
procedure TCfgFrm.btnTestClick(Sender: TObject);
begin
  ScrnFrm.Show;
end; {TCfgFrm.btnTestClick}
end.
// SCRN.dfm
object ScrnFrm: TScrnFrm
  Left = 196
    Top = 98
    BorderIcons = []
    BorderStyle = bsNone
    Caption = 'ScrnFrm'
    ClientHeight = 101
    ClientWidth = 259
    Color = clBlack
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -13
    Font.Name = 'System'
    Font.Style = []
    FormStyle = fsStayOnTop
    OldCreateOrder = True
    OnActivate = FormActivate
    OnHide = FormHide
    OnShow = FormShow
    PixelsPerInch = 96
    TextHeight = 16
    object tmrTick: TTimer
    Enabled = False
      OnTimer = tmrTickTimer
      Left = 65535
      Top = 2
  end
end
// SCRN.pas
unit Scrn;
interface
uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, ExtCtrls;
type
  TScrnFrm = class(TForm)
    tmrTick: TTimer;
    procedure tmrTickTimer(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure FormHide(Sender: TObject);
    procedure FormActivate(Sender: TObject);
  private
    { Private declarations }
    procedure DrawSphere(x, y, size: integer; color: TColor);
    procedure DeactivateScrnSaver(var Msg: TMsg; var Handled: boolean);
  public
    { Public declarations }
  end;
var
  ScrnFrm: TScrnFrm;
implementation
{$R *.DFM}
uses
  Cfg;
var
  crs: TPoint; {Оригинальная позиция курсора мыши.}
function Min(a, b: integer): integer;
begin
  if b < a then
    Result := b
  else
    Result := a;
end; {Min}
procedure TScrnFrm.DrawSphere(x, y, size: integer; color: TColor);
var
  i, dw: integer;
  cx, cy: integer;
  xy1, xy2: integer;
  r, g, b: byte;
begin
  with Canvas do
  begin
    {Заполняем установки карандаша и кисти.}
    Pen.Style := psClear;
    Brush.Style := bsSolid;
    Brush.Color := color;
    {Подготовим цвета для сфер.}
    r := GetRValue(color);
    g := GetGValue(color);
    b := GetBValue(color);
    {Рисуем сферу.}
    dw := size div 16;
    for i := 0 to 15 do
    begin
      xy1 := (i * dw) div 2;
      xy2 := size - xy1;
      Brush.Color := RGB(Min(r + (i * 8), 255), Min(g + (i * 8), 255),
        Min(b + (i * 8), 255));
      Ellipse(x + xy1, y + xy1, x + xy2, y + xy2);
    end;
  end;
end; {TScrnFrm.DrawSphere}
procedure TScrnFrm.DeactivateScrnSaver(var Msg: TMsg; var Handled: boolean);
var
  done: boolean;
begin
  if Msg.message = WM_MOUSEMOVE then
    done := (Abs(LOWORD(Msg.lParam) - crs.x) > 5) or
      (Abs(HIWORD(Msg.lParam) - crs.y) > 5)
  else
    done := (Msg.message = WM_KEYDOWN) or (Msg.message = WM_KEYUP) or
      (Msg.message = WM_SYSKEYDOWN) or (Msg.message = WM_SYSKEYUP) or
      (Msg.message = WM_ACTIVATE) or (Msg.message = WM_NCACTIVATE) or
      (Msg.message = WM_ACTIVATEAPP) or (Msg.message = WM_LBUTTONDOWN) or
      (Msg.message = WM_RBUTTONDOWN) or (Msg.message = WM_MBUTTONDOWN);
  if done then
    Close;
end; {TScrnFrm.DeactivateScrnSaver}
procedure TScrnFrm.tmrTickTimer(Sender: TObject);
const
  sphcount: integer = 0;
var
  x, y: integer;
  size: integer;
  r, g, b: byte;
  color: TColor;
begin
  if sphcount > CfgFrm.spnSpheres.Value then
  begin
    Refresh;
    sphcount := 0;
  end;
  Inc(sphcount);
  x := Random(ClientWidth);
  y := Random(ClientHeight);
  size := CfgFrm.spnSize.Value + Random(50) - 25;
  x := x - size div 2;
  y := y - size div 2;
  r := Random($80);
  g := Random($80);
  b := Random($80);
  DrawSphere(x, y, size, RGB(r, g, b));
end; {TScrnFrm.tmrTickTimer}
procedure TScrnFrm.FormShow(Sender: TObject);
begin
  GetCursorPos(crs);
  tmrTick.Interval := 1000 - CfgFrm.spnSpeed.Value * 90;
  tmrTick.Enabled := true;
  Application.OnMessage := DeactivateScrnSaver;
  ShowCursor(false);
end; {TScrnFrm.FormShow}
procedure TScrnFrm.FormHide(Sender: TObject);
begin
  Application.OnMessage := nil;
  tmrTick.Enabled := false;
  ShowCursor(true);
end; {TScrnFrm.FormHide}
procedure TScrnFrm.FormActivate(Sender: TObject);
begin
  WindowState := wsMaximized;
end; {TScrnFrm.FormActivate}
end.
// Spheres.dpr
program Spheres;
uses
  Forms, SysUtils,
  Scrn in 'SCRN.PAS' {ScrnFrm},
  Cfg in 'CFG.PAS' {CfgFrm};
{$R *.RES}
{$D SCRNSAVE Spheres Screen Saver}
begin
  {Возможен запуск только одной копии.}
  if hPrevInst = 0 then
  begin
    if (ParamCount > 0) and (UpperCase(ParamStr(1)) = '/S') then
    begin
      {ScrnFrm должна быть главной формой.}
      Application.CreateForm(TScrnFrm, ScrnFrm);
      Application.CreateForm(TCfgFrm, CfgFrm);
    end
    else
    begin
      {CfgFrm должна быть главной формой.}
      Application.CreateForm(TCfgFrm, CfgFrm);
      Application.CreateForm(TScrnFrm, ScrnFrm);
    end;
    Application.Run;
  end;
end.
// Spheres.opt
[Compiler]
A = 1
B = 0
D = 1
F = 0
I = 1
K = 1
L = 1
P = 1
Q = 0
R = 0
S = 1
T = 0
U = 1
V = 1
W = 0
X = 1
Y = 1
[Linker]
MapFile = 0
LinkBuffer = 0
DebugInfo = 0
OptimizeExe = 1
StackSize = 16384
HeapSize = 8192
[Directories]
OutputDir =
SearchPath =
Conditionals =
[Parameters]
RunParams = / s

Снимок экрана.

Оформил: DeeCo Автор: http://www.swissdelphicenter.ch

uses
   Graphics;
 // Capture the entire screen 
// Screenshot des gesamten Bildschirms 
procedure ScreenShot(Bild: TBitMap);
 var
   c: TCanvas;
   r: TRect;
 begin
   c := TCanvas.Create;
   c.Handle := GetWindowDC(GetDesktopWindow);
   try
     r := Rect(0, 0, Screen.Width, Screen.Height);
     Bild.Width := Screen.Width;
     Bild.Height := Screen.Height;
     Bild.Canvas.CopyRect(r, c, r);
   finally
     ReleaseDC(0, c.Handle);
     c.Free;
   end;
 end;
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   Form1.Visible := False;
   Sleep(750); // some delay, ein wenig Zeit geben 
  ScreenShot(Image1.Picture.BitMap);
   Form1.Visible := True;
 end;
 // Only active window 
// Screenshot des aktiven Fensters 
procedure ScreenShotActiveWindow(Bild: TBitMap);
 var
   c: TCanvas;
   r, t: TRect;
   h: THandle;
 begin
   c := TCanvas.Create;
   c.Handle := GetWindowDC(GetDesktopWindow);
   h := GetForeGroundWindow;
   if h <> 0 then
     GetWindowRect(h, t);
   try
     r := Rect(0, 0, t.Right - t.Left, t.Bottom - t.Top);
     Bild.Width  := t.Right - t.Left;
     Bild.Height := t.Bottom - t.Top;
     Bild.Canvas.CopyRect(r, c, t);
   finally
     ReleaseDC(0, c.Handle);
     c.Free;
   end;
 end;
 procedure TForm1.Button2Click(Sender: TObject);
 begin
   Form1.Visible := False;
   Sleep(750); //some delay,ein wenig Zeit geben 
  ScreenShotActiveWindow(Image1.Picture.BitMap);
   Form1.Visible := True;
 end;
 {**********************************************}
 // Another print screen function by Xavier P: 
// Capture the entire screen 
procedure ScreenShot(x: Integer;
   y: Integer; //(x, y) = Left-top coordinate 
  Width: Integer;
   Height: Integer; //(Width-Height) = Bottom-Right coordinate 
  bm: TBitMap); //Destination 
var
   dc: HDC;
   lpPal: PLOGPALETTE;
 begin
   {test width and height}
   if ((Width = 0) or
     (Height = 0)) then
     Exit;
   bm.Width  := Width;
   bm.Height := Height;
   {get the screen dc}
   dc := GetDc(0);
   if (dc = 0) then
     Exit;
   {do we have a palette device?}
   if (GetDeviceCaps(dc, RASTERCAPS) and
     RC_PALETTE = RC_PALETTE) then
   begin
     {allocate memory for a logical palette}
     GetMem(lpPal,
       SizeOf(TLOGPALETTE) +
     (255 * SizeOf(TPALETTEENTRY)));
     {zero it out to be neat}
     FillChar(lpPal^,
       SizeOf(TLOGPALETTE) +
     (255 * SizeOf(TPALETTEENTRY)),
       #0);
     {fill in the palette version}
     lpPal^.palVersion := $300;
     {grab the system palette entries}
     lpPal^.palNumEntries :=
       GetSystemPaletteEntries(dc,
       0,
       256,
       lpPal^.palPalEntry);
     if (lpPal^.PalNumEntries <> 0) then
       {create the palette}
       bm.Palette := CreatePalette(lpPal^);
     FreeMem(lpPal, SizeOf(TLOGPALETTE) +
     (255 * SizeOf(TPALETTEENTRY)));
   end;
   {copy from the screen to the bitmap}
   BitBlt(bm.Canvas.Handle,
     0,
     0,
     Width,
     Height,
     Dc,
     x,
     y,
     SRCCOPY);
   {release the screen dc}
   ReleaseDc(0, dc);
 end;
 // Example: 
procedure TForm1.Button1Click(Sender: TObject);
 begin
  ScreenShot(0,0,Screen.Width, Screen.Height, Image1.Picture.Bitmap);
 end;
 {**********************************************}
 // Capture a window 
procedure ScreenShot(hWindow: HWND; bm: TBitmap);
 var
   Left, Top, Width, Height: Word;
   R: TRect;
   dc: HDC;
   lpPal: PLOGPALETTE;
 begin
   {Check if valid window handle}
   if not IsWindow(hWindow) then Exit;
   {Retrieves the rectangular coordinates of the specified window}
   GetWindowRect(hWindow, R);
   Left := R.Left;
   Top := R.Top;
   Width := R.Right - R.Left;
   Height := R.Bottom - R.Top;
   bm.Width  := Width;
   bm.Height := Height;
   {get the screen dc}
   dc := GetDc(0);
   if (dc = 0) then
    begin
     Exit;
   end;
   {do we have a palette device?}
   if (GetDeviceCaps(dc, RASTERCAPS) and
     RC_PALETTE = RC_PALETTE) then
    begin
     {allocate memory for a logical palette}
     GetMem(lpPal,
       SizeOf(TLOGPALETTE) +
     (255 * SizeOf(TPALETTEENTRY)));
     {zero it out to be neat}
     FillChar(lpPal^,
       SizeOf(TLOGPALETTE) +
     (255 * SizeOf(TPALETTEENTRY)),
       #0);
     {fill in the palette version}
     lpPal^.palVersion := $300;
     {grab the system palette entries}
     lpPal^.palNumEntries :=
       GetSystemPaletteEntries(dc,
       0,
       256,
       lpPal^.palPalEntry);
     if (lpPal^.PalNumEntries <> 0) then
      begin
       {create the palette}
       bm.Palette := CreatePalette(lpPal^);
     end;
     FreeMem(lpPal, SizeOf(TLOGPALETTE) +
     (255 * SizeOf(TPALETTEENTRY)));
   end;
   {copy from the screen to the bitmap}
   BitBlt(bm.Canvas.Handle,
     0,
     0,
     Width,
     Height,
     Dc,
     Left,
     Top,
     SRCCOPY);
   {release the screen dc}
   ReleaseDc(0, dc);
 end;
 // Example: Capture the foreground window: 
procedure TForm1.Button1Click(Sender: TObject);
 begin
   ScreenShot(GetForeGroundWindow, Image1.Picture.Bitmap);
 end;
 {**********************************************}
 // by Daniel Wischnewski 
Sometimes you want to take a screen shot,
 however often Windows has trouble with big data amounts and becomes very slow.
 The simple solution is to make many small screen shots and paste the result together.
 It''s not light speed, however often faster than taking the whole screen at once.
 const
   cTileSize = 50;
 function TForm1.GetSCREENSHOT: TBitmap;
 var
   Locked: Boolean;
   X, Y, XS, YS: Integer;
   Canvas: TCanvas;
   R: TRect;
 begin
   Result := TBitmap.Create;
   Result.Width := Screen.Width;
   Result.Height := Screen.Height;
   Canvas := TCanvas.Create;
   Canvas.Handle := GetDC(0);
   Locked := Canvas.TryLock;
   try
     XS := Pred(Screen.Width div cTileSize);
     if Screen.Width mod cTileSize > 0 then
       Inc(XS);
     YS := Pred(Screen.Height div cTileSize);
     if Screen.Height mod cTileSize > 0 then
       Inc(YS);
     for X := 0 to XS do
       for Y := 0 to YS do
       begin
         R := Rect(
           X * cTileSize, Y * cTileSize, Succ(X) * cTileSize,
           Succ(Y) * cTileSize);
         Result.Canvas.CopyRect(R, Canvas, R);
       end;
   finally
     if Locked then
       Canvas.Unlock;
     ReleaseDC(0, Canvas.Handle);
     Canvas.Free;
   end;
 end;

Как скопировать экран (или его часть) в TBitmap.

Например, с помощью WinAPI так -

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