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

Как узнать или установить аттрибуты файла.

Чтобы прочитать аттрибуты файла, необходимо передать имя файла в функцию FileGetAttr, которая вернёт аттрибуты для данного файла.

Например, добавьте на форму компоненты TButton и TLabel и добавьте следующий код в в обработчик события OnClick кнопки:

var
  attr: Integer;
  s: string;
begin
  attr := FileGetAttr('c:\Autoexec.bat');
  if (attr and faHidden) <> 0 then s := 'Hidden';
  if (attr and faReadOnly) <> 0 then s := s + 'Read-Only';
  if (attr and faSysFile) <> 0 then s := s + 'System';
  if (attr and faArchive) <> 0 then s := s + 'Archive';
  Label1.Caption := s;
end;

Чтобы установить аттрибуты у файла, необходимо передать имя файла и нужные аттрибуты в функцию FileSetAttr. Каждый аттрибут имеет мнемоническое имя, объявленное в юните SysUtils.

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

Attributes := Attributes or faSystem;

Так же можно очистить некоторые аттрибуты. Например, чтобы снять атрибуты только чтения и "Скрытый", необходимо выполнить следующий код:

Attributes := Attributes and not (faReadOnly or faHidden);

Вместо объявленных значений атрибутов можно использовать числовые значения.

+--------------------------------+
| Возвр. знач.|   Аттр. Файла    |
+--------------------------------+
|   128       |   Нормальный     |
|   1         |   Только чтение  |
|   2         |   Скрытый        |
|   4         |   Системный      |
|   32        |   Архивный       |
+-------------+------------------+

Пример:

{Скрытый}
FileSetAttr('C:\Autoexec.bat',2);
{Скрытый и Только чтение. В свою очередь
функция FileGetAttr верн¸т значение 3}
FileSetAttr('C:\Autoexec.bat',3);

Установить или получить статус Off-Line.

{ 
  Users can choose to work offline by selecting Work Offline on the 
  File menu in Internet Explorer 4.0 and later. When Work Offline is selected, 
  the system enters a global offline state independent of any current network 
  connection, and content is read exclusively from the cache. 
} 
uses wininet; 
// Get offline state 
// Alhaiseb Misurata Libya 
function IsGlobalOffline: Boolean; 
var 
  State, Size: DWORD; 
begin 
  Result := False; 
  State  := 0; 
  Size   := SizeOf(DWORD); 
  if InternetQueryOption(nil, INTERNET_OPTION_CONNECTED_STATE, @State, Size) then 
    if (State and INTERNET_STATE_DISCONNECTED_BY_USER) <> 0 then 
      Result := True; 
end; 
//Set offline state 
procedure SetGlobalOffline(fGoOffline: Boolean); 
var 
  ci: INTERNET_CONNECTED_INFO; 
begin 
  if fGoOffline then 
  begin 
    ci.dwConnectedState := INTERNET_STATE_DISCONNECTED_BY_USER; 
    ci.dwFlags          := ISO_FORCE_DISCONNECTED; 
  end 
  else 
    ci.dwConnectedState := INTERNET_STATE_CONNECTED; 
  InternetSetOption(nil, INTERNET_OPTION_CONNECTED_STATE, @ci, SizeOf(ci)); 
end;

Как получить или установить приоритет процесса в Win9x или Me.

const
  ppIdle : Integer = -1;
  ppNormal : Integer = 0;
  ppHigh : Integer = 1;
  ppRealTime : Integer = 2;
function SetProcessPriority( Priority : Integer ) : Integer;
var
  H : THandle;
begin
  Result := ppNormal;
  H := GetCurrentProcess();
  if ( Priority = ppIdle ) then
    SetPriorityClass( H, IDLE_PRIORITY_CLASS )
  else
  if ( Priority = ppNormal ) then
    SetPriorityClass( H, NORMAL_PRIORITY_CLASS )
  else
  if ( Priority = ppHigh ) then
    SetPriorityClass( H, HIGH_PRIORITY_CLASS )
  else
  if ( Priority = ppRealTime ) then
    SetPriorityClass( H, REALTIME_PRIORITY_CLASS );
  case GetPriorityClass( H ) of
    IDLE_PRIORITY_CLASS : Result := ppIdle;
    NORMAL_PRIORITY_CLASS : Result := ppNormal;
    HIGH_PRIORITY_CLASS : Result := ppHigh;
    REALTIME_PRIORITY_CLASS : Result := ppRealTime;
  end;
end;
function GetProcessPriority : Integer;
var
  H : THandle;
begin
  Result := ppNormal;
  H := GetCurrentProcess();
  case GetPriorityClass( H ) of
    IDLE_PRIORITY_CLASS : Result := ppIdle;
    NORMAL_PRIORITY_CLASS : Result := ppNormal;
    HIGH_PRIORITY_CLASS : Result := ppHigh;
    REALTIME_PRIORITY_CLASS : Result := ppRealTime;
  end;
end;

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

function SetProcessPriority( Priority : Integer ) : Integer;

Для установки приоритета Вашего приложения, либо:

function GetProcessPriority : Integer;

Для получения приоритета.

Как узнать и поменять разрешение экрана.

Узнать можно так:

Screen.Width;
Screen.Height;

А поменять можно с помощью следующей процердуры:

procedure ChangeDisplayResolution(x, y: word);
var
  dm: TDEVMODE;
begin
  ZeroMemory(@dm, sizeof(TDEVMODE));
  dm.dmSize := sizeof(TDEVMODE);
  dm.dmPelsWidth := x;
  dm.dmPelsHeight := y;
  dm.dmFields := DM_PELSWIDTH or DM_PELSHEIGHT;
  ChangeDisplaySettings(dm, 0);
end;

Определить и выставить значение текстового свойства.

unit StrForm;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, StdCtrls;
type
  TForm1 = class(TForm)
    ButtonGet: TButton;
    EditProperty: TEdit;
    Label1: TLabel;
    Bevel1: TBevel;
    ButtonTrial: TButton;
    Label2: TLabel;
    LabelResult: TLabel;
    ButtonSet: TButton;
    Label3: TLabel;
    EditValue: TEdit;
    procedure ButtonGetClick(Sender: TObject);
    procedure ButtonSetClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
var
  Form1: TForm1;
implementation
{$R *.DFM}
uses
  TypInfo;
procedure TForm1.ButtonGetClick(Sender: TObject);
var
  PropInfo: PPropInfo;
begin
  if not Assigned (ButtonTrial) then
    ShowMessage ('The button has been renamed')
  else
  begin
    PropInfo := GetPropInfo (
      ButtonTrial.ClassInfo, EditProperty.Text);
    if PropInfo <> nil then
      if PropInfo^.PropType^.Kind =
          tkLString then
        LabelResult.Caption :=
          GetStrProp (ButtonTrial, PropInfo)
      else
        ShowMessage ('Not a string property')
    else
      ShowMessage ('Property doesn''t exist');
  end;
end;
procedure TForm1.ButtonSetClick(Sender: TObject);
var
  PropInfo: PPropInfo;
begin
  if not Assigned (ButtonTrial) then
    ShowMessage ('The button has been renamed')
  else
  begin
    PropInfo := GetPropInfo (
      ButtonTrial.ClassInfo, EditProperty.Text);
    if PropInfo <> nil then
      if PropInfo^.PropType^.Kind =
          tkLString then
        SetStrProp (ButtonTrial, PropInfo, EditValue.Text)
      else
        ShowMessage ('Not a string property')
    else
      ShowMessage ('Property doesn''t exist');
  end;
end;
end.

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

Получить и установить системные цвета.

var 
  OldColor: TColor; 
  Element: TColor = COLOR_BTNFACE; 
  {....} 
{ 
  Set the color for a system element. SetSysColors function 
  changes the current Windows session only. 
  The new colors are not saved when Windows terminates. 
  For a list of color elements see  Win32 API Help - Function GetSysColor 
  Open the ColorDialog - and set the new color systemwide 
} 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  if ColorDialog1.Execute then 
  begin 
    SetSysColors(1, Element, ColorDialog1.Color); 
  end; 
end; 
{ 
  Save the old color value of the element COLOR_BTNFACE to restore on Button2 click 
} 
procedure TForm1.FormShow(Sender: TObject); 
begin 
  OldColor := GetSysColor(COLOR_BTNFACE); 
end; 
{ 
  Restore the old color value 
  Stellt den alten Farbwert wieder her 
} 
procedure TForm1.Button2Click(Sender: TObject); 
begin 
  SetSysColors(1, Element, OldColor); 
end;

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

Display Device Modes

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

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

Получение возможных видео-режимов

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

Данная функция имеет на входе переменную типа TDevMode, в которой помещаются параметры. Сам тип TDevMode имеет множество переменных, относящихся к видео адаптеру. А именно, он включает в себя разрешение видео адаптера в пикселях (dmPelsWidth, dmPelsHeight), разрядность цвета (в битах на пиксель), поддерживаемая при данном разрешении (dmBitsPerPel), частота обновления (dmDisplayFrequency) и другие.

procedure TForm1.FormCreate(Sender: TObject);
var
  i: Integer;
  DevMode: TDevMode;
begin
  i:=0;
  while EnumDisplaySettings(nil,i,DevMode) do
  begin
    with Devmode do
      ListBox1.Items.Add(Format('%dx%d %d Colors',
      [dmPelsWidth,dmPelsHeight,1 shl dmBitsperPel]));
    Inc(i);
  end;
end;

Установка видео-режима

После того как мы получим все доступные режимы, то установить желательный не составляет особого труда. Для этого мы воспользуемся функцией ChangeDisplaySettings. Так же данная функция при необходимости обновит реестр Windows.

procedure TForm1.Button1Click(Sender: TObject);
var
  DevMode: TDeviceMode;
  liRetValue: Longint;
begin
  if EnumDisplaySettings(nil,Listbox1.ItemIndex,Devmode) then
    liRetValue := ChangeDisplaySettings(DevMode, CDS_UPDATEREGISTRY);
  SendMessage(HWND_BROADCAST, WM_DISPLAYCHANGE, SPI_SETNONCLIENTMETRICS, 0);
end;

Функция ChangeDisplaySettings возвращает значение long integer. Это значение можно использовать для определения успешности выполнения функции, сравнив со значениями из списка констант.

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

Внимание: Многие адаптеры (особенно старые) могут не поддерживать смену разрешения без перезагрузки компьютера.

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

Отслеживание изменений дисплея

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

...
type
  TForm1 = class(TForm)
    ListBox1: TListBox;
...
  private
  procedure WMDisplayChange(var message:TMessage); message WM_DISPLAYCHANGE;
...
procedure TForm1.WMDisplayChange(var message: TMessage);
begin
  ShowMessage('Changes in display detected!');
  inherited;
end;

Получение и установка видеорежимов в Windows.

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

Получение списка видеорежимов

Получить видеорежимы можно серией вызовов EnumDisplaySettings. Функция EnumDisplaySettings возвращает информацию о видеорежиме, указанном в параметре IModeNode. Функции необходимо передать структуру типа TDevMode, в которую будет записана информация о видеорежиме. Данная структура имеет поля, характеризующие видеорежим: разрешение (dmPelsWidth, dmPelsHeight), количество битов цветности (dmBitsPerPel), частота обновления экрана (dmDisplayFrequency) и др.

function EnumDisplaySettings(lpszDeviceName: PWideChar; iModeNum: DWORD;
  var lpDevMode: TdeviceMode): BOOL; stdcall;

Параметры.

Поле Описание.

Если lpDevMode равно nil, из реестра берется информация о видеорежиме установленном по умолчанию. Передавая в lpDevMode nil и в dwFlags 0 можно получить настройки текущего видеорежима.

Ниже приведена процедура, получающая и отображающая в ListBox все возможные видеорежимы.

procedure TForm1.FormCreate(Sender: TObject);
var
  i: Integer;
  DevMode : TDeviceMode;
begin
  i:=0;
  while EnumDisplaySettings(nil,i,DevMode) do
  begin
    with Devmode do
      ListBox1.Items.Add(Format('%dx%d %d Colors',
      [dmPelsWidth,dmPelsHeight,Int64(1) shl dmBitsperPel]));
    Inc(i);
  end;
end;

Получение параметров текущего видеорежима

Помимо вызова EnumDisplaySettings инфомацию о текущем видеорежиме можно получать и другими способами.Получить количество битов цвета текущего видеорежима можно и другим способом:

GetDeviceCaps(Form1.Canvas.Handle, BITSPIXEL) *
GetDeviceCaps(Form1.Canvas.Handle, PLANES)

Получаемые значения при этом:

Непосредственно количество цветов можно так же легко подсчитать:

NumberOfColors := (1 shl
(GetDeviceCaps(Form1.Canvas.Handle, BITSPIXEL) *
GetDeviceCaps(Form1.Canvas.Handle, PLANES));

Текущее разрешение экрана можно узнать с помощью вызова GetSystemMetrics() в качестве параметров передается:

Ниже приведен пример получения высоты и ширины рабочей области экрана (для всей экранной области надо просто поменять параметры вызова GetSystemMetrics):

var
  x, y: Integer;
  Mode: string;
begin
  x:=GetSystemMetrics(Sm_Cxscreen);
  y:=GetSystemMetrics(Sm_CYscreen);
  Mode:=Format('%d x %d',[x,y]);
  if y=480 then
    Mode:=Mode+('Standard VGA')
  else
    Mode:=Mode+('Super VGA');
  StaticText1.Caption:=Mode;
end;

Установка видеорежима

Как мы убедились получения списка и параметров видеорежимов не проблема. Теперь разберемся с программной сменой видеорежимов. Функция ChangeDisplaySettings предназначена для изменения текущего видеорежима экрана и при необходимости обновления этой информации в реестре Windows.

function ChangeDisplaySettings(var lpDevMode: TDeviceMode;
dwFlags: DWORD): Longint; stdcall;

Параметры:

При немедленном изменении видеорежима всем запущенным приложениям рассылается сообщение WM_DISPLAYCHANGE.

А вот и пример смены видеорежима:

{...}
type
  TForm1 = class(TForm)
    Button1: TButton;
    ListView1: TListView;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure ListView1DblClick(Sender: TObject);
  private
    { Private declarations }
    {Массив для хранения информации о видеорежимах}
    DevMode : array[0..20] of TDeviceMode;
  public
    { Public declarations }
end;
{...}
procedure TForm1.FormCreate(Sender: TObject);
begin
  {Настройка ListView}
  ListView1.ViewStyle := vsReport;
  ListView1.RowSelect := TRUE;
  ListView1.Columns.Add;
  ListView1.Columns.Add;
  ListView1.Columns[0].Caption := 'Width x Height';
  ListView1.Columns[0].Width := 100;
  ListView1.Columns[1].Caption := 'Colors';
  ListView1.Columns[1].Width := 100;
end;
{Процедура получения списка режимов}
procedure TForm1.Button1Click(Sender: TObject);
var
  tmpStr1, tmpStr2 : string;
  tmpDC : HDC;
  x, Selection, cxScreen, cyScreen, Resolution : Integer;
begin
  { Запоминаем текущие настройки}
  tmpDC := getDC(Handle);
  try
    cxScreen := GetSystemMetrics(SM_CXSCREEN);
    cyScreen := GetSystemMetrics(SM_CYSCREEN);
    Resolution := GetDeviceCaps(tmpDC, BITSPIXEL);
  finally
    ReleaseDC(Handle, tmpDC);
  end;
  ListView1.Items.Clear;
  x := 0;
  { Получаем список видеорежимов}
  while EnumDisplaySettings(nil,x,DevMode[x]) do
  begin
    { Разрешение экрана }
    tmpStr1 := IntToStr(DevMode[x].dmPelsWidth) + 'x' +
    IntToStr(DevMode[x].dmPelsHeight);
    { Цвета }
    case DevMode[x].dmBitsPerPel of
      4 : tmpStr2 := '16 Colors';
      8 : tmpStr2 := '256 Colors';
      16 : tmpStr2 := 'High Color (16 Bit)';
      32 : tmpStr2 := 'True Color (32 Bit)';
    end;
    { А теперь полученную информацию надо отобразить }
    with ListView1.Items.Add do
    begin
      Caption := tmpStr1;
      SubItems.Add(tmpStr2);
    end;
    { В ListView надо встать не строку с описанием текущего режима,
    для этого сохраним индекс элемента с описанием этого режима }
    if ( cxScreen = DevMode[x].dmPelsWidth ) and
    ( cyScreen = DevMode[x].dmPelsHeight ) and
    ( Resolution = DevMode[x].dmBitsPerPel ) then
      Selection := x;
    inc(x);
    if x = 20 then
      Break;
  end;
  { В ListView перемещаемся на строчку с описанием текущего режима }
  ActiveControl := ListView1;
  ListView1.Selected := ListView1.Items.Item[Selection];
end;
{Установка выбранного пользователем видеорежима}
procedure TForm1.ListView1DblClick(Sender: TObject);
var
  tmpDevMode : TDevMode;
begin
  { Получаем сохраненную ранее информацию по выбранному режиму}
  tmpDevMode := DevMode[ListView1.Items.IndexOf(ListView1.Selected)];
  { Скажем Windows, какие параметры надо сменить }
  tmpDevMode.dmFields := DM_BITSPERPEL or DM_PELSWIDTH or
    DM_PELSHEIGHT or DM_DISPLAYFLAGS or DM_DISPLAYFREQUENCY;
  { Очень неплохо будет протестировать видеорежим
  и записать изменения в реестр}
  if ChangeDisplaySettings(tmpDevMode, CDS_TEST) =
  DISP_CHANGE_SUCCESSFUL then
    ChangeDisplaySettings(tmpDevMode, CDS_UPDATEREGISTRY);
end;

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

Замечание 2: Многие драйвера, особенно старые не поддерживают изменения видеорежима без перезагрузки компьютера.

Обнаружение изменений видеорежима

При изменениях видеорежима генерируется сообщение WM_DISPLAYCHANGE. Необходимо создать обработчик данного сообщения в вашем приложении.

...
type
  TForm1 = class(TForm)
  ListBox1: TListBox;
...
private
  procedure WMDisplayChange(var message:TMessage); message WM_DISPLAYCHANGE;
...
procedure TForm1.WMDisplayChange(var message: TMessage);
begin
  ShowMessage('Changes in display detected!');
  inherited;
end;

Получить или установить задний фон в TWebBrowser.

//You need a TWebbrowser and 3 TButtons 
// First load a page 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  WebBrowser1.Navigate('www.SwissDelphiCenter.com'); 
end; 
// Show the background color 
// Hintergrundfarbe herausfinden 
procedure TForm1.Button2Click(Sender: TObject); 
begin 
  ShowMessage(WebBrowser1.OleObject.Document.bgColor); 
end; 
// Set the background color 
procedure TForm1.Button3Click(Sender: TObject); 
begin 
  WebBrowser1.OleObject.Document.bgColor := '#000000'; 
end;

Получение уведомлений от оболочки (Shell).

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

{$IFNDEF VER80} {$IFNDEF VER90} {$IFNDEF VER93}
{$DEFINE Delphi3orHigher}
{$ENDIF} {$ENDIF} {$ENDIF}
unit ShellNotify;
interface
uses
  Windows, Messages, SysUtils, Classes, Controls, Forms, Dialogs,
  {$IFNDEF Delphi3orHigher} OLE2, {$ELSE} ActiveX, ComObj, {$ENDIF}
  ShlObj;
type
  NOTIFYREGISTER = record
    pidlPath : PItemIDList;
    bWatchSubtree : boolean;
end;
PNOTIFYREGISTER = ^NOTIFYREGISTER;
const
  SNM_SHELLNOTIFICATION = WM_USER +1;
  SHCNF_ACCEPT_INTERRUPTS = $0001;
  SHCNF_ACCEPT_NON_INTERRUPTS = $0002;
  SHCNF_NO_PROXY = $8000;
type
  TNotificationEvent = (neAssociationChange, neAttributesChange,
    neFileChange, neFileCreate, neFileDelete, neFileRename,
    neDriveAdd, neDriveRemove, neShellDriveAdd, neDriveSpaceChange,
    neMediaInsert, neMediaRemove, neFolderCreate, neFolderDelete,
    neFolderRename, neFolderUpdate, neNetShare, neNetUnShare,
    neServerDisconnect, neImageListChange);
  TNotificationEvents = set of TNotificationEvent;
  TShellNotificationEvent1 = procedure(Sender: TObject;
    Path: string)of object;
  TShellNotificationEvent2 = procedure(Sender: TObject;
    path1, path2: string) of object;
  // TShellNotificationAttributesEvent = procedure(Sender: TObject;
  // OldAttribs, NewAttribs: Integer) of Object;
  TShellNotification = class( TComponent )
    private
      fWatchEvents: TNotificationEvents;
      fPath: string;
      fActive, fWatch: Boolean;
      prevPath1, prevPath2: string;
      PrevEvent: Integer;
      Handle, NotifyHandle: HWND;
      fOnAssociationChange: TNotifyEvent;
      fOnAttribChange: TShellNotificationEvent2;
      FOnCreate: TShellNotificationEvent1;
      FOnDelete: TShellNotificationEvent1;
      FOnDriveAdd: TShellNotificationEvent1;
      FOnDriveAddGui: TShellNotificationEvent1;
      FOnDriveRemove: TShellNotificationEvent1;
      FOnMediaInsert: TShellNotificationEvent1;
      FOnMediaRemove: TShellNotificationEvent1;
      FOnDirCreate: TShellNotificationEvent1;
      FOnNetShare: TShellNotificationEvent1;
      FOnNetUnShare: TShellNotificationEvent1;
      FOnRenameFolder: TShellNotificationEvent2;
      FOnItemRename: TShellNotificationEvent2;
      FOnFolderRemove: TShellNotificationEvent1;
      FOnServerDisconnect: TShellNotificationEvent1;
      FOnFolderUpdate: TShellNotificationEvent1;
      function PathFromPidl(Pidl: PItemIDList): string;
      procedure SetWatchEvents(const Value: TNotificationEvents);
      function GetActive: Boolean;
      procedure SetActive(const Value: Boolean);
      procedure SetPath(const Value: string);
      procedure SetWatch(const Value: Boolean);
    protected
      procedure ShellNotifyRegister;
      procedure ShellNotifyUnregister;
      procedure WndProc(var message: TMessage);
      procedure DoAssociationChange; dynamic;
      procedure DoAttributesChange(Path1, Path2: string); dynamic;
      procedure DoCreateFile(Path: string); dynamic;
      procedure DoDeleteFile(Path: string); dynamic;
      procedure DoDriveAdd(Path:string); dynamic;
      procedure DoDriveAddGui(Path: string); dynamic;
      procedure DoDriveRemove(Path: string); dynamic;
      procedure DoMediaInsert(Path: string); dynamic;
      procedure DoMediaRemove(Path: string); dynamic;
      procedure DoDirCreate(Path: string); dynamic;
      procedure DoNetShare(Path: string); dynamic;
      procedure DoNetUnShare(Path: string); dynamic;
      procedure DoRenameFolder(Path1, Path2: string); dynamic;
      procedure DoRenameItem(Path1, Path2: string); dynamic;
      procedure DoFolderRemove(Path: string); dynamic;
      procedure DoServerDisconnect(Path: string); dynamic;
      procedure DoDirUpdate(Path: string); dynamic;
    public
      constructor Create(AOwner: TComponent); override;
      destructor Destroy; override;
    published
      property Path: string read fPath write SetPath;
      property Active: Boolean read GetActive write SetActive;
      property WatchSubTree: Boolean read fWatch write SetWatch;
      property WatchEvents: TNotificationEvents
      read fWatchEvents write SetWatchEvents;
      property OnAssociationChange: TNotifyEvent
      read fOnAssociationChange write FOnAssociationChange;
      property OnAttributesChange: TShellNotificationEvent2
      read fOnAttribChange write fOnAttribChange;
      property OnFileCreate: TShellNotificationEvent1
      read FOnCreate write FOnCreate;
      property OnFolderRename: TShellNotificationEvent2
      read FOnRenameFolder write FOnRenameFolder;
      property OnFolderUpdate: TShellNotificationEvent1
      read FOnFolderUpdate write FOnFolderUpdate;
      property OnFileDelete: TShellNotificationEvent1
      read FOnDelete write FOnDelete;
      property OnDriveAdd: TShellNotificationEvent1
      read FOnDriveAdd write FOnDriveAdd;
      property OnFolderRemove: TShellNotificationEvent1
      read FOnFolderRemove write FOnFolderRemove;
      property OnItemRename: TShellNotificationEvent2
      read FOnItemRename write FOnItemRename;
      property OnDriveAddGui: TShellNotificationEvent1
      read FOnDriveAddGui write FOnDriveAddGui;
      property OnDriveRemove: TShellNotificationEvent1
      read FOnDriveRemove write FOnDriveRemove;
      property OnMediaInserted: TShellNotificationEvent1
      read FOnMediaInsert write FOnMediaInsert;
      property OnMediaRemove: TShellNotificationEvent1
      read FOnMediaRemove write FOnMediaRemove;
      property OnDirCreate: TShellNotificationEvent1
      read FOnDirCreate write FOnDirCreate;
      property OnNetShare: TShellNotificationEvent1
      read FOnNetShare write FOnNetShare;
      property OnNetUnShare: TShellNotificationEvent1
      read FOnNetUnShare write FOnNetUnShare;
      property OnServerDisconnect: TShellNotificationEvent1
      read FOnServerDisconnect write FOnServerDisconnect;
end;
function SHChangeNotifyRegister( hWnd: HWND; dwFlags: integer;
wEventMask : cardinal; uMsg: UINT; cItems : integer;
lpItems : PNOTIFYREGISTER) : HWND; stdcall;
function SHChangeNotifyDeregister(hWnd: HWND) : boolean; stdcall;
function SHILCreateFromPath(Path: Pointer; PIDL: PItemIDList;
var Attributes: ULONG):HResult; stdcall;
implementation
const Shell32DLL = 'shell32.dll';
function SHChangeNotifyRegister; external Shell32DLL index 2;
function SHChangeNotifyDeregister; external Shell32DLL index 4;
function SHILCreateFromPath; external Shell32DLL index 28;
{ TShellNotification }
constructor TShellNotification.Create(AOwner: TComponent);
begin
  inherited Create( AOwner );
  if not (csDesigning in ComponentState) then
    Handle := AllocateHWnd(WndProc);
end;
destructor TShellNotification.Destroy;
begin
  if not (csDesigning in ComponentState) then
    Active := False;
  if Handle <> 0 then
    DeallocateHWnd( Handle );
  inherited Destroy;
end;
procedure TShellNotification.DoAssociationChange;
begin
  if Assigned( fOnAssociationChange ) and
  (neAssociationChange in fWatchEvents) then
    fOnAssociationChange( Self );
end;
procedure TShellNotification.DoAttributesChange;
begin
  if Assigned( fOnAttribChange ) then
    fOnAttribChange( Self, Path1, Path2 );
end;
procedure TShellNotification.DoCreateFile(Path: string);
begin
  if Assigned( fOnCreate ) then
    FOnCreate(Self, Path)
end;
procedure TShellNotification.DoDeleteFile(Path: string);
begin
  if Assigned( FOnDelete ) then
    FOnDelete(Self, Path);
end;
procedure TShellNotification.DoDirCreate(Path: string);
begin
  if Assigned( FOnDirCreate ) then
    FOnDirCreate( Self, Path );
end;
procedure TShellNotification.DoDirUpdate(Path: string);
begin
  if Assigned( FOnFolderUpdate ) then
    FOnFolderUpdate(Self, Path);
end;
procedure TShellNotification.DoDriveAdd(Path: string);
begin
  if Assigned( FOnDriveAdd ) then
    FOnDriveAdd(Self, Path);
end;
procedure TShellNotification.DoDriveAddGui(Path: string);
begin
  if Assigned( FOnDriveAddGui ) then
    FOnDriveAdd(Self, Path);
end;
procedure TShellNotification.DoDriveRemove(Path: string);
begin
  if Assigned( FOnDriveRemove ) then
    FOnDriveRemove(Self, Path);
end;
procedure TShellNotification.DoFolderRemove(Path: string);
begin
  if Assigned(FOnFolderRemove) then
    FOnFolderRemove( Self, Path );
end;
procedure TShellNotification.DoMediaInsert(Path: string);
begin
  if Assigned( FOnMediaInsert ) then
    FOnMediaInsert(Self, Path);
end;
procedure TShellNotification.DoMediaRemove(Path: string);
begin
  if Assigned(FOnMediaRemove) then
    FOnMediaRemove(Self, Path);
end;
procedure TShellNotification.DoNetShare(Path: string);
begin
  if Assigned(FOnNetShare) then
    FOnNetShare(Self, Path);
end;
procedure TShellNotification.DoNetUnShare(Path: string);
begin
  if Assigned(FOnNetUnShare) then
    FOnNetUnShare(Self, Path);
end;
procedure TShellNotification.DoRenameFolder(Path1, Path2: string);
begin
  if Assigned( FOnRenameFolder ) then
    FOnRenameFolder(Self, Path1, Path2);
end;
procedure TShellNotification.DoRenameItem(Path1, Path2: string);
begin
  if Assigned( FOnItemRename ) then
    FonItemRename(Self, Path1, Path2);
end;
procedure TShellNotification.DoServerDisconnect(Path: string);
begin
  if Assigned( FOnServerDisconnect ) then
    FOnServerDisconnect(Self, Path);
end;
function TShellNotification.GetActive: Boolean;
begin
  Result := (NotifyHandle <> 0) and (fActive);
end;
function TShellNotification.PathFromPidl(Pidl: PItemIDList): string;
begin
  SetLength(Result, Max_Path);
  if not SHGetPathFromIDList(Pidl, PChar(Result)) then
    Result := '';
  if pos(#0, Result) > 0 then
    SetLength(Result, pos(#0, Result));
end;
procedure TShellNotification.SetActive(const Value: Boolean);
begin
  if (Value <> fActive) then
  begin
    fActive := Value;
    if fActive then
      ShellNotifyRegister
    else
      ShellNotifyUnregister;
  end;
end;
procedure TShellNotification.SetPath(const Value: string);
begin
  if fPath <> Value then
  begin
    fPath := Value;
    ShellNotifyRegister;
  end;
end;
procedure TShellNotification.SetWatch(const Value: Boolean);
begin
  if fWatch <> Value then
  begin
    fWatch := Value;
    ShellNotifyRegister;
  end;
end;
procedure TShellNotification.SetWatchEvents(
const Value: TNotificationEvents);
begin
  if fWatchEvents <> Value then
  begin
    fWatchEvents := Value;
    ShellNotifyRegister;
  end;
end;
procedure TShellNotification.ShellNotifyRegister;
var
  NotifyRecord: PNOTIFYREGISTER;
  Flags: DWORD;
  Pidl: PItemIDList;
  Attributes: ULONG;
begin
  if not (csDesigning in ComponentState) and
  not (csLoading in ComponentState) then
  begin
    SHILCreatefromPath( PChar(fPath), Addr(Pidl), Attributes);
    NotifyRecord^.pidlPath := Pidl;
    NotifyRecord^.bWatchSubtree := fWatch;
    if NotifyHandle <> 0 then
      ShellNotifyUnregister;
    Flags := 0;
    if neAssociationChange in FWatchEvents then
      Flags := Flags or SHCNE_ASSOCCHANGED;
    if neAttributesChange in FWatchEvents then
      Flags := Flags or SHCNE_ATTRIBUTES;
    if neFileChange in FWatchEvents then
      Flags := Flags or SHCNE_UPDATEITEM;
    if neFileCreate in FWatchEvents then
      Flags := Flags or SHCNE_CREATE;
    if neFileDelete in FWatchEvents then
      Flags := Flags or SHCNE_DELETE;
    if neFileRename in FWatchEvents then
      Flags := Flags or SHCNE_RENAMEITEM;
    if neDriveAdd in FWatchEvents then
      Flags := Flags or SHCNE_DRIVEADD;
    if neDriveRemove in FWatchEvents then
      Flags := Flags or SHCNE_DRIVEREMOVED;
    if neShellDriveAdd in FWatchEvents then
      Flags := Flags or SHCNE_DRIVEADDGUI;
    if neDriveSpaceChange in FWatchEvents then
      Flags := Flags or SHCNE_FREESPACE;
    if neMediaInsert in FWatchEvents then
      Flags := Flags or SHCNE_MEDIAINSERTED;
    if neMediaRemove in FWatchEvents then
      Flags := Flags or SHCNE_MEDIAREMOVED;
    if neFolderCreate in FWatchEvents then
      Flags := Flags or SHCNE_MKDIR;
    if neFolderDelete in FWatchEvents then
      Flags := Flags or SHCNE_RMDIR;
    if neFolderRename in FWatchEvents then
      Flags := Flags or SHCNE_RENAMEFOLDER;
    if neFolderUpdate in FWatchEvents then
      Flags := Flags or SHCNE_UPDATEDIR;
    if neNetShare in FWatchEvents then
      Flags := Flags or SHCNE_NETSHARE;
    if neNetUnShare in FWatchEvents then
      Flags := Flags or SHCNE_NETUNSHARE;
    if neServerDisconnect in FWatchEvents then
      Flags := Flags or SHCNE_SERVERDISCONNECT;
    if neImageListChange in FWatchEvents then
      Flags := Flags or SHCNE_UPDATEIMAGE;
    NotifyHandle := SHChangeNotifyRegister(Handle,
    SHCNF_ACCEPT_INTERRUPTS or SHCNF_ACCEPT_NON_INTERRUPTS,
    Flags, SNM_SHELLNOTIFICATION, 1, NotifyRecord);
  end;
end;
procedure TShellNotification.ShellNotifyUnregister;
begin
  if NotifyHandle <> 0 then
    SHChangeNotifyDeregister(NotifyHandle);
end;
procedure TShellNotification.WndProc(var message: TMessage);
type
  TPIDLLIST = record
  pidlist : array[1..2] of PITEMIDLIST;
end;
PIDARRAY = ^TPIDLLIST;
var
  Path1 : string;
  Path2 : string;
  ptr : PIDARRAY;
  repeated : boolean;
  event : longint;
begin
  case message.Msg of
    SNM_SHELLNOTIFICATION:
    begin
      event := message.LParam and ($7FFFFFFF);
      Ptr := PIDARRAY(message.WParam);
      Path1 := PathFromPidl( Ptr^.pidlist[1] );
      Path2 := PathFromPidl( Ptr^.pidList[2] );
      repeated := (PrevEvent = event)
      and (uppercase(prevpath1) = uppercase(Path1))
      and (uppercase(prevpath2) = uppercase(Path2));
      if Repeated then
        exit;
      PrevEvent := message.Msg;
      prevPath1 := Path1;
      prevPath2 := Path2;
      case event of
        SHCNE_ASSOCCHANGED : DoAssociationChange;
        SHCNE_ATTRIBUTES : DoAttributesChange( Path1, Path2);
        SHCNE_CREATE : DoCreateFile(Path1);
        SHCNE_DELETE : DoDeleteFile(Path1);
        SHCNE_DRIVEADD : DoDriveAdd(Path1);
        SHCNE_DRIVEADDGUI : DoDriveAddGui(path1);
        SHCNE_DRIVEREMOVED : DoDriveRemove(Path1);
        SHCNE_MEDIAINSERTED : DoMediaInsert(Path1);
        SHCNE_MEDIAREMOVED : DoMediaRemove(Path1);
        SHCNE_MKDIR : DoDirCreate(Path1);
        SHCNE_NETSHARE : DoNetShare(Path1);
        SHCNE_NETUNSHARE : DoNetUnShare(Path1);
        SHCNE_RENAMEFOLDER : DoRenameFolder(Path1, Path2);
        SHCNE_RENAMEITEM : DoRenameItem(Path1, Path2);
        SHCNE_RMDIR : DoFolderRemove(Path1);
        SHCNE_SERVERDISCONNECT : DoServerDisconnect(Path);
        SHCNE_UPDATEDIR : DoDirUpdate(Path);
        SHCNE_UPDATEIMAGE : ;
        SHCNE_UPDATEITEM : ;
      end;
    end;
  end;
end;
end.

Получить иконку из ярлыка.

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

{How to get icon from a shortcut file ? 
I have found that if you use a ListView component, 
to show a list of files in any folder that contains shortcuts, 
then the shortcut icons do not appear correctly - 
they do not show the true icon of the application to which they relate. 
However, there is a a very useful feature of SHGetFileInfo, 
which is SHGFI_LINKOVERLAY. This adds the shortcut "arrow", 
which is shown in the bottom left corner of any shortcut icon. 
The demo code below shows the basic use of the SHGFI_LINKOVERLAY feature. 
I have added code to this demo, to distingiush between shortcut and non-shortcut files - 
 without this code, it will overlay the shortcut "arrow" irrespective of the file type. 
To show the icon of a shortcut, the following code can be used as a demo: 
1. Add the following components to a new project, and adjust their 
properties according to the code below: }
 // Code for DFM file: 
object Form1: TForm1
   Left = 379
   Top = 355
   Width = 479
   Height = 382
   Caption = 'Get Icon from Shortcut File'
   Color = clBtnFace
   Font.Charset = DEFAULT_CHARSET
   Font.Color = clWindowText
   Font.Height = -11
   Font.Name = 'MS Sans Serif'
   Font.Style = []
   OldCreateOrder = False
   PixelsPerInch = 96
   TextHeight = 13
   object ListView: TListView
     Left = 0
     Top = 73
     Width = 471
     Height = 275
     Align = alClient
     Columns = <
       item
         Width = 100
       end
       item
         Width = 100
       end>
     SmallImages = imgList
     TabOrder = 0
     ViewStyle = vsReport
   end
   object Panel: TPanel
     Left = 0
     Top = 0
     Width = 471
     Height = 73
     Align = alTop
     TabOrder = 1
     object btnGetFile: TButton
       Left = 16
       Top = 8
       Width = 75
       Height = 25
       Caption = 'Get file'
       TabOrder = 0
       OnClick = btnGetFileClick
     end
     object btnGetIcon: TButton
       Left = 104
       Top = 8
       Width = 75
       Height = 25
       Caption = 'Get icon'
       TabOrder = 1
       OnClick = btnGetIconClick
     end
     object edFileName: TEdit
       Left = 16
       Top = 40
       Width = 441
       Height = 21
       TabOrder = 2
     end
   end
   object dlgOpen: TOpenDialog
     Filter = 'Shortcut files|*.lnk|All files|*.*'
     Options = [ofHideReadOnly, ofNoDereferenceLinks,
       ofEnableSizing]  // - this is important ! 
    Left = 248
     Top = 8
   end
   object imgList: TImageList
     BlendColor = clWhite
     BkColor = clWhite
     Masked = False
     ShareImages = True
     Left = 216
     Top = 8
   end
 end
 // 2. Add the code to the PAS file below: 
unit cdShortCutIcon;
 interface
 uses
   Windows, Messages, SysUtils, Variants, Graphics, Controls, Forms,
   Dialogs, Buttons, ExtCtrls, StdCtrls, StrUtils, ShellAPI,
   CommCtrl, ImgList, ComCtrls, Classes;
 type
   TForm1 = class(TForm)
     dlgOpen: TOpenDialog;
     ListView: TListView;
     imgList: TImageList;
     Panel: TPanel;
     btnGetFile: TButton;
     btnGetIcon: TButton;
     edFileName: TEdit;
     procedure btnGetFileClick(Sender: TObject);
     procedure btnGetIconClick(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 var
   Form1: TForm1;
 implementation
 {$R *.dfm}
 procedure TForm1.btnGetFileClick(Sender: TObject);
 begin
   { choose file to get icon from }
   if dlgOpen.Execute then edFileName.Text := dlgOpen.FileName;
 end;
 procedure TForm1.btnGetIconClick(Sender: TObject);
 var
   Icon : TIcon;
   ListItem : TListItem;
   shInfo : TSHFileInfo;
   sFileType : string;
 begin
   { initialise ListView and Icon }
   ListView.SmallImages := imgList;
   Icon := TIcon.Create;
   try
     ListView.Items.BeginUpdate;
     ListItem := listview.items.add;{ Initialise ListView.Item.Add }
     { get details about file type from SHGetFileInfo }
     SHGetFileInfo(PChar(edFileName.Text), 0, shInfo,
       SizeOf(shInfo), SHGFI_TYPENAME);
     sFileType := shInfo.szTypeName;
     { is this a shortcut file ? }
     if shInfo.szTypeName = 'Shortcut' then
       SHGetFileInfo(PChar(edFileName.Text), 0, shInfo, SizeOf(shInfo),
         SHGFI_LINKOVERLAY or SHGFI_ICON or
         SHGFI_SMALLICON or SHGFI_SYSICONINDEX)
     else
       { ...otherwise treat it as a normal file}
       SHGetFileInfo(PChar(edFileName.Text), 0, shInfo, SizeOf(shInfo),
         SHGFI_ICON or SHGFI_SMALLICON or
         SHGFI_SYSICONINDEX);
     { assign icon }
     Icon.Handle := shInfo.hIcon;
     { List File name, Icon and FileType in ListView}
     ListItem.Caption := ExtractFileName(edFileName.Text);    //...add filename 
    ListItem.SubItems.Add(sFileType); //...and filetype.. 
    ListItem.ImageIndex := imgList.AddIcon(Icon); //...and icon. 
  finally
     ListView.Items.EndUpdate; //..free memory on icon and clean up. 
    sFileType := '';
     Icon.Free;
   end;
 end;
 end.

Как получить короткий путь файла если есть длинный.

// Короткий
GetShortPathName(LongPath) 
// Наоборот длинный
GetFullPathName(ShortPath)

Как считать сигнал с микрофона.

В Windows нет разделения каналов записи по источникам.

CD-ROM ----------|
|                |--- Динамики
Микрофон --------| |
|                   - Windows --|--- Записывающие программы
Линейный вход ---| |
|                |--- Линейный выход
MIDI ------------|

Все поступающие в систему звуки смешиваются, и лишь после этого их получает программа.

Для получения звукового сигнала нужно воспользоваться WinAPI. WaveInOpen открывает доступ к микрофону. Одновременно только одна программа может работать с микрофоном. Заодно Вы указываете, какая нужна частота, сколько бит на значение и размер буфера. От последнего зависит, как часто и в каком объеме информация будет поступать в программу.

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

Функции WaveInReset и WaveInClose прекратят поступление информации в программу и закроют доступ к микрофону.

Эта программа считывает сигнал с микрофона и выводит его на экран. Частота сигнала - 22050 Гц. Количество бит определяется флажком, размер буфера TrackBar-ом.

unit Unit1;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, ComCtrls, MMSystem;
type
  TData8 = array [0..127] of byte;
  PData8 = ^TData8;
  TData16 = array [0..127] of smallint;
  PData16 = ^TData16;
  TPointArr = array [0..127] of TPoint;
  PPointArr = ^TPointArr;
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    PaintBox1: TPaintBox;
    TrackBar1: TTrackBar;
    CheckBox1: TCheckBox;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure CheckBox1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    procedure OnWaveIn(var Msg: TMessage); message MM_WIM_DATA;
end;
var
  Form1: TForm1;
implementation
{$R *.DFM}
var
  WaveIn: hWaveIn;
  hBuf: THandle;
  BufHead: TWaveHdr;
  bufsize: integer;
  Bits16: boolean;
  p: PPointArr;
  stop: boolean = false;
procedure TForm1.Button1Click(Sender: TObject);
var
  header: TWaveFormatEx;
  BufLen: word;
  buf: pointer;
begin
  BufSize := TrackBar1.Position * 500 + 100; { Размер буфера }
  Bits16 := CheckBox1.Checked;
  with header do
  begin
    wFormatTag := WAVE_FORMAT_PCM;
    nChannels := 1; { количество каналов }
    nSamplesPerSec := 22050; { частота }
    wBitsPerSample := integer(Bits16) * 8 + 8; { 8 / 16 бит }
    nBlockAlign := nChannels * (wBitsPerSample div 8);
    nAvgBytesPerSec := nSamplesPerSec * nBlockAlign;
    cbSize := 0;
  end;
  WaveInOpen(Addr(WaveIn), WAVE_MAPPER, addr(header),
  Form1.Handle, 0, CALLBACK_WINDOW);
  BufLen := header.nBlockAlign * BufSize;
  hBuf := GlobalAlloc(GMEM_MOVEABLE and GMEM_SHARE, BufLen);
  Buf := GlobalLock(hBuf);
  with BufHead do
  begin
    lpData := Buf;
    dwBufferLength := BufLen;
    dwFlags := WHDR_BEGINLOOP;
  end;
  WaveInPrepareHeader(WaveIn, Addr(BufHead), sizeof(BufHead));
  WaveInAddBuffer(WaveIn, addr(BufHead), sizeof(BufHead));
  GetMem(p, BufSize * sizeof(TPoint));
  stop := true;
  WaveInStart(WaveIn);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
  if stop = false then
    Exit;
  stop := false;
  while not stop do
    Application.ProcessMessages;
  stop := false;
  WaveInReset(WaveIn);
  WaveInUnPrepareHeader(WaveIn, addr(BufHead), sizeof(BufHead));
  WaveInClose(WaveIn);
  GlobalUnlock(hBuf);
  GlobalFree(hBuf);
  FreeMem(p, BufSize * sizeof(TPoint));
end;
procedure TForm1.OnWaveIn;
var
  i: integer;
  data8: PData8;
  data16: PData16;
  h: integer;
  XScale, YScale: single;
begin
  h := PaintBox1.Height;
  XScale := PaintBox1.Width / BufSize;
  if Bits16 then
  begin
    data16 := PData16(PWaveHdr(Msg.lParam)^.lpData);
    YScale := h / (1 shl 16);
    for i := 0 to BufSize - 1 do
      p^[i] := Point(round(i * XScale),
    round(h / 2 - data16^[i] * YScale));
  end
  else
  begin
    Data8 := PData8(PWaveHdr(Msg.lParam)^.lpData);
    YScale := h / (1 shl 8);
    for i := 0 to BufSize - 1 do
      p^[i] := Point(round(i * XScale),
    round(h - data8^[i] * YScale));
  end;
  with PaintBox1.Canvas do
  begin
    Brush.Color := clWhite;
    FillRect(ClipRect);
    Polyline(Slice(p^, BufSize));
  end;
  if stop then
    WaveInAddBuffer(WaveIn, PWaveHdr(Msg.lParam), SizeOf(TWaveHdr))
  else
    stop := true;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
  Button2.Click;
end;
procedure TForm1.CheckBox1Click(Sender: TObject);
begin
  if stop then
  begin
    Button2.Click;
    Button1.Click;
  end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
  TrackBar1.OnChange := CheckBox1Click;
  Button1.Caption := 'Start';
  Button2.Caption := 'Stop';
  CheckBox1.Caption := '16 / 8 bit';
end;
end.

Извлечение звуков из системного динамика под Windows95.

procedure Sound(Freq: Word);
var
  B: Byte;
begin
  if Freq > 18 then
  begin
    Freq := Word(1193181 div LongInt(Freq));
    B := Byte(GetPort($61));
    if (B and 3) = 0 then
    begin
      SetPort($61, Word(B or 3));
      SetPort($43, $B6);
    end;
    SetPort($42, Freq);
    SetPort($42, Freq shr 8);
  end;
end;
procedure NoSound;
var
  Value: Word;
begin
  Value := GetPort($61) and $FC;
  SetPort($61, Value);
end;
procedure SetPort(address, Value: Word);
var
  bValue: byte;
begin
  bValue := trunc(Value and 255);
  asm
    mov dx, address
    mov al, bValue
    out dx, al
  end;
end;
function GetPort(address: word): word;
var
  bValue: byte;
begin
  asm
    mov dx, address
    in al, dx
    mov bValue, al
  end;
  GetPort := bValue;
end;

Под WinNT вы можете использовать Beep(Tone, Duration) (задавать тон и продолжительность звучания).

Извлечение звуков из системного динамика под Windows95 2.

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

procedure MakeSound(note, duration: integer);
{
Цель:      Проигрывание звуков на динамике PC.
Параметры: note = шаг тона (правильный диапазон с 1 по 84 (1
самый низкий тон и 84 самый высокий)
duration = продолжительность звучания (допустимый диапазон
с 1 по 128... но это мои догадки... чем меньше значение
тем короче продолжительность)
}
var
  result: integer;
begin
  {проверка на правильность величины... должно быть 1-84}
  if (note < 1) or (note > 84) then
    exit;
  {проверка на правильность величины... по моим догадкам, должно быть
  в диапазоне от 1 до 128}
  if (duration < 1) or (duration > 128) then
    exit;
  {открываем звуковой канал}
  result := OpenSound;
  {устанавливаем размер звуковой очереди (не очищайте это! Я думаю что
  каждая нота требует 6 байт.)}
  result := SetVoiceQueueSize(1, 6);
  {устанавливаем звуковую ноту (и ее длительность)}
  result := SetVoiceNote(1, note, duration, 1);
  {проигрываем ноту}
  result := StartSound;
  {ожидаем окончания звучания}
  result := WaitSoundState(S_QUEUEEMPTY);
  {закрываем звуковой канал}
  CloseSound;
end;

Затем можно вызвать эту функцию следующим образом...

MakeSound(1,1);
MakeSound(32,10); 

Эти две строчки заставят динамик вашего PC зазвучать сначала в низком диапазоне (продолжительностью в секунду или две), и затем немного дольше в более высоком диапазоне.

Получить звук с микрофона.

Сначала надо создать пустой аудио файл, допустим Windows Audio Recorder, причем какие у него будут параметры, такие будут и у результирующего файла, затем с помощью var Media:TMediaPlayer.

procedure TForm1.btRecordClick(Sender: TObject);
begin
  with Media do
  begin
    { Set FileName to the test.wav file to }
    { get the recording parameters. }
    FileName := 'd:\test.wav';
    { Open the device. }
    Open;
    { Start recording. }
    Wait := False;
    StartRecording;
  end;
end;
procedure TForm1.btStopClick(Sender: TObject);
begin
  with Media do
  begin
    { Stop recording. }
    Stop;
    { Change the filename to the new file we want to write. }
    FileName := 'd:\new.wav';
    { Save and close the file. }
    Save;
    Close;
  end;
end;

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

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

procedure GetSubDirs(const sRootDir: string; slt: TStrings);
 var
   srSearch: TSearchRec;
   sSearchPath: string;
   sltSub: TStrings;
   i: Integer;
 begin
   sltSub := TStringList.Create;
   slt.BeginUpdate;
   try
     sSearchPath := AddDirSeparator(sRootDir);
     if FindFirst(sSearchPath + '*', faDirectory, srSearch) = 0 then
       repeat
         if ((srSearch.Attr and faDirectory) = faDirectory) and
           (srSearch.Name <> '.') and
           (srSearch.Name <> '..') then
         begin
           slt.Add(sSearchPath + srSearch.Name);
           sltSub.Add(sSearchPath + srSearch.Name);
         end;
       until (FindNext(srSearch) <> 0);
     FindClose(srSearch);
     for i := 0 to sltSub.Count - 1 do
       GetSubDirs(sltSub.Strings[i], slt);
   finally
     slt.EndUpdate;
     FreeAndNil(sltSub);
   end;
 end;

Взять один символ из потока памяти.

 unit MsFormR;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls;
type
  TForm1 = class(TForm)
    OpenDialog1: TOpenDialog;
    SaveDialog1: TSaveDialog;
    Memo1: TMemo;
    ListBox1: TListBox;
    Panel1: TPanel;
    Button1: TButton;
    Button2: TButton;
    Splitter1: TSplitter;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    MemStr1: TMemoryStream;
  public
    procedure ShowMemStr;
  end;
var
  Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
  MemStr1 := TMemoryStream.Create;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
  Str1: TFileStream;
begin
  OpenDialog1.Filter :=
    'Any file (*.*)|*.*';
  OpenDialog1.DefaultExt := '*';
  if OpenDialog1.Execute then
  begin
    Str1 := TFileStream.Create (
      OpenDialog1.Filename, fmOpenRead);
    try
      MemStr1.LoadFromStream (Str1);
      ShowMemStr;
      Button2.Enabled := true;
    finally
      Str1.Free;
    end;
  end;
end;
procedure TForm1.ShowMemStr;
begin
  Memo1.Lines.LoadFromStream (MemStr1);
end;
procedure TForm1.Button2Click(Sender: TObject);
const
  ndx: LongInt = 1;
var
  pch:  PChar;
  tmpC: Char;
begin
  pch := MemStr1.Memory;
  tmpC := pch[ndx];
  pch[ndx] := #0;
  ListBox1.Items.SetText(MemStr1.Memory);
  pch[ndx] := tmpC;
  if ndx < MemStr1.Size then
    Inc(ndx)
  else
    Button2.Enabled := False;
end;
end.

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

Получить системный фокус приложения.

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

function GetSysFocus: Integer;
 var
   hFgWin, FgThreadID, hFocusWin: Integer;
 begin
   hFgWin     := GetForegroundWindow;
   FgThreadID := GetWindowThreadProcessID(hFgWin, nil);
   if AttachThreadInput(GetCurrentThreadID, FgThreadID, True) then
   begin
     hFocusWin := GetFocus;
     Result    := GetFocus;
     AttachThreadInput(GetCurrentThreadID, FgThreadID, False);
   end
   else
     Result := GetFocus;
 end;

Вывести информацию о системе.

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

{ 
  The SYSTEM_INFO structure contains information about the current computer 
  system. This includes the architecture and type of the processor, the number of 
  processors in the system, the page size, and other such information. 
}
 procedure TForm1.Button1Click(Sender: TObject);
 var
   SysInfo: TSystemInfo;
 begin
   GetSystemInfo(SysInfo);
   with ListBox1.Items, SysInfo do
   begin
     Add('ProcessorArchitecture:' + IntToStr(wProcessorArchitecture));
     Add(FloatToStr(dwPageSize) + ' Kb page size');
     Add(Format('Lowest memory address accessible to applications and DLL - %p',
       [lpMinimumApplicationAddress]));
     Add(Format('Highest memory address accessible to applications and DLL - %p',
       [lpMaximumApplicationAddress]));
     Add('OEMID:' + IntToStr(dwOemId));
     Add('ActiveProcessorMask:' + IntToStr(dwActiveProcessorMask));
     Add(IntToStr(dwNumberOfProcessors) + ' - number of processors');
     Add('ProcessorType:' + IntToStr(dwProcessorType));
     case wProcessorLevel of
       3: Add('Intel 80386 processor level');
       4: Add('Intel 80486 processor level');
       5: Add('Intel Pentium processor level');
     end;
     Add(FloatToStr(dwAllocationGranularity / 1024) +
       ' Kb - granularity with which virtual memory is allocated');
     Add('ProcessorRevision:' + IntToStr(wProcessorRevision));
   end;
 end;

Получить шрифт системного меню.

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

function GetMenuFont: TFont;
 var
   ncm: TNonClientMetrics;
 begin
   ncm.cbSize := SizeOf(TNonClientMetrics);
   SystemParametersInfo(SPI_GETNONCLIENTMETRICS, SizeOf(TNonClientMetrics), @ncm, 0);
   Result := TFont.Create;
   { 
  lfCaptionFont - regular captions 
  lfSmCaptionFont - small captions 
  lfMenuFont - menus 
  lfStatusFont - status bars 
  lfMessageFont - message boxes 
  }
   Result.Handle := CreateFontIndirect(ncm.lfCaptionFont);
 end;
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   label1.Caption := GetMenuFont.Name;
 end;

Получение информации о таблице.

Вам нужно воспользоваться свойством FieldDefs. В следующем примере список полей и их соответствующий размер передается компоненту TMemo (расположенному на форме) с именем Memo1:

procedure TForm1.ShowFields;
var
  i: Word;
begin
  Memo1.Lines.Clear;
  Table1.FieldDefs.Update;                     
  { должно быть вызвано, если Table1 не активна }
  for i := 0 to Table1.FieldDefs.Count - 1 do
    With Table1.FieldDefs.Items[i] do
      Memo1.Lines.Add(Name + ' - ' + IntToStr(Size));
end;

Если вам просто нужны имена полей (FieldNames), то используйте метода TTable GetFieldNames: GetIndexNames для получения имен индексов:

var 
  FldNames, IdxNames : TStringList;
begin
  FldNames := TStringList.Create;
  IdxNames := TStringList.Create;
  If Table1.State = dsInactive then 
    Table1.Open;
  Table1.GetFieldNames(FldNames);
  Table1.GetIndexNames(IdxNames);
  {...... используем полученную информацию ......}
  FldNames.Free; {освобождаем stringlist}
  IdxNames.Free;
end;

Для получения информации об определенном поле вы должны использовать FieldDef.

Получение физического пути к таблице.

Автор: Xavier Pacheco

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

pDBDesc = ^DBDesc;
DBDesc = packed record        { Описание данной базы данных }
szName          : DBINAME;    { Логическое имя (или псевдоним) }
szText          : DBINAME;    { Описательный текст }
szPhyName       : DBIPATH;    { Физическое имя/путь }
szDbType        : DBINAME;    { Тип базы данных }
end;

DBIERR_NONE             Описание базы данных для pszName было успешно извлечено.
DBIERR_OBJNOTFOUND      База данных, указанная в pszName, не была обнаружена.

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

var
  vDBDesc: DBDesc;
  DirTable: String;
begin
  Check(DbiGetDatabaseDesc(PChar(Table1.DatabaseName), @vDBDesc));
  DirTable := Format('%s\%s', [vDBDesc.szPhyName, Table1.TableName]);
  ShowMessage(DirTable);
end;

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

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

handle_taskbar := FindWindow('Shell_TrayWnd', nil);

Получение информации о TaskBar.

Для вывода информации мы будет использовать компонент TStringGrid с закладки Additional.

Сначала вам нужно будет после.

var
  Form1: TForm1;

Добавить следующий код:

AppBarData : TAppBarData;
bAlwaysOnTop, bAutoHide : boolean;
Clrect,rect : TRect;
Edge: UInt;

Затем после слова Implementation пишем.

procedure DetectTaskBar;
begin
  AppBarData.hWnd := FindWindow('Shell_TrayWnd', nil);
  AppBarData.cbSize := sizeof(AppBarData);
  bAlwaysOnTop := (SHAppBarMessage(ABM_GETSTATE, AppBardata)
  and ABS_ALWAYSONTOP) <> 0;
  bAutoHide := (SHAppBarMessage(ABM_GETSTATE, AppBardata)
  and ABS_AUTOHIDE) <> 0;
  GetClientRect(AppBarData.hWnd, Clrect);
  GetWindowRect(AppBarData.hwnd, rect);
  if rect.top > 0 then
    Edge := ABE_BOTTOM
  else
  if rect.bottom then
    Edge:=ABE_TOP
  else
  if rect.right then
    Edge:=ABE_LEFT
  else
    Edge:=ABE_RIGHT;
end;

И осталось описать самое главное - обработчик нажатия кнопки:

procedure TForm1.Button1Click(Sender: TObject);
begin
  DetectTaskBar;
  StringGrid1.Cells[0,0] := 'Выше других окон';
  StringGrid1.Cells[0,1] := 'Автоматически убирать с экрана';
  StringGrid1.Cells[0,2] := 'Клиентская область';
  StringGrid1.Cells[0,3] := 'Оконная область';
  StringGrid1.Cells[0,4] := 'Края';
  if bAlwaysOnTop = true then
    StringGrid1.Cells[1,0] := 'true'
  else
    StringGrid1.Cells[1,0] := 'false';
  if bAutoHide = true then
    StringGrid1.Cells[1,1] := 'true'
  else
    StringGrid1.Cells[1,1] := 'false';
  StringGrid1.Cells[1,2] := IntToStr(Clrect.Left)+':'+IntToStr(Clrect.Top) +
  ':'+IntToStr(Clrect.Right)+':'+IntToStr(Clrect.Bottom);
  StringGrid1.Cells[1,3] := IntToStr(rect.Left)+':'+IntToStr(rect.Top) +
  ':'+IntToStr(rect.Right)+':'+IntToStr(rect.Bottom);
  StringGrid1.Cells[1,4] := IntToStr(Edge);
end;

Определить позицию панели задач.

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

{With SHAppBarMessage }
 uses
   ShellAPI;
 procedure TForm1.Button1Click(Sender: TObject);
 var
   tabd: TAppBarData;
   PosString: string;
 begin
   FillChar(tabd, SizeOf(TAppBarData), 0);
   tabd.cbSize := SizeOf(TAppBarData);
   if SHAppBarMessage(ABM_GETTASKBARPOS, Tabd) = 0 then Exit;
   with Tabd.rc do
     PosString := Format(' (%d, %d);(%d, %d) ', [Left, Top, Right, Bottom]);
   case tabd.uEdge of
     ABE_LEFT: ShowMessage('Left Position' + PosString);
     ABE_TOP: ShowMessage('Top Position' + PosString);
     ABE_RIGHT: ShowMessage('Right Position' + PosString);
     ABE_BOTTOM: ShowMessage('Bottom Position' + PosString);
   end;
 end;

Определить позицию панели задач 2.

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

 {With FindWindow, GetWindowRect }
 type
   TTaskBarPos = (_TOP, _BOTTOM, _LEFT, _RIGHT, _NONE);
 function GetTaskBarPos: TTaskBarPos;
 var
   hTaskbar: HWND;
   T: TRect;
   scrW, scrH: integer;
 begin
   hTaskBar := FindWindow('Shell_TrayWnd', nil);
   if hTaskbar <> 0 then
   begin
     GetWindowRect(hTaskBar, T);
     ScrW := Screen.Width;
     ScrH := Screen.Height;
     if (T.Top > scrH div 2) and (T.Right >= scrW) then
       Result := _BOTTOM
     else if (T.Top < scrH div 2) and (T.Bottom <= scrW div 2) then
       Result := _TOP
     else if (T.Left < scrW div 2) and (T.Top <= 0) then
       Result := _LEFT
     else // the last "if" is not really needed 
    if T.Left >= ScrW div 2 then
       Result := _RIGHT;
   end;
 end;
 procedure TForm1.Button5Click(Sender: TObject);
 var
   TaskBarPos: TTaskBarPos;
 begin
   TaskBarPos := GetTaskBarPos;
   case TaskBarPos of
     _LEFT: ShowMessage('Left Position');
     _TOP: ShowMessage('Top Position');
     _RIGHT: ShowMessage('Right Position');
     _BOTTOM: ShowMessage('Bottom Position');
   end;
 end;

Получить дескриптор окна, которое владеет кнопками запущенных программ на панели задач.

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

{ 
  In this article, I wish to describe the useful undocumented function 
  GetTaskmanWindow. The GetTaskmanWindow function returns a handle to 
  the window that ownes the taskbar buttons. 
  Here is the quoting about taskbar from Microsoft MSDN: 
  "The Microsoft® Windows® interface includes a special application desktop 
  toolbar called the taskbar. 
  The taskbar can be used for such tasks as switching between open 
  windows and starting new applications..." 
  and "The taskbar includes the Start menu, taskbar buttons, 
  a shortcut menu, and a status area...". 
  Unfortunately, Win32 API doesn't contain documented 
  function that can be used for accessing to the 
  taskbar so we should again use an undocumented way. 
  Here is the prototype for GetTaskmanWindow: 
   function GetTaskmanWindow (): HWND; 
  As always, Microsoft doesn't provide us with the exports symbols 
  in the User32.lib for this function, so we should load them dynamically using the 
  GetProcAddress and GetModuleHandle functions: 
}
 // getaskmanwnd.cpp (Windows NT/2000) 
// 
// This example will show you how you can obtain a handle to the 
// Windows Taskbar window. 
// Translated from C to Delphi by Thomas Stutz 
// Original Code: 
// (c)1999 Ashot Oganesyan K, SmartLine, Inc 
// mailto:ashot@aha.ru, http://www.protect-me.com, http://www.codepile.com 
function TaskmanWindow: HWND;
 type
   TGetTaskmanWindow = function(): HWND; stdcall;
 var
   hUser32: THandle;
   GetTaskmanWindow: TGetTaskmanWindow;
 begin
   Result := 0;
   hUser32 := GetModuleHandle('user32.dll');
   if (hUser32 > 0) then
   begin
     @GetTaskmanWindow := GetProcAddress(hUser32, 'GetTaskmanWindow');
     if Assigned(GetTaskmanWindow) then
     begin
       Result := GetTaskmanWindow;
     end;
   end;
 end;
 procedure ShowTaskmanWindow(bValue: Boolean);
 var
   hTaskmanWindow: Hwnd;
 begin
   hTaskmanWindow := TaskmanWindow;
   if hTaskmanWindow <> 0 then
   begin
     ShowWindow(GetParent(hTaskmanWindow), Ord(bValue));
   end;
 end;
 // Example to Hide the Taskman Window 
procedure TForm1.Button1Click(Sender: TObject);
 begin
   ShowTaskmanWindow(False);
 end;

Как оперделить все IP и порты на моем компьютере.

Импорт GetTcpTable:

unit TcpTable;
interface
type
  PDWord = ^Longword;
  PMIB_TCPROW = ^TMIB_TCPROW;
  TMIB_TCPROW = record
    dwState: LongWord;
    dwLocalAddr: LongWord;
    dwLocalPort: LongWord;
    dwRemoteAddr: LongWord;
    dwRemotePort: LongWord;
  end;
  PMIB_TCPTABLE = ^TMIB_TCPTABLE;
  TMIB_TCPTABLE = record
    dwNumEntries: LongWord;
    table: array[0..0] of TMIB_TCPROW;
  end;
function GetTcpTable(var TcpTable: PMIB_TCPTABLE;
  var Size: PDWord; bOrder: Boolean): LongWord; stdcall
implementation
function GetTcpTable; external 'Iphlpapi.dll' name 'GetTcpTable';
end.

Вызов GetTcpTable:

{$R-}
Entries := 16;
Sz := SizeOf(TMIB_TCPTABLE) + SizeOf(TMIB_TCPROW) * (Entries - 1);
pMibTable := nil;
try
  repeat
    ReallocMem(pMibTable, Sz);
    Res := GetTcpTable(pMibTable^, Sz, False);
  until Res <> ERROR_INSUFFICIENT_BUFFER;
  if Res <> NO_ERROR then
  begin
    ShowMessage(SysErrorMessage(Res));
    exit;
  end;
  for Entries := 0 to pMibTable.dwNumEntries - 1 do
  begin
    < Делать что - то >
  end;
finally
  FreeMem(pMibTable);
end;
{$R+}

Как получить текст HTML Документа из TWebBrowser без тегов.

uses mshtml, activex;
procedure GetHtmlCode(WebBrowser: TWebBrowser; FileName: string);
var
 htmlDoc: IHtmlDocument2;
 PersistFile: IPersistFile;
begin
 htmlDoc := WebBrowser.document as IHtmlDocument2;
 PersistFile := HTMLDoc as IPersistFile;
 PersistFile.save(StringToOleStr(FileName), true);
end;

Как получить текст HTML Документа из TWebBrowser без тегов 2.

var
  Document: IHTMLDocument2;
begin
 Document := WB.Document as IHtmlDocument2;
 if Document < >  nil then
   Memo1.Text := (Document.all.Item(NULL, 0) as IHTMLElement).OuterHTML;

Извлечение текста из TMemoField.

Автор: Steve Schafer

var
  P: PChar;
  S: TMemoryStream;
  Size: LongInt;
begin
  S := TMemoryStream.Create;
  MyMemoField.SaveToStream(S);
  Size := S.Position;
  GetMem(P, Size + 1);
  S.Position := 0;
  S.Read(P^, Size);
  P[Size] := #0;
  S.Free;
  { используем текст в PChar }
  FreeMem(P, Size + 1);
end;

Обнаружить, использует ли пользователь стиль XP или классический стиль.

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

function _IsThemeActive: Boolean;
 // Returns True if the user uses XP style 
const
   themelib = 'uxtheme.dll';
 type
   TIsThemeActive = function: BOOL; stdcall;
 var
   IsThemeActive: TIsThemeActive;
   huxtheme: HINST;
 begin
   Result := False;
   // Check if XP or later Version 
  if (Win32Platform  = VER_PLATFORM_WIN32_NT) and
      (((Win32MajorVersion = 5) and (Win32MinorVersion >= 1)) or
       (Win32MajorVersion > 5)) then
   begin
     huxtheme := LoadLibrary(themelib);
     if huxtheme <> 0 then
     begin
       try
         IsThemeActive := GetProcAddress(huxtheme, 'IsThemeActive');
         Result := IsThemeActive;
       finally
        if huxtheme > 0 then
           FreeLibrary(huxtheme);
       end;
     end;
   end;
 end;
 // Example Call: 
procedure TForm1.Button1Click(Sender: TObject);
 begin
  if _IsThemeActive then
    ShowMessage('Windows Themes are active.');
 end;

Как получить список часовых поясов.

uses
  Registry;
...
var
  reg : TRegistry;
  ts : TStrings;
  i : integer;
begin
  reg := TRegistry.Create;
  reg.RootKey := HKEY_LOCAL_MACHINE;
  reg.OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\Time Zones', false);
  if reg.HasSubKeys then
  begin
    ts := TStringList.Create;
    reg.GetKeyNames(ts);
    reg.CloseKey;
    for i := 0 to ts.Count -1 do
    begin
      reg.OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\Time Zones\' + ts.Strings[i], false);
      Memo1.Lines.Add(ts.Strings[i]);
      Memo1.Lines.Add(reg.ReadString('Display'));
      Memo1.Lines.Add(reg.ReadString('Std'));
      Memo1.Lines.Add(reg.ReadString('Dlt'));
      Memo1.Lines.Add('----------------------');
      reg.CloseKey;
    end;
    ts.Free;
  end
  else
    reg.CloseKey;
  reg.free;
end;

Разбивка строки на слова.

Приведу несколько простых функций, позволяющих работать с отдельными словами в строке. Возможно они пригодятся вам для разбивки текстовых полей на отдельные слова (for i := 1 to NumToken do ...) с последующим сохранением их в базе данных.

function GetToken(aString, SepChar: string; TokenNum: Byte): string;
{
параметры: aString : полная строка
SepChar : единственный символ, служащий
разделителем между словами (подстроками)
TokenNum: номер требуемого слова (подстроки))
result    : искомое слово или пустая строка, если количество слов
меньше значения 'TokenNum'
}
var
  Token: string;
  StrLen: Byte;
  TNum: Byte;
  TEnd: Byte;
begin
  StrLen := Length(aString);
  TNum := 1;
  TEnd := StrLen;
  while ((TNum <= TokenNum) and (TEnd <> 0)) do
  begin
    TEnd := Pos(SepChar, aString);
    if TEnd <> 0 then
    begin
      Token := Copy(aString, 1, TEnd - 1);
      Delete(aString, 1, TEnd);
      Inc(TNum);
    end
    else
    begin
      Token := aString;
    end;
  end;
  if TNum >= TokenNum then
  begin
    GetToken1 := Token;
  end
  else
  begin
    GetToken1 := '';
  end;
end;
function NumToken(aString, SepChar: string): Byte;
{
parameters: aString : полная строка
SepChar : единственный символ, служащий
разделителем между словами (подстроками)
result    : количество найденных слов (подстрок)
}
var
  RChar: Char;
  StrLen: Byte;
  TNum: Byte;
  TEnd: Byte;
begin
  if SepChar = '#' then
  begin
    RChar := '*'
  end
  else
  begin
    RChar := '#'
  end;
  StrLen := Length(aString);
  TNum := 0;
  TEnd := StrLen;
  while TEnd <> 0 do
  begin
    Inc(TNum);
    TEnd := Pos(SepChar, aString);
    if TEnd <> 0 then
    begin
      aString[TEnd] := RChar;
    end;
  end;
  Result := TNum;
end;
// Или другое решение:
function CopyColumn(const s_string: string; c_fence: char;
  i_index: integer): string;
var
  i, i_left: integer;
begin
  result := EmptyStr;
  if i_index = 0 then
  begin
    exit;
  end;
  i_left := 0;
  for i := 1 to Length(s_string) do
  begin
    if s_string[i] = c_fence then
    begin
      Dec(i_index);
      if i_index = 0 then
      begin
        result := Copy(s_string, i_left + 1, i - i_left - 1);
        exit;
      end
      else
      begin
        i_left := i;
      end;
    end;
  end;
  Dec(i_index);
  if i_index = 0 then
  begin
    result := Copy(s_string, i_left + 1, Length(s_string));
  end;
end;

Я знаю что в GetToken параметр SepChar (в моем случае c_fence) строка, не символ, но комментарий гласит, что функция ожидает единственный символ в этой строке, и это очевидно, поскольку если вы пошлете более одного символа, функция попросту несработает. ( Delete(aString,1,TEnd) будет ошибкой, если Length( SepChar ) > 1 ).

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

function GetMemoryTotalPhys: DWord;
var
  memStatus: TMemoryStatus;
begin
  memStatus.dwLength := sizeOf (memStatus);
  GlobalMemoryStatus(memStatus);
  Result := memStatus.dwTotalPhys;
end;

Получить прозрачный цвет.

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

interface
 {------------------------------------------------------------------------------}
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
 {------------------------------------------------------------------------------}
 //Hilfsfunktion zum Auslesen eines Bytes aus TColor 
//Value gibt die Farbe an 
//Shift gibt die Anzahl der zu schiebenden Bits an 
//Bsp: um aus Value=$00120000 das Rot-Byte auszulesen, muss Shift den Wert 16 haben 
//     ($12 wird dann zuruckgegeben 
function GetByte(Value : TColor; Shift : byte): byte;
   {------------------------------------------------------------------------------}
   //Hilfsprozedur zum Auslesen des Rot-,Grun- und Blauwertes aus TColor 
  //nutzt GetByte 
procedure ColorToRGB(Color : TColor; var R, G, B : byte);
   {------------------------------------------------------------------------------}
   //Hilfsfunckion zum Erstellen eines TColor aus Rot-,Grun- und Blauwerten 
function RGBToColor(R, G, B : byte): TColor;
   {------------------------------------------------------------------------------}
   //Eigentliche Transparenzfunktion, ermittelt die Transparenzfarbe des transparenten 
  //Vordergrunds, wenn Hintergrundfarbe=BGColor und Vordergrundfarbe=FRColor ist 
  //TranspValue gibt den Ganzzahligen Prozentsatz des Transparenzwertes an 
function TransparencyColor(BGColor, FRColor : TColor; TranspValue : byte): TColor;
   {------------------------------------------------------------------------------}
 implementation
 function GetByte(Value : TColor; Shift : byte): byte;
 begin
   Result := (Value and ($FF shl Shift)) shr Shift;
   //Byte an entsprechender Stelle maskieren und dann nach Rechts verschieben 
end;
 {------------------------------------------------------------------------------}
 procedure ColorToRGB(Color : TColor; var R, G, B : byte);
 begin
   R := GetByte(Color, 16); //zweites Byte aus Color (v.R.) 
  G := GetByte(Color, 8);  //drittes Byte aus Color (v.R.) 
  B := GetByte(Color, 0);  //viertes Byte aus Color (v.R.) 
end;
 {------------------------------------------------------------------------------}
 function RGBToColor(R, G, B : byte): TColor;
 begin
   Result := ((R and $FF) shl 16) +
     ((G and $FF) shl 8) + (B and $FF);
 end;
 {------------------------------------------------------------------------------}
 function TransparencyColor(BGColor, FRColor : TColor; TranspValue : byte): TColor;
 var
    BGR, BGG, BGB, FRR, FRG, FRB, ergR, ergG, ergB : byte;
   TrFact : real;
 begin
   //Transparenzfaktor errechnen 
  TrFact := TranspValue / 100;
   //Hinter- und Vordergrundfarbe in Rot-,Grun- und Blauwerte splitten 
  ColorToRGB(BGColor, BGR, BGG, BGB);
   ColorToRGB(FRColor, FRR, FRG, FRB);
   //Ergebnisfarbwerte errechnen 
  ergR := byte(Trunc(BGR * TrFact + FRR * (1 - TrFact)));
   ergG := byte(Trunc(BGG * TrFact + FRG * (1 - TrFact)));
   ergB := byte(Trunc(BGB * TrFact + FRB * (1 - TrFact)));
   //Rot-,Grun- und Blauwert zu TColor und zuruckgeben 
  Result := RGBToColor(ErgR, ergG, ergB);
 end;
 {------------------------------------------------------------------------------}

Функция, возвращающая тип.

// функция Chameleon, возвращающая тип сгенерированного исключения
unit Unit1;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls;
type
  MyBoolean = class
  public
    Value: boolean;
  end;
  MyInteger = class
  public
    Value: integer;
  end;
  MyClass = class
  public
    Value: TStrings;
  end;
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure MyProc;
    function Chameleon: boolean;
  end;
var
  Form1: TForm1;
implementation
{$R *.DFM}
function TForm1.Chameleon: boolean;
var
  b: MyBoolean;
  i: MyInteger;
  c: MyClass;
  r: integer;
begin
  r := Random(3);
  case r of
    0:
      begin
        b := MyBoolean.Create;
        raise b;
      end;
    1:
      begin
        i := MyInteger.Create;
        raise i;
      end;
    2:
      begin
        c := MyClass.Create;
        raise c;
      end;
  end;
end;
procedure TForm1.MyProc;
begin
  try
    Chameleon;
  except
    on MyBoolean do
      ShowMessage('Функция возвратила класс MyBoolean');
    on MyInteger do
      ShowMessage('Функция возвратила класс MyInteger');
    on MyClass do
      ShowMessage('Функция возвратила класс MyClass');
  end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
  Chameleon;
end;
end.

Взгляните на тип данных Variant в D2: следующий код.

function AnyType(const TypeParm: integer): Variant;
begin
  case TypeParm of
    1: Result := 1;
    2: Result := 2.0;
    3: Result := 'Три';
    4: Result := StrToDate('4/4/1944');
  end;
end;

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

{моя форма имеет 3 метки, одну кнопку и этот код}
var
  MyFuncRetInt: function(P1, P2: Integer): Integer;
  MyFuncRetBool: function(P1, P2: Integer): LongBool;
  MyFuncRetPointer: function(P1, P2: Integer): Pointer;
function MyFuncRetAnything(P1, P2: Integer): Integer;
var
  RetPointer: Pointer;
  RetBool: LongBool;
  RetInteger: Integer;
begin
  RetPointer := nil;
  RetBool := False;
  RetInteger := 4711;
  case P1 of
    1: Result := Integer(RetPointer);
    2: Result := Integer(RetBool);
    3: Result := RetInteger;
  end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
  if MyFuncRetBool(2, 1900) then
    Label1.Caption := 'True'
  else
    Label1.Caption := 'False';
  Label2.Caption := IntToStr(MyFuncRetInt(3, 1900));
  Label3.Caption := IntToHex(Integer(MyFuncRetPointer(1, 1900)), 16);
end;
initialization
  MyFuncRetInt := @MyFuncRetAnything;
  MyFuncRetBool := @MyFuncRetAnything;
  MyFuncRetPointer := @MyFuncRetAnything;
end.

Получить список зарегистрированных Win32 модулей и их версий.

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

 { The registered Win32 type libraries/modules are registered with a 
  version number in the registry. 
  But it's possible that one modlue has more than one version. 
  The recursive function "RecurseWin32" searches from a certain path 
  for all occurences of the searched key. 
  For instance, I get the following entries for 
  "Visual Basic For Applications" on my system: 
  000204F3-0000-0000-C000-000000000046   \ 1.0 \  7  \ win32 
  "c:\\WINDOWS\\SYSTEM\\vbade32.olb" 
  000204F3-0000-0000-C000-000000000046   \ 1.0 \  9  \ win32 
  "c:\\WINDOWS\\SYSTEM\\VBAEN32.OLB" 
}
 { Die installierten bzw. registrierten Win32 TypeLibs bzw. "Modulen" 
  mussen sich mit einer Versionsnummer in der registry eintragen. 
  Zu einem bestimmten "Modul" konnen aber mehrere Versionen in der 
  Registry eingetragen sein. 
  Welche? 
  Kernstuck ist die rekursive Function "RecurseWin32", die ab einem 
  bestimmten Pfad nach jedem Vorkommen des gesuchten Schlussels sucht... 
  Zum Beispiel ermmittelt es auf meinem System entsprechend folgendes zum 
  Eintrag "Visual Basic For Applications" 
  000204F3-0000-0000-C000-000000000046   \ 1.0 \  7  \ win32 
  "c:\\WINDOWS\\SYSTEM\\vbade32.olb" 
  000204F3-0000-0000-C000-000000000046   \ 1.0 \  9  \ win32 
  "c:\\WINDOWS\\SYSTEM\\VBAEN32.OLB" 
  Diese Technik la?t sich ubrigens an weiteren Bedurfnisse anpassen... 
}
 {It's a recursiv one :-}
 function RecurseWin32(const R: TRegistry; const ThePath: string;
   const TheKey: string): string;
 var
   TheList: TStringList;
   i: Integer;
   LP: string;
   OnceUponATime: string;
 begin
   Result  := '-';
   TheList := TStringList.Create;
   try
     R.OpenKey(ThePath, False);
     R.GetKeyNames(TheList);
     R.CloseKey;
     if TheList.Count = 0 then Exit;
     for i := 0 to TheList.Count - 1 do with TheList do
        begin
         LP := ThePath + '\' + TheList[i];
         if CompareText(Strings[i], TheKey) = 0 then
          begin
           Result := LP;
           Break;
         end;
         OnceUponATime := RecurseWin32(R, LP, TheKey);
         if OnceUponATime <> '-' then
          begin
           Result := OnceUponATime;
           Break;
         end;
       end;
   finally
     TheList.Clear;
     TheList.Free;
   end;
 end;
 { Create the output list: you may change the format as you need ...}
 function GetWin32TypeLibList(var Lines: TStringList): Boolean;
 var
    R: TRegistry;
   W32: string;
   i, j, TheIntValue, TheSizeOfTheIntValue: Integer;
   TheSearchedValue, TheSearchedValueString: string;
   TheVersionList, TheKeyList: TStringList;
   TheBasisKey: string;
 begin
   Result := True;
   try
     try
       R          := TRegistry.Create;
       TheVersionList := TStringList.Create;
       TheKeyList := TStringList.Create;
       R.RootKey := HKEY_CLASSES_ROOT;
       R.OpenKey('TypeLib', False);
       TheBasisKey := R.CurrentPath;
       (* Basis Informations *)
       case R.GetDataType('') of
         rdUnknown: ShowMessage('Nothing ???');
         rdExpandString, rdString: TheSearchedValueString := R.ReadString('');
         rdInteger: TheIntValue         := R.ReadInteger('');
         rdBinary: TheSizeOfTheIntValue := R.GetDataSize('');
       end;
       (* Build the List of Keys *)
       R.GetKeyNames(TheKeyList);
       R.CloseKey;
       ShowMessage(TheKeyList.Strings[1]);
       for i := 0 to TheKeyList.Count - 1 do
          (* Loop around the typelib entries)
          (* Schleife um die TypeLib Eintrage *)
         with TheKeyList do
           if Length(Strings[i]) > 0 then
            begin
             R.OpenKey(TheBasisKey + '\' + Strings[i], False);
             TheVersionList.Clear;
             R.GetKeyNames(TheVersionList);
             R.CloseKey;
             (* Find "Win32" for each version *)
             (* Finde der "win32" fur jede VersionVersion:*)
             for j := 0 to TheVersionList.Count - 1 do
               if Length(TheVersionList.Strings[j]) > 0 then
                begin
                 W32 := RecurseWin32(R, TheBasisKey + '\' +
                   Strings[i] + '\' +
                   TheVersionList.Strings[j],
                   'Win32');
                 if W32 <> '-' then
                  begin
                   Lines.Add(W32);
                   R.OpenKey(W32, False);
                   case R.GetDataType('') of
                     rdExpandString,
                     rdString: TheSearchedValue := R.ReadString('');
                     else
                       TheSearchedValue := 'Nothing !!!';
                   end;
                   R.CloseKey;
                   Lines.Add('-----> ' + TheSearchedValue);
                 end;
               end;
           end;
     finally
       TheVersionList.Free;
       TheKeyList.Free;
     end;
   except
     Result := False;
   end;
 end;
 { Example of use / Anwendungsbeispiel }
 procedure TForm1.Button1Click(Sender: TObject);
 var
   L: TStringList;
 begin
   L := TStringList.Create;
   GetWin32TypeLibList(L);
   Memo1.Lines.Assign(L);
   L.Free;
 end;

Определить доменное имя, в которое зашел пользователь.

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

function GetDomainName: AnsiString;
 type
  WKSTA_INFO_100 = record
    wki100_platform_id: Integer;
    wki100_computername: PWideChar;
    wki100_langroup: PWideChar;
    wki100_ver_major: Integer;
    wki100_ver_minor: Integer;
  end;
  WKSTA_USER_INFO_1 = record
    wkui1_username: PChar;
    wkui1_logon_domain: PChar;
    wkui1_logon_server: PChar;
    wkui1_oth_domains: PChar;
  end;
 type
  //Win9X ANSI prototypes from RADMIN32.DLL and RLOCAL32.DLL 
 TWin95_NetUserGetInfo = function(ServerName, UserName: PChar; Level: DWORD; var
    BfrPtr: Pointer): Integer;
  stdcall;
  TWin95_NetApiBufferFree = function(BufPtr: Pointer): Integer;
  stdcall;
  TWin95_NetWkstaUserGetInfo = function(Reserved: PChar; Level: Integer; var
    BufPtr: Pointer): Integer;
  stdcall;
  //WinNT UNICODE equivalents from NETAPI32.DLL 
 TWinNT_NetWkstaGetInfo = function(ServerName: PWideChar; level: Integer; var
    BufPtr: Pointer): Integer;
  stdcall;
  TWinNT_NetApiBufferFree = function(BufPtr: Pointer): Integer;
  stdcall;
  function IsWinNT: Boolean;
  var
    VersionInfo: TOSVersionInfo;
  begin
    VersionInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
    Result := GetVersionEx(VersionInfo);
    if Result then
      Result := VersionInfo.dwPlatformID = VER_PLATFORM_WIN32_NT;
  end;
 var
  Win95_NetUserGetInfo: TWin95_NetUserGetInfo;
  Win95_NetWkstaUserGetInfo: TWin95_NetWkstaUserGetInfo;
  Win95_NetApiBufferFree: TWin95_NetApiBufferFree;
  WinNT_NetWkstaGetInfo: TWinNT_NetWkstaGetInfo;
  WinNT_NetApiBufferFree: TWinNT_NetApiBufferFree;
  WSNT: ^WKSTA_INFO_100;
  WS95: ^WKSTA_USER_INFO_1;
  EC: DWORD;
  hNETAPI: THandle;
 begin
  try
    Result := '';
    if IsWinNT then
    begin
      hNETAPI := LoadLibrary('NETAPI32.DLL');
      if hNETAPI <> 0 then
      begin @WinNT_NetWkstaGetInfo := GetProcAddress(hNETAPI, 'NetWkstaGetInfo');
          @WinNT_NetApiBufferFree  := GetProcAddress(hNETAPI, 'NetApiBufferFree');
        EC := WinNT_NetWkstaGetInfo(nil, 100, Pointer(WSNT));
        if EC = 0 then
        begin
          Result := WideCharToString(WSNT^.wki100_langroup);
          WinNT_NetApiBufferFree(Pointer(WSNT));
        end;
      end;
    end
    else
    begin
      hNETAPI := LoadLibrary('RADMIN32.DLL');
      if hNETAPI <> 0 then
      begin @Win95_NetApiBufferFree := GetProcAddress(hNETAPI, 'NetApiBufferFree');
          @Win95_NetUserGetInfo := GetProcAddress(hNETAPI, 'NetUserGetInfoA');
        EC := Win95_NetWkstaUserGetInfo(nil, 1, Pointer(WS95));
        if EC = 0 then
        begin
          Result := WS95^.wkui1_logon_domain;
          Win95_NetApiBufferFree(Pointer(WS95));
        end;
      end;
    end;
  finally
    if hNETAPI <> 0 then
      FreeLibrary(hNETAPI);
  end;
 end;
 procedure TForm1.Button1Click(Sender: TObject);
 begin
  ShowMessage(GetDomainName);
 end;

Получить список пользователей.

GetLocalUserList - возвращает список пользователей (Windows NT, Windows 2000).

unit Func;
interface
uses Sysutils, Classes, Stdctrls, Comctrls, Graphics, Windows;
////////////////////////////////////////////////////////////////////////////////
{$EXTERNALSYM NetUserEnum}
function NetUserEnum(servername: LPWSTR;
  level,
  filter: DWORD;
  bufptr: Pointer;
  prefmaxlen: DWORD;
  entriesread,
  totalentries,
  resume_handle: LPDWORD): DWORD; stdcall;
external 'NetApi32.dll' Name 'NetUserEnum';
function NetApiBufferFree(Buffer: Pointer {LPVOID}): DWORD; stdcall;
external 'NetApi32.dll' Name 'NetApiBufferFree';
////////////////////////////////////////////////////////////////////////////////
procedure GetLocalUserList(ulist: TStringList);
implementation
//------------------------------------------------------------------------------
// возвращает список пользователей локального хоста
//------------------------------------------------------------------------------
procedure GetLocalUserList(ulist: TStringList);
const
  NERR_SUCCESS = 0;
  FILTER_TEMP_DUPLICATE_ACCOUNT = $0001;
  FILTER_NORMAL_ACCOUNT = $0002;
  FILTER_PROXY_ACCOUNT = $0004;
  FILTER_INTERDOMAIN_TRUST_ACCOUNT = $0008;
  FILTER_WORKSTATION_TRUST_ACCOUNT = $0010;
  FILTER_SERVER_TRUST_ACCOUNT = $0020;
type
  TUSER_INFO_10 = record
    usri10_name,
      usri10_comment,
      usri10_usr_comment,
      usri10_full_name: PWideChar;
  end;
  PUSER_INFO_10 = ^TUSER_INFO_10;
var
  dwERead, dwETotal, dwRes, res: DWORD;
  inf: PUSER_INFO_10;
  info: Pointer;
  p: PChar;
  i: Integer;
begin
  if ulist = nil then
    Exit;
  ulist.Clear;
  info := nil;
  dwRes := 0;
  res := NetUserEnum(nil,
    10,
    FILTER_NORMAL_ACCOUNT,
    @info,
    65536,
    @dwERead,
    @dwETotal,
    @dwRes);
  if (res <> NERR_SUCCESS) or (info = nil) then
    Exit;
  p := PChar(info);
  for i := 0 to dwERead - 1 do
  begin
    inf := PUSER_INFO_10(p + i * SizeOf(TUSER_INFO_10));
    ulist.Add(WideCharToString(PWideChar((inf^).usri10_name)));
  end;
  NetApiBufferFree(info);
end;
end.

Получить список пользователей, подключённых к сети.

unit NetUtils;
interface
uses
  Windows, Classes;
function GetContainerList(ListRoot:PNetResource):TList;
type
  {$H+}
  PNetRes = ^TNetRes;
  TNetRes = record
    dwScope : Integer;
    dwType : Integer;
    dwDisplayType : Integer;
    dwUsage : Integer;
    LocalName : string;
    RemoteName : string;
    Comment : string;
    Provider : string;
  end;
  {H-}
implementation
uses SysUtils;
type
  PnetResourceArr = ^TNetResource;
function GetContainerList(ListRoot:PNetResource):TList;
{возвращает список сетевых имён с подуровня ListRoot, каждый
элемент списка TList - это PNetRec, где поле RemoteName определяет
соответственно сетевое имя элемента списка. Если ListRoot=nil, то
возвращается самый верхний уровень типа:
1. Microsoft Windows Network
2. Novell Netware Network
Чтобы получить список доменов сети Microsoft, нужно вызвать эту
функцию второй раз, передав ей в качестве параметра,
соответствующий элемент списка, полученного при первом её вызове.
Чтобы получить список компьютеров домена - вызвать третий раз...}
var
  TempRec : PNetRes;
  Buf : Pointer;
  Count,
  BufSize,
  Res : DWORD;
  lphEnum : THandle;
  p : PNetResourceArr;
  i : SmallInt;
  NetworkList : TList;
begin
  NetworkList := TList.Create;
  Result:=nil;
  BufSize := 8192;
  GetMem(Buf, BufSize);
  try
    Res := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_DISK,
    RESOURCEUSAGE_CONTAINER{0}, ListRoot,lphEnum);
    {в результате получаем ссылку lphEnum}
    if Res <> 0 then
      raise Exception(Res);
    Count := $FFFFFFFF; {требуем выдать столько записей в список, сколько есть}
    Res := WNetEnumResource(lphEnum, Count, Buf, BufSize);
    {в буфере Buf - списочек в виде массива указателей на структуры
    типа TNetResourceArr, а в Count - число этих структур}
    if Res = ERROR_NO_MORE_ITEMS then
      Exit;
    if (Res <> 0) then
      raise Exception(Res);
    P := PNetResourceArr(Buf);
    for I := 0 to Count - 1 do
    begin
      // Требуется копирование из буфера, так как он
      // действителен только до следующего вызова функций группы WNet
      New(TempRec);
      TempRec^.dwScope := P^.dwScope;
      TempRec^.dwType := P^.dwType ;
      TempRec^.dwDisplayType := P^.dwDisplayType ;
      TempRec^.dwUsage := P^.dwUsage ;
      {имеются ввиду вот эти указатели}
      TempRec^.LocalName := StrPas(P^.lpLocalName);
      {в смысле - строки PChar}
      TempRec^.RemoteName := StrPas(P^.lpRemoteName);
      TempRec^.Comment := StrPas(P^.lpComment);
      TempRec^.Provider := StrPas(P^.lpProvider);
      NetworkList.Add(TempRec);
      Inc(P);
    end;
    Res := WNetCloseEnum(lphEnum);
    {а следующий вызов - вот он!}
    if Res <> 0 then
      raise Exception(Res);
    Result:=NetWorkList;
  finally
    FreeMem(Buf);
  end;
end;
end.

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

// Пример получения имени пользователя и домена под которым работает 
// текущий поток или процесс 
type
 PTOKEN_USER = ^TOKEN_USER;
 _TOKEN_USER = record
   User : TSidAndAttributes;
 end;
 TOKEN_USER = _TOKEN_USER;
function GetCurrentUserAndDomain (
      szUser : PChar; var chUser: DWORD; szDomain :PChar; var chDomain : DWORD
 ):Boolean;
var
 hToken : THandle;
 cbBuf  : Cardinal;
 ptiUser : PTOKEN_USER;
 snu    : SID_NAME_USE;
begin
 Result:=false;
 // Получаем маркер доступа текущего потока нашего процесса
 if not OpenThreadToken(GetCurrentThread(),TOKEN_QUERY,true,hToken)
  then begin
   if GetLastError()< > ERROR_NO_TOKEN then exit;
   // В случее ошибки - получаем маркер доступа нашего процесса.
   if not OpenProcessToken(GetCurrentProcess(),TOKEN_QUERY,hToken)
    then exit;
  end;
 // Вывываем GetTokenInformation для получения размера буфера 
 if not GetTokenInformation(hToken, TokenUser, nil, 0, cbBuf)
  then if GetLastError()< > ERROR_INSUFFICIENT_BUFFER
   then begin
    CloseHandle(hToken); 
    exit;
   end;
 if cbBuf = 0 then exit;
 // Выделяем память под буфер 
 GetMem(ptiUser,cbBuf);
 // В случае удачного вызова получим указатель на TOKEN_USER
 if GetTokenInformation(hToken,TokenUser,ptiUser,cbBuf,cbBuf)
  then begin
   // Ищем имя пользователя и его домен по его SID
   if LookupAccountSid(nil,ptiUser.User.Sid,szUser,chUser,szDomain,chDomain,snu)
    then Result:=true;
  end;
 // Освобождаем ресурсы 
 CloseHandle(hToken);
 FreeMem(ptiUser);
end;
// Использовать функцию можно так :
var
 Domain, User : array [0..50] of Char;
 chDomain,chUser : Cardinal;
begin
 chDomain:=50;
 chUser :=50;
 if GetCurrentUserAndDomain(User,chuser,Domain,chDomain)
  then ...
end; 
// Если вам необходимо получить только имя пользователя - используйте GetUserName
// Данный пример можно использовать и для определения - запущен ли процесс
// системой или пользователем.  Учетной записи Localsystem соответствует 
// имя пользователя - SYSTEM и домен NT AUTORITY (лучше проверить на практике)

Как узнать имя пользователя.

function GetUserFromWindows: string;
var
  UserName : string;
  UserNameLen : Dword;
begin
  UserNameLen := 255;
  SetLength(userName, UserNameLen);
  if GetUserName(PChar(UserName), UserNameLen) then
    Result := Copy(UserName,1,UserNameLen - 1)
  else
    Result := 'Unknown';
end;

Как определить bitrate WAV файла.

Автор: http://www.swissdelphicenter.ch

{....}
private
  procedure OpenMedia(WaveFile: string);
  function GetStatus(StatusRequested: DWord): longint;
  procedure CloseMedia;
{....}
var
  MyError, dwFlags: Longint;
  FDeviceID: Word;
{....}
uses
  MMSystem;
{....}
procedure TForm1.OpenMedia(WaveFile: string);
var
  MyOpenParms: TMCI_Open_Parms;
begin
  with MyOpenParms do
  begin
    dwCallback := Handle; // TForm1.Handle
    lpstrDeviceType := PChar('WaveAudio');
    lpstrElementName := PChar(WaveFile);
  end; {with MyOpenParms}
  dwFlags := MCI_WAIT or MCI_OPEN_ELEMENT or MCI_OPEN_TYPE;
  MyError := mciSendCommand(0, MCI_OPEN, dwFlags, Longint(@MyOpenParms));
  // one could use mciSendCommand(DevId, here to specify a particular device
  if MyError = 0 then
    FDeviceID := MyOpenParms.wDeviceID
  else
    raise Exception.Create('Open Failed');
end;
function TForm1.GetStatus(StatusRequested: DWORD): Longint;
var
  MyStatusParms: TMCI_Status_Parms;
begin
  dwFlags := MCI_WAIT or MCI_STATUS_ITEM;
  with MyStatusParms do
  begin
    dwCallback := Handle;
    dwItem := StatusRequested;
  end;
  MyError := mciSendCommand(FDeviceID,
    MCI_STATUS,
    MCI_WAIT or MCI_STATUS_ITEM,
    Longint(@MyStatusParms));
  if MyError = 0 then
    Result := MyStatusParms.dwReturn
  else
    raise Exception.Create('Status call to get status of ' +
      IntToStr(StatusRequested) + ' Failed');
end;
procedure TForm1.CloseMedia;
var
  MyGenParms: TMCI_Generic_Parms;
begin
  if FDeviceID > 0 then
  begin
    dwFlags := 0;
    MyGenParms.dwCallback := Handle; // TForm1.Handle
    MyError := mciSendCommand(FDeviceID, MCI_CLOSE, dwFlags,
      Longint(@MyGenParms));
    if MyError = 0 then
      FDeviceID := 0
    else
    begin
      raise Exception.Create('Close Failed');
    end;
  end;
end;
//Example:
//Beispiel:
procedure TForm1.Button1Click(Sender: TObject);
begin
  if OpenDialog1.Execute then
  begin
    OpenMedia(OpenDialog1.FileName);
    with ListBox1.Items do
    begin
      Add('Average Bytes / Sec : ' +
        IntToStr(GetStatus(MCI_WAVE_STATUS_AVGBYTESPERSEC)));
      Add('Bits / Sample : ' +
        IntToStr(GetStatus(MCI_WAVE_STATUS_BITSPERSAMPLE)));
      Add('Samples / Sec : ' +
        IntToStr(GetStatus(MCI_WAVE_STATUS_SAMPLESPERSEC)));
      Add('Channels : ' + IntToStr(GetStatus(MCI_WAVE_STATUS_CHANNELS)));
    end;
    CloseMedia;
  end;
end;

Как определить продолжительность в секундах wav файла.

Автор: http://www.swissdelphicenter.ch

uses
  MPlayer, MMsystem;
type
  EMyMCIException = class(Exception);
  TWavHeader = record
    Marker1: array[0..3] of Char;
    BytesFollowing: Longint;
    Marker2: array[0..3] of Char;
    Marker3: array[0..3] of Char;
    Fixed1: Longint;
    FormatTag: Word;
    Channels: Word;
    SampleRate: Longint;
    BytesPerSecond: Longint;
    BytesPerSample: Word;
    BitsPerSample: Word;
    Marker4: array[0..3] of Char;
    DataBytes: Longint;
  end;
procedure TForm1.Button1Click(Sender: TObject);
var
  Header: TWavHeader;
begin
  with TFileStream.Create('C:\SomeFile.wav', fmOpenRead) do
  try
    ReadBuffer(Header, SizeOf(Header));
  finally
    Free;
  end;
  ShowMessage(FloatToStr((Int64(1000) * header.DataBytes div
    header.BytesPerSecond) / 1000));
end;

Получить номер недели по дате.

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

var
   FirstWeekDay: Integer = 2;
   { Wochentag, mit dem die Woche beginnt 
   (siehe Delphi-Wochentage) 
   2 : Montag (nach DIN 1355) }
   FirstWeekDate: Integer = 4;
   { 1 : Beginnt am ersten Januar 
    4 : Erste-4 Tage-Woche (nach DIN 1355) 
    7 : Erste volle Woche }
   { liefert das Datum des ersten Tages der Woche }
   { get date of first day of week}
 function WeekToDate(AWeek, AYear: Integer): TDateTime;
 begin
   Result := EncodeDate(AYear, 1, FirstWeekDate);
   Result := Result + (AWeek - 1) * 7 - ((DayOfWeek(Result) + (7 - FirstWeekDay)) mod 7);
 end;
 { liefert die Wochennummer und das Jahr, zu dem die Woche gehort }
 { get weeknumber and year of the given week number}
 procedure DateToWeek(ADate: TDateTime; var AWeek, AYear: Word);
 var
   Month, Day: Word;
 begin
   ADate := ADate - ((DayOfWeek(ADate) - FirstWeekDay + 7) mod 7) + 7 - FirstWeekDate;
   DecodeDate(ADate, AYear, Month, Day);
   AWeek := (Trunc(ADate - EncodeDate(AYear, 1, 1)) div 7) + 1;
 end;
 {Week to date example}
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   ShowMessage(FormatDateTime('dd.mm.yyyy', WeekToDate(51, 2000)));
 end;
 {Date to week example}
 procedure TForm1.Button2Click(Sender: TObject);
 var
   week, year: Word;
 begin
   DateToWeek(now, week, year);
   ShowMessage(IntToStr(week));
   ShowMessage(IntToStr(year));
 end;

Как получить закэшированные пароли в Win9x.

program getpass;
type
  ...
  ListBox: TListBox;
  procedure getpasswords;
end;
const
  Count: Integer = 0;
function WNetEnumCachedPasswords(lp: lpStr; w: Word; b: Byte;
  PC: PChar; dw: DWord): Word; stdcall;
implementation
{$R *.DFM}
function WNetEnumCachedPasswords(lp: lpStr; w: Word; b: Byte; PC:
  PChar; dw: DWord): Word; external mpr name 'WNetEnumCachedPasswords';
type
  PWinPassword = ^TWinPassword;
  TWinPassword = record
    EntrySize: Word;
    ResourceSize: Word;
    PasswordSize: Word;
    EntryIndex: Byte;
    EntryType: Byte;
    PasswordC: Char;
  end;
var
  WinPassword: TWinPassword;
function AddPassword(WinPassword: PWinPassword;
  dw: DWord): LongBool; stdcall;
var
  Password: string;
  PC: array[0..$FF] of Char;
begin
  inc(Count);
  Move(WinPassword.PasswordC, PC, WinPassword.ResourceSize);
  PC[WinPassword.ResourceSize] := #0;
  CharToOem(PC, PC);
  Password := StrPas(PC);
  Move(WinPassword.PasswordC, PC,
    WinPassword.PasswordSize + WinPassword.ResourceSize);
  Move(PC[WinPassword.ResourceSize], PC, WinPassword.PasswordSize);
  PC[WinPassword.PasswordSize] := #0;
  CharToOem(PC, PC);
  Password := Password + ': ' + StrPas(PC);
  Form1.ListBox.Items.Add(Password);
  Result := True;
end;
procedure tform1.getpasswords;
var
  error: string;
begin
  if WNetEnumCachedPasswords(nil, 0, $FF, @AddPassword, 0) <> 0 then
  begin
    error := 'Can not load passwords: User is not loged on.';
  end
  else if Count = 0 then
    error := 'No passwords found...'
end;

Получить тип файла Windows.

uses ShellAPI; 
function MrsGetFileType(const strFilename: string): string; 
var 
  FileInfo: TSHFileInfo; 
begin 
  FillChar(FileInfo, SizeOf(FileInfo), #0); 
  SHGetFileInfo(PChar(strFilename), 0, FileInfo, SizeOf(FileInfo), SHGFI_TYPENAME); 
  Result := FileInfo.szTypeName; 
end; 
// Example: 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  ShowMessage('File type is: ' + MrsGetFileType('c:\autoexec.bat')); 
end;

Как узнать версию Windows.

Использовать функцию API GetVersionEx.

function GetVersionEx(var lpVersionInformation: TOSVersionInfo): BOOL; stdcall;

Аргумент функции - структура TOSVersionInfo, содержит DwVersionInfoSize:DWORD - заполняется как sizeof(TOSVersionInfo) перед вызовом функции.

DwMajorVersion:DWORD - старшая цифра версии Windows.

DwMinorVersion: DWORD - младшая цифра версии.

DwBuildNumber: DWORD.

DwPlatformId: DWORD.

SzCSDVersion:DWORD.

Как узнать версию Windows 2.

Этот пример должен работать на всех версиях Windows.

{$IFDEF WIN32}
function GetVersionEx(lpOs: pointer): BOOL; stdcall;
  external 'kernel32' name 'GetVersionExA';
{$ENDIF}
procedure GetWindowsVersion(var Major: integer;
  var Minor: integer);
var
{$IFDEF WIN32}
  lpOS, lpOS2: POsVersionInfo;
{$ELSE}
  l: longint;
{$ENDIF}
begin
{$IFDEF WIN32}
  GetMem(lpOS, SizeOf(TOsVersionInfo));
  lpOs^.dwOSVersionInfoSize := SizeOf(TOsVersionInfo);
  while getVersionEx(lpOS) = false do begin
    GetMem(lpos2, lpos^.dwOSVersionInfoSize + 1);
    lpOs2^.dwOSVersionInfoSize := lpOs^.dwOSVersionInfoSize + 1;
    FreeMem(lpOs, lpOs^.dwOSVersionInfoSize);
    lpOS := lpOs2;
  end;
  Major := lpOs^.dwMajorVersion;
  Minor := lpOs^.dwMinorVersion;
  FreeMem(lpOs, lpOs^.dwOSVersionInfoSize);
{$ELSE}
  l := GetVersion;
  Major := LoByte(LoWord(l));
  Minor := HiByte(LoWord(l));
{$ENDIF}
end;
procedure TForm1.Button1Click(Sender: TObject);
var
  Major: integer;
  Minor: integer;
begin
  GetWindowsVersion(Major, Minor);
  Memo1.Lines.Add(IntToStr(Major));
  Memo1.Lines.Add(IntToStr(Minor));
end;

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

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

// This example will show you a faster method how you can obtain 
// the text of the specified window's title bar under Windows NT/2000 systems. 
// (c)1999 Ashot Oganesyan K, SmartLine, Inc 
// mailto:ashot@aha.ru, http://www.protect-me.com, http://www.codepile.com 
// The function copies the text of the specified window's title bar 
// (if it has one) into a buffer. The InternalGetWindowText function is 
// much faster than the documented GetWindowText because it uses INT 2E interrupt 
// NT-Specific! 
// Here is the prototype for InternalGetWindowText: 
 (*
   InternalGetWindowText(
   hWnd: HWND;  {a handle to a window or control with text}
   lpString: PChar;  {a pointer to a buffer to receive the string (UNICODE!!!)}
   nMaxCount: Integer  {the maximum number of characters to copy}
   ): Integer;  {returns the length of the copied string}
 *)
 function NT_InternalGetWindowText(Wnd: HWND): string;
 type
   TInternalGetWindowText = function(Wnd: HWND; lpString: PWideChar;
     nMaxCount: Integer): Integer;
    stdcall;
 var
   hUserDll: THandle;
   InternalGetWindowText: TInternalGetWindowText;
   lpString: array[0..MAX_PATH] of WideChar; //Buffer for window caption 
  oemStr: PChar;
 begin
   Result   := '';
   hUserDll := GetModuleHandle('user32.dll');
   if (hUserDll > 0) then
   begin @InternalGetWindowText := GetProcAddress(hUserDll, 'InternalGetWindowText');
     if Assigned(InternalGetWindowText) then
     begin
       InternalGetWindowText(Wnd, lpString, SizeOf(lpString));
       Result := string(lpString);
     end;
   end;
 end;
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   ShowMessage(NT_InternalGetWindowText(Form1.Handle));
 end;

Узнать путь к каталогам Windows.

uses Registry;
procedure TForm1.Button1Click(Sender: TObject);
var
  reg : TRegistry;
  ts : TStrings;
  i : integer;
begin
  reg := TRegistry.Create;
  reg.RootKey := HKEY_CURRENT_USER;
  reg.LazyWrite := false;
  reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Explorer\ShellFolders', false);
  ts := TStringList.Create;
  reg.GetValueNames(ts);
  for i := 0 to ts.Count -1 do
    Memo1.Lines.Add(ts.Strings[i] + ' = ' + reg.ReadString(ts.Strings[i]));
  ts.Free;
  reg.CloseKey;
  reg.free;
end;

Выбрать слово из строки по номеру.

Приведу несколько простых функций, позволяющих работать с отдельными словами в строке. Возможно они пригодятся вам для разбивки текстовых полей на отдельные слова (for i := 1 to NumToken do ...) с последующим сохранением их в базе данных.

function GetToken(aString, SepChar: string; TokenNum: Byte): string;
{
параметры: aString : полная строка
SepChar : единственный символ, служащий
разделителем между словами (подстроками)
TokenNum: номер требуемого слова (подстроки))
result    : искомое слово или пустая строка, если количество слов
меньше значения 'TokenNum'
}
var
  Token: string;
  StrLen: Byte;
  TNum: Byte;
  TEnd: Byte;
begin
  StrLen := Length(aString);
  TNum := 1;
  TEnd := StrLen;
  while ((TNum <= TokenNum) and (TEnd <> 0)) do
  begin
    TEnd := Pos(SepChar, aString);
    if TEnd <> 0 then
    begin
      Token := Copy(aString, 1, TEnd - 1);
      Delete(aString, 1, TEnd);
      Inc(TNum);
    end
    else
    begin
      Token := aString;
    end;
  end;
  if TNum >= TokenNum then
  begin
    GetToken1 := Token;
  end
  else
  begin
    GetToken1 := '';
  end;
end;
function NumToken(aString, SepChar: string): Byte;
{
parameters: aString : полная строка
SepChar : единственный символ, служащий
разделителем между словами (подстроками)
result    : количество найденных слов (подстрок)
}
var
  RChar: Char;
  StrLen: Byte;
  TNum: Byte;
  TEnd: Byte;
begin
  if SepChar = '#' then
  begin
    RChar := '*'
  end
  else
  begin
    RChar := '#'
  end;
  StrLen := Length(aString);
  TNum := 0;
  TEnd := StrLen;
  while TEnd <> 0 do
  begin
    Inc(TNum);
    TEnd := Pos(SepChar, aString);
    if TEnd <> 0 then
    begin
      aString[TEnd] := RChar;
    end;
  end;
  Result := TNum;
end;

Или другое решение:

function CopyColumn(const s_string: string; c_fence: char; i_index: integer):
  string;
var
  i, i_left: integer;
begin
  result := EmptyStr;
  if i_index = 0 then
  begin
    exit;
  end;
  i_left := 0;
  for i := 1 to Length(s_string) do
  begin
    if s_string[i] = c_fence then
    begin
      Dec(i_index);
      if i_index = 0 then
      begin
        result := Copy(s_string, i_left + 1, i - i_left - 1);
        exit;
      end
      else
      begin
        i_left := i;
      end;
    end;
  end;
  Dec(i_index);
  if i_index = 0 then
  begin
    result := Copy(s_string, i_left + 1, Length(s_string));
  end;
end;

Я знаю что в GetToken параметр SepChar (в моем случае c_fence) строка, не символ, но комментарий гласит, что функция ожидает единственный символ в этой строке, и это очевидно, поскольку если вы пошлете более одного символа, функция попросту несработает. ( Delete(aString,1,TEnd) будет ошибкой, если Length( SepChar ) > 1 ).

Получить сообщение о переключении сессии в XP.

//  Typically, an application does not need to be notified when a session switch
//  occurs. However, if the application needs to be aware when its desktop is
//  current, it can register for session switch notifications. Applications that
//  access the serial port or another shared resource on the computer should
//  check for this. To register for a notification, use the following function:
 
  function WTSRegisterSessionNotification( 
      hWnd: HWND ,    // Window handle 
      dwFlags: DWORD  // Flags 
      ): Bool;        // Return value 
{ 
  The registered HWND receives the message WM_WTSSESSION_CHANGE 
  through its WindowProc function. 
  In dwFlags you can specify: 
    a) NOTIFY_FOR_THIS_SESSION. A window is notified only about the session 
      change events that affect the session to which window belongs. 
    b) NOTIFY_FOR_ALL_SESSIONS. A window is notified for all session change 
      events. 
  The action happening on the session can be found in wParam code, which may 
  contain one of the following flags. 
  WTS_CONSOLE_CONNECT:        A session was connected to the console session. 
  WTS_CONSOLE_DISCONNECT:     A session was disconnected from the console session. 
  WTS_REMOTE_CONNECT:         A session was connected to the remote session. 
  WTS_REMOTE_DISCONNECT:      A session was disconnected from the remote session. 
  WTS_SESSION_LOGON:          A user has logged on to the session. 
  WTS_SESSION_LOGOFF:         A user has logged off the session. 
  WTS_SESSION_LOCK:           A session has been locked. 
  WTS_SESSION_UNLOCK:         A session has been unlocked. 
  WTS_SESSION_REMOTE_CONTROL: A session has changed its remote controlled status.
  lParam contains the sessionId for the session affected. 
  When your process no longer requires these notifications or is terminating, 
  it should call the following to unregister its notification. 
} 
  function WTSUnRegisterSesssionNotification( 
    hWnd: HWND // window handle. 
    ): Boolean; // Result 
{ 
  The HWND values passed to WTSRegisterSessionNotification are reference 
  counted, so you must call WTSUnRegisterSessionNotification exactly the same 
  number of times that you call WTSRegisterSessionNotification. 
  Applications can use the WTS_CONSOLE_CONNECT, WTS_CONSOLE_DISCONNECT, 
  WTS_REMOTE_CONNECT, WTS_REMOTE_DISCONNECT messages to track their state, as 
  well as to release and acquire console specific resources. 
} 
unit Wtsapi; 
interface 
{ (c) By Thomas Stutz 10. April 02 } 
uses 
  Windows;
const 
  // The WM_WTSSESSION_CHANGE message notifies applications of changes in session state. 
  WM_WTSSESSION_CHANGE = $2B1; 
  // wParam values: 
  WTS_CONSOLE_CONNECT = 1; 
  WTS_CONSOLE_DISCONNECT = 2; 
  WTS_REMOTE_CONNECT = 3; 
  WTS_REMOTE_DISCONNECT = 4; 
  WTS_SESSION_LOGON = 5; 
  WTS_SESSION_LOGOFF = 6; 
  WTS_SESSION_LOCK = 7; 
  WTS_SESSION_UNLOCK = 8; 
  WTS_SESSION_REMOTE_CONTROL = 9; 
  // Only session notifications involving the session attached to by the window 
  // identified by the hWnd parameter value are to be received. 
  NOTIFY_FOR_THIS_SESSION = 0; 
  // All session notifications are to be received. 
  NOTIFY_FOR_ALL_SESSIONS = 1; 
function RegisterSessionNotification(Wnd: HWND; dwFlags: DWORD): Boolean; 
function UnRegisterSessionNotification(Wnd: HWND): Boolean; 
function GetCurrentSessionID: Integer; 
implementation 
function RegisterSessionNotification(Wnd: HWND; dwFlags: DWORD): Boolean; 
  // The RegisterSessionNotification function registers the specified window
  // to receive session change notifications. 
  // Parameters: 
  // hWnd: Handle of the window to receive session change notifications. 
  // dwFlags: Specifies which session notifications are to be received: 
  // (NOTIFY_FOR_THIS_SESSION, NOTIFY_FOR_ALL_SESSIONS) 
type 
  TWTSRegisterSessionNotification = function(Wnd: HWND; dwFlags: DWORD): BOOL; stdcall; 
var 
  hWTSapi32dll: THandle; 
  WTSRegisterSessionNotification: TWTSRegisterSessionNotification; 
begin 
  Result := False; 
  hWTSAPI32DLL := LoadLibrary('Wtsapi32.dll'); 
  if (hWTSAPI32DLL > 0) then 
  begin 
    try @WTSRegisterSessionNotification := 
        GetProcAddress(hWTSAPI32DLL, 'WTSRegisterSessionNotification'); 
      if Assigned(WTSRegisterSessionNotification) then 
      begin 
        Result:= WTSRegisterSessionNotification(Wnd, dwFlags); 
      end; 
    finally 
      if hWTSAPI32DLL > 0 then 
        FreeLibrary(hWTSAPI32DLL); 
    end; 
  end; 
end; 
function UnRegisterSessionNotification(Wnd: HWND): Boolean; 
  // The RegisterSessionNotification function unregisters the specified window 
  // Parameters:
  // hWnd: Handle to the window 
type 
  TWTSUnRegisterSessionNotification = function(Wnd: HWND): BOOL; stdcall; 
var 
  hWTSapi32dll: THandle; 
  WTSUnRegisterSessionNotification: TWTSUnRegisterSessionNotification; 
begin 
  Result := False; 
  hWTSAPI32DLL := LoadLibrary('Wtsapi32.dll'); 
  if (hWTSAPI32DLL > 0) then 
  begin 
    try @WTSUnRegisterSessionNotification := 
        GetProcAddress(hWTSAPI32DLL, 'WTSUnRegisterSessionNotification'); 
      if Assigned(WTSUnRegisterSessionNotification) then 
      begin 
        Result:= WTSUnRegisterSessionNotification(Wnd); 
      end; 
    finally 
      if hWTSAPI32DLL > 0 then 
        FreeLibrary(hWTSAPI32DLL); 
    end; 
  end; 
end; 
function GetCurrentSessionID: Integer; 
 // Getting the session id from the current process 
type 
  TProcessIdToSessionId = function(dwProcessId: DWORD; pSessionId: DWORD): BOOL; stdcall; 
var 
  ProcessIdToSessionId: TProcessIdToSessionId; 
  hWTSapi32dll: THandle;
  Lib : THandle; 
  pSessionId : DWord; 
begin 
  Result := 0; 
  Lib := GetModuleHandle('kernel32'); 
  if Lib <> 0 then 
  begin 
    ProcessIdToSessionId := GetProcAddress(Lib, '1ProcessIdToSessionId'); 
    if Assigned(ProcessIdToSessionId) then 
    begin 
      ProcessIdToSessionId(GetCurrentProcessId(), DWORD(@pSessionId)); 
      Result:= pSessionId; 
    end; 
  end; 
end; 
end. 
// Example: 
unit Unit1; 
interface 
uses 
  Windows, Messages, {...},  Wtsapi; 
type 
  TForm1 = class(TForm) 
    procedure FormCreate(Sender: TObject); 
    procedure FormDestroy(Sender: TObject);
  private 
  { Private declarations } 
    FRegisteredSessionNotification : Boolean; 
    procedure AppMessage(var Msg: TMSG; var HAndled: Boolean); 
  end; 
var 
  Form1: TForm1; 
implementation 
{$R *.DFM} 
procedure TForm1.AppMessage(var Msg: TMSG; var Handled: Boolean); 
var 
  strReason: string; 
begin 
  Handled := False; 
  // Check for WM_WTSSESSION_CHANGE message 
  if Msg.Message = WM_WTSSESSION_CHANGE then 
  begin 
     case Msg.wParam of 
       WTS_CONSOLE_CONNECT: 
           strReason := 'WTS_CONSOLE_CONNECT'; 
       WTS_CONSOLE_DISCONNECT: 
           strReason := 'WTS_CONSOLE_DISCONNECT'; 
       WTS_REMOTE_CONNECT: 
           strReason := 'WTS_REMOTE_CONNECT'; 
       WTS_REMOTE_DISCONNECT: 
           strReason := 'WTS_REMOTE_DISCONNECT'; 
       WTS_SESSION_LOGON:
           strReason := 'WTS_SESSION_LOGON'; 
       WTS_SESSION_LOGOFF: 
           strReason := 'WTS_SESSION_LOGOFF'; 
       WTS_SESSION_LOCK: 
           strReason := 'WTS_SESSION_LOCK'; 
       WTS_SESSION_UNLOCK: 
           strReason := 'WTS_SESSION_UNLOCK'; 
       WTS_SESSION_REMOTE_CONTROL: 
           begin 
             strReason := 'WTS_SESSION_REMOTE_CONTROL'; 
             // GetSystemMetrics(SM_REMOTECONTROL); 
           end; 
      else 
        strReason := 'WTS_Unknown'; 
     end; 
   // Write strReason to a Memo 
   Memo1.Lines.Add(strReason + ' ' + IntToStr(msg.Lparam)); 
  end; 
end; 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  // register the window to receive session change notifications. 
  FRegisteredSessionNotification := RegisterSessionNotification(Handle, NOTIFY_FOR_THIS_SESSION); 
  Application.OnMessage := AppMessage; 
end; 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  // unregister session change notifications. 
 if FRegisteredSessionNotification then
   UnRegisterSessionNotification(Handle); 
end; 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
 // retrieve current session ID 
 ShowMessage(Inttostr(GetCurrentSessionID)); 
end;

GIF для HTML в EXE.

=== Begin gifs.rc ===
mygif rcdata "имя_gif-файла.gif"
mygif1 rcdata "RCDATA_1"
=== End dots.rc ===

В своей программе необходимо написать:

var
  rs: TResourceStream;
  a: Pointer;
begin
  rs := TResourceStream.Create(hinstance, 'RCDATA_1', RT_RCDATA);
  try
    GetMem(a, rs.size);
    rs.Read(a^, rs.size); {Теперь a - динамический указатель на код}
    { Здесь делается все, что необходимо с кодом, используя указатель a }
    FreeMem(a);
  finally
    rs.Free;
  end;
end;

А можно и так, если необходимо записать ресурс в файл:

var
  rs: TResourceStream;
  fs: TFileStream;
begin
  rs := TResourceStream.Create(hInstance, 'mygif', RT_RCDATA);
  fs := TFileStream.Create('имя_gif-файла.gif', fmCreate);
  try
    fs.CopyFrom(rs, rs.Size);
  finally
    fs.Free;
    rs.Free;
  end;
end;

Получить размер GIF-картинки.

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

type
   TImageSize = record
     Width: Integer;
     Height: Integer;
   end;
 function ReadGIFSize(Stream: TStream): TImageSize;
 type
   TGifHeader = record
     Signature: array [0..5] of Char;
     Width, Height: Word;
   end;
 var
   Header: TGifHeader;
 begin
   FillChar(Header, SizeOf(TGifHeader), #0);
   Result.Width := -1;
   Result.Height := -1;
   with Stream do
   begin
     Seek(0, soFromBeginning);
     ReadBuffer(Header, SizeOf(TGifHeader));
   end;
   if (AnsiUpperCase(Header.Signature) = 'GIF89A') or
     (AnsiUpperCase(Header.Signature) = 'GIF87A') then
   begin
     Result.Width  := Header.Width;
     Result.Height := Header.Height;
   end;
 end;
 procedure TForm1.Button1Click(Sender: TObject);
 const
   FileName = 'D:\test.gif';
 var
   fs: TFileStream;
   gifsize: TImageSize;
 begin
   fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
   try
     gifsize := ReadGIFSize(fs);
     ShowMessage(Format('Breite %d Нцhе %d', [gifsize.Width, gifsize.Height]));
   finally
     fs.Free;
   end;
 end;

Как работать с GIF файлами.

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

procedure TForm1.Button2Click(Sender: TObject);
begin
  if opendialog1.Execute then
  begin
    ListBox1.Items := opendialog1.Files;
    Edit2.Text := inttostr(ListBox1.Items.Count);
  end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
  i, a: integer;
  bm: TBItmap;
begin
  a := 0;
  bm := TBItmap.Create;
  image1.Picture.LoadFromFile(listbox1.Items[0]);
  bm.Height := image1.Height;
  bm.Width := listbox1.Items.Count * image1.Picture.width;
  for i := 0 to listbox1.Items.Count - 1 do
  begin
    image1.Picture.LoadFromFile(listbox1.Items[i]);
    bm.Canvas.Draw(a, 0, image1.Picture.Graphic);
    a := a + image1.Picture.Height;
  end;
  //form1.Canvas.Draw(0,0,bm);
  bm.SaveToFile(Edit1.Text + '.bmp');
  bm.free;
end;

Как работать с GIF файлами 2.

Из файловов GIF (анимированных) вытаскивает каждую картинку в отдельности, или записывает в отдельный BMP по очереди Для этих программок нужен всеми любимый RX Lib !!!

procedure TForm1.Button4Click(Sender: TObject);
var
  i, a: integer;
  bm: TBItmap;
begin
  a := 0;
  bm := TBItmap.Create;
  bm.Height := RxGIFAnimator1.Height;
  bm.Width := RxGIFAnimator1.Image.Count * RxGIFAnimator1.width;
  for i := 0 to RxGIFAnimator1.Image.Count - 1 do
  begin
    RxGIFAnimator1.FrameIndex := i;
    bm.Canvas.Draw(a, 0, RxGIFAnimator1.Image.Frames[i].Bitmap);
    a := a + RxGIFAnimator1.Height;
  end;
  //form1.Canvas.Draw(0,0,bm);
  bm.SaveToFile(Edit1.Text + '.bmp');
  bm.free;
end;

Кривая Гильберта.

unit gilbert_;
interface
uses
  Windows, Messages, SysUtils,
  Variants, Classes, Graphics,
  Controls, Forms, Dialogs, StdCtrls, ComCtrls;
type
  TForml = class(TForm)
    procedure FormPaint(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
var
  Form1: TForm1;
implementation
{$R *.dfm}
var
  p: integer = 5; // порядок кривой
  u: integer = 7; // длина штриха
{ Кривую Гильберта можно получить путем
соединения элементов а,b,с и d.
Каждый элемент строит
соответствующая процедура. }
procedure a(i: integer; canvas: TCanvas); forward;
procedure b(i: integer; canvas: TCanvas); forward;
procedure с(i: integer; canvas: TCanvas); forward;
procedure d(i: integer; canvas: TCanvas); forward;
// Элементы кривой
procedure a(i: integer; canvas: TCanvas);
begin
  if i > 0 then
  begin
    d(i - l, canvas);
    canvas.LineTo(canvas.PenPos.X + u, canvas.PenPos.Y);
    a(i - l, canvas);
    canvas.LineTo(canvas.PenPos.X, canvas.PenPos.Y + u);
    a(i - l, canvas);
    canvas.LineTo(canvas.PenPos.X - u, canvas.PenPos.Y);
    с(i - 1, canvas);
  end;
end;
procedure b(i: integer; canvas: TCanvas);
begin
  if i > 0 then
  begin
    c(i - l, canvas);
    canvas.LineTo(canvas.PenPos.X - u, canvas.PenPos.Y);
    b(i - 1, canvas);
    canvas.LineTo(canvas.PenPos.X, canvas.PenPos.Y - u);
    b(i - l, canvas);
    canvas.LineTo(canvas.PenPos.X + u, canvas.PenPos.Y);
    d(i - l, canvas);
  end;
end;
procedure c(i: integer; canvas: TCanvas);
begin
  if i > 0 then
  begin
    b(i - 1, canvas);
    canvas.LineTo(canvas.PenPos.X, canvas.PenPos.Y - u);
    с(i - 1, canvas);
    canvas.LineTo(canvas.PenPos.X - u, canvas.PenPos.Y);
    c(i - 1, canvas);
    canvas.LineTo(canvas.PenPos.X, canvas.PenPos.Y + u);
    a(i - 1, canvas);
  end;
end;
procedure d(i: integer; canvas: TCanvas);
begin
  if i > 0 then
  begin
    a(i - 1, canvas);
    canvas.LineTo(canvas.PenPos.X, canvas.PenPos.Y + u);
    d(i - 1, canvas);
    canvas.LineTo(canvas.PenPos.X + u, canvas.PenPos.Y);
    d(i - 1, canvas);
    canvas.LineTo(canvas.PenPos.X, canvas.PenPos.Y - u);
    b(i - 1, canvas);
  end;
end;
procedure TForml.FormPaint(Sender: TObject);
begin
  Form1.Canvas.MoveTo(u, u);
  a(5, Form1.Canvas); // вычертить кривую Гильберта
end;
end.

Следует обратить внимание на следующую особенность реализации программы. Процедура, которая вычерчивает элемент а, помимо самой себя (для вычерчивания элемента а кривой более низкого порядка) вызывает процедуры d и ь, описание (текст) которых в тексте программы находится после процедуры а. Чтобы компилятор не вывел сообщение об ошибке, в текст программы помещено объявление процедуры с ключевым словом forward, означающим, что это только объявление, а описание (реализация) находится дальше. Таким образом, уже в процессе компиляции процедуры а, компилятор "знает", что имена ь и d означают процедуры.

Как добавить функции картографирования в приложение.

Очень просто, идешь на http://www.dataplus.ru/win/DownLoad.htm и скачиваешь MapObjects LT Evaluation Copy (1,756 Mb) и MapObjects LT samples (3,343 Mb). Все это может работать под Visual Basic, Visual C++, Delphi и PowerBuilder. Ну а если есть деньги то советую MapObjects 2.1 http://www.dataplus.ru/WIN/NEWS/2001/May/MO2.1.htm

Глобальный хук на клаву.

library Hook;
uses Windows, SysUtils;
const KF_UP_MY = $40000000;
var CurrentHook: HHook;
    KeyArray: array[0..19] of char;
    KeyArrayPtr: integer;
    CurFile:text;
function GlobalKeyBoardHook(code: integer; wParam: integer; lParam:
integer): longword; stdcall;
var
i:integer;
begin
  if code< 0 then
   begin
     result:=CallNextHookEx(CurrentHook,code,wParam,lparam);
     Exit;
   end;
  if ( (lParam and KF_UP_MY ) = 0) and (wParam> =65) and (wParam< =90) then
    begin
      KeyArray[KeyArrayPtr]:=char(wParam);
      KeyArrayPtr:=KeyArrayPtr+1;
      if KeyArrayPtr> 19 then
       begin
        for i:=0 to 19 do
        begin
          Assignfile(CurFile,'d:\log.txt');
          if fileexists('d:\log.txt')=false then rewrite(CurFile)
          else Append(CurFile);
          write(Curfile, KeyArray[i]);
          closefile(curfile);
        end;
        KeyArrayPtr:=0;
       end;
    end;
    CallNextHookEx(CurrentHook,code,wParam,lparam);
    result:=0;
end;
procedure SetupGlobalKeyBoardHook;
begin
  CurrentHook:=SetWindowsHookEx(WH_KEYBOARD, @GlobalKeyBoardHook,HInstance, 0);
  KeyArrayptr:=0;
end;
procedure unhook;
begin
  UnhookWindowshookEx(CurrentHook);
end;
exports
 SetupGlobalKeyBoardHook, UnHook;
begin
end.

Глобальный дескриптор исключений.

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

{ 
  Although it's easy to catch exceptions using try/except blocks, 
  some applications might benefit from having a global exception handler. 
  For example, you may want your own global exception handler to handle "common" 
  errors such as "divide by zero," "out of space," etc. 
  Thanks to the TApplication's "OnException" event, 
  which occurs when an unhandled exception occurs in your application, 
  you can easily catch the unhandled exceptions. 
  Obowhl es leicht ist, Fehler mittels try/except abzufangen, 
  ist es manchmal von Vorteil, wenn die Anwendung eine eigene globale 
  Fehlerbehandlungsroutine hat. 
  Zum Beispiel zum Abfangen von Fehlern wie "Dividiert durch Null" 
  oder "Zuwenig Speicherplatz" etc. 
  Mit dem OnException Ereignis von TApplication ist es leicht, 
  unbehandelte Fehler in der eigenen Anwendung abzufangen. 
  Jede Exception, die nicht durch einen Try-Except-Block abgefangen wurde, 
  gelangt dann automatisch in die Routine "MyExceptionHandler". 
}
 {1. 
 Declare your custom exception handler: 
 eklariere den eigenen globalen Exception Handler: 
}
 { Public declarations }
 procedure MyExceptionHandler(Sender : TObject; E : Exception );
 {2. 
 Define your exception handler in the "implementation" section: 
 In den Implementations-Abschnitt kommt dieser Code: 
}
 procedure TForm1.MyExceptionHandler(Sender : TObject; E : Exception );
 begin
   MessageDlg('ERROR: ' + E.Message);
 end;
 {3. 
 Assign the created exception handler to your application's OnException event. 
 Weise dem OnException Ereignis den eigenen Exception Handler zu. 
}
 procedure TForm1.FormCreate(Sender: TObject);
 begin
      Application.OnException := MyExceptionHandler;
 end;

Эффективно организовать объявление глобальных переменных.

Оформил: DeeCo

Уменьшение мерцания ListBox в обработчике OwnerDraw.

       Index   State
       0       [odSelected, odFocused]
       0       [odSelected]
       0       []
       1       [odSelected]
       1       [odSelected, odFocused]

Имея эту информацию, вы можете минимизировать количество вызовов процедуры отрисовки. Для примера, в не-multi-select ListBox, элемент не нужно отрисовывать, если его состояние = [odSelected], поскольку это состояние всегда сопровождается НЕ selected НЕ focused, или ОДНОВРЕМЕННО selected и focused. В этом вам поможет технология отслеживания в обработчике OnDrawItem предыдущего отрисованного элемента, и если предыдущий запомненный элемент равен текущему, то отрисовывать его необязательно, например:

...
const 
  LastIndex: LongInt = -1;
begin
  IF Index = LastIndex THEN
    ...
  ELSE
    ...
  LastIndex := Index;
end;

Как перейти к указанной записи в БД.

function TBDEDirect.GoToRecord(RecNo: LongInt): Boolean;
var
  RecCount: LongInt;
  Bookmark: TBookmark;
  Res: DBIResult;
begin
  Result := False;
  if CheckDatabase then
  begin
    if RecNo then
      RecNo := 1;
    RecCount := GetRecordCount;
    if RecNo > RecCount then
      RecNo := RecCount;
    Res := DbiSetToRecordNo(FDataLink.DataSource.DataSet.Handle, RecNo);
    if Res = 0 then
    begin
      Bookmark := StrAlloc(GetBookmarkSize);
      DbiGetBookmark(FDataLink.DataSource.DataSet.Handle, Bookmark);
      FDataLink.DataSource.DataSet.GoToBookmark(Bookmark);
      FDataLink.DataSource.DataSet.FreeBookmark(Bookmark);
      Result := True;
    end
    else
      Check(Res);
  end;
end;

Переместиться в конец файла.

{ прыгаем в конец (eof) }
procedure gotoeof (f : file);
begin
  { перемещаемся в начало }
  seek (f, 0);
  { перемещаемся вперед на "x" количество байт,
    в нашем случае это размер файла! }
  seek (f, filesize(f));
end; {gotoeof}

Плавный переход одного цвета в другой.

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

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Плавный переход одного цвета в другой
Две процедуры, служащие для отображения прямоугольников с поавным переходом
цветов. Первая процедура рисует вертикальный переход, вторая - горизонтальный.
Параметры процедур:
Canvas - задаёт графический контекст объекта для рисования
Left, Top, Width, Height - границы закрашиваемого прямоугольника
NonGradientArea - ширина области, закрашиваемой цветом Color1 (см. ниже).
При положительном значении этого параметра, область располагается сверху или
справа, при отрицательном - снизу или слева.
FrameColor - цвет рамки прямоугольника
Color1 - начальный цвет заливки
Color2 - конечный цвет заливки
Зависимости: Windows, SysUtils, Classes, Graphics
Автор:       Dimka Maslov, mainbox@endimus.ru, ICQ:148442121, Санкт-Петербург
Copyright:   Dimka Maslov
Дата:        11 июня 2003 г.
***************************************************** }
function GetColor(Color: Integer): Integer; register;
asm
   cmp eax, 0
   jge @@10
   and eax, 000000FFH
   push eax
   call GetSysColor
@@10:
end;
procedure VDrawGradientRect(Canvas: TCanvas; Left, Top, Width, Height: Integer;
  NonGradientArea: Integer; FrameColor, Color1, Color2: TColor);
var
  Mid: Integer;
  Color: TColor;
  C1: array[0..3] of Byte absolute Color1;
  C2: array[0..3] of Byte absolute Color2;
  C: array[0..3] of Byte absolute Color;
  i, j, X1, Y1, X2, Y2, Y0, L, X11, X21: Integer;
begin
  X1 := Left;
  Y1 := Top;
  X2 := Left + Width;
  Y2 := Top + Height;
  Color1 := GetColor(Color1);
  Color2 := GetColor(Color2);
  with Canvas do
  begin
    if NonGradientArea < 0 then
    begin
      Mid := Y2 + NonGradientArea;
      Y0 := Y1 + 1;
      L := Mid - Y0;
      X11 := X1 + 1;
      X21 := X2 - 1;
      for i := Y1 + 1 to Mid do
      begin
        for j := 0 to 3 do
          C[j] := MulDiv(1, C2[j] * (Mid - i) + C1[j] * (i - Y0), L);
        Pen.Color := Color;
        MoveTo(X11, i);
        LineTo(X21, i);
      end;
      Pen.Style := psClear;
      Brush.Color := Canvas.Pen.Color;
      Rectangle(X1 + 1, Mid, X2, Y2);
    end
    else
    begin
      Mid := NonGradientArea;
      Pen.Style := psSolid;
      Y0 := Y2 - 2;
      L := Mid - Y0;
      X11 := X1 + 1;
      X21 := X2 - 1;
      for i := Y2 - 2 downto Mid do
      begin
        for j := 0 to 3 do
          C[j] := MulDiv(1, C2[j] * (Mid - i) + C1[j] * (i - Y0), L);
        Pen.Color := Color;
        MoveTo(X11, i);
        LineTo(X21, i);
      end;
      Pen.Style := psClear;
      Brush.Color := Canvas.Pen.Color;
      Rectangle(X1 + 1, Y1 + 1, X2, Mid + 1);
    end;
    Pen.Color := FrameColor;
    Pen.Style := psSolid;
    MoveTo(X1, Y1);
    LineTo(X2 - 1, Y1);
    LineTo(X2 - 1, Y2 - 1);
    LineTo(X1, Y2 - 1);
    LineTo(X1, Y1);
  end;
end;
procedure HDrawGradientRect(Canvas: TCanvas; Left, Top, Width, Height: Integer;
  NonGradientArea: Integer; FrameColor, Color1, Color2: TColor);
var
  Mid: Integer;
  Color: TColor;
  C1: array[0..3] of Byte absolute Color1;
  C2: array[0..3] of Byte absolute Color2;
  C: array[0..3] of Byte absolute Color;
  i, j, X1, Y1, X2, Y2, X0, L, Y11, Y21: Integer;
begin
  X1 := Left;
  Y1 := Top;
  X2 := Left + Width;
  Y2 := Top + Height;
  Color1 := GetColor(Color1);
  Color2 := GetColor(Color2);
  with Canvas do
  begin
    if NonGradientArea < 0 then
    begin
      Mid := X2 + NonGradientArea;
      X0 := X1 + 1;
      L := Mid - X0;
      Y11 := Y1 + 1;
      Y21 := Y2 - 1;
      Pen.Style := psSolid;
      for i := X0 to Mid do
      begin
        for j := 0 to 3 do
          C[j] := MulDiv(1, C2[j] * (Mid - i) + C1[j] * (i - X0), L);
        Pen.Color := Color;
        MoveTo(i, Y11);
        LineTo(i, Y21);
      end;
      Pen.Style := psClear;
      Brush.Color := Canvas.Pen.Color;
      Rectangle(Mid, Y11, X2, Y2);
    end
    else
    begin
      Mid := NonGradientArea;
      X0 := X2 - 2;
      L := Mid - X0;
      Y11 := Y1 + 1;
      Y21 := Y2 - 1;
      Pen.Style := psSolid;
      for i := X0 downto Mid do
      begin
        for j := 0 to 3 do
          C[j] := MulDiv(1, C2[j] * (Mid - i) + C1[j] * (i - X0), L);
        Pen.Color := Color;
        MoveTo(i, Y11);
        LineTo(i, Y21);
      end;
      Pen.Style := psClear;
      Brush.Color := Canvas.Pen.Color;
      Rectangle(X1 + 1, Y1 + 1, Mid + 1, Y2);
    end;
    Pen.Color := FrameColor;
    Pen.Style := psSolid;
    MoveTo(X1, Y1);
    LineTo(X2 - 1, Y1);
    LineTo(X2 - 1, Y2 - 1);
    LineTo(X1, Y2 - 1);
    LineTo(X1, Y1);
  end;
end;

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

procedure TForm1.FormPaint(Sender: TObject);
begin
  VDrawGradientRect(Canvas, 0, 0, ClientWidth, ClientHeight, 0,
    clBtnFace, clHighlight);
end;

Алгоритм градиентной заливки.

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

Например, нужно сложить красный и синий. Получаем.

(255,0,0)+(0,0,255)=((255+0) div 2,(0+0) div 2,(0+255) div 2)=(127,0,127).

В результате получаем сиреневый цвет. Также надо поступать, если цветов более чем 2: сложить соответствующие координаты, потом каждую сумму разделить нацело на количество цветов.

Поговорим теперь о градиентной заливке. Градиентная заливка - это заливка цветом с плавным переходом от одного цвета к другому.

Итак, пусть заданы 2 цвета своими координатами ((A1, A2, A3) и (B1, B2, B3)) и линия (длиной h пикселов), по которой нужно залить. Тогда каждый цвет каждого пиксела, находящегося на расстоянии x пикселов от начала будет равен (A1-(A1-B1)/h*x, A2-(A2-B2)/h*x, A3-(A3-B3)/h*x). Теперь, имея линию с градиентной заливкой, можно таким образом залить совершенно любую фигуру: будь то прямоугольник, круг или просто произвольная фигура.

Вот как выглядит описанный алгоритм:

{Считается, что координаты первого цвета
равны (A1, A2, A3), а второго (B1, B2, B3)
Кроме того, линия начинается в координатах
(X1,Y1), а заканчивается в (X2,Y1)}
var
  h, i: integer;
begin
  h:=X2-X1-1;
  for i:=0 to h do
    with PaintBox1.Canvas do
    begin
      Pen.Color:=RGB(A1-(A1-B1)/h*i, A2-(A2-B2)/h*i, A3-(A3-B3)/h*i);
      Rectangle(I,Y1,I+1,Y1);
    end;
end.

Создание градиентной заливки.

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

procedure FillGradientRect(Canvas: TCanvas; Recty: TRect; fbcolor, fecolor: TColor; fcolors: Integer);
 var
   i, j, h, w, fcolor: Integer;
   R, G, B: Longword;
   beginRGBvalue, RGBdifference: array[0..2] of Longword;
 begin
   beginRGBvalue[0] := GetRvalue(colortoRGB(FBcolor));
   beginRGBvalue[1] := GetGvalue(colortoRGB(FBcolor));
   beginRGBvalue[2] := GetBvalue(colortoRGB(FBcolor));
   RGBdifference[0] := GetRvalue(colortoRGB(FEcolor)) - beginRGBvalue[0];
   RGBdifference[1] := GetGvalue(colortoRGB(FEcolor)) - beginRGBvalue[1];
   RGBdifference[2] := GetBvalue(colortoRGB(FEcolor)) - beginRGBvalue[2];
   Canvas.pen.Style := pssolid;
   Canvas.pen.mode := pmcopy;
   j := 0;
   h := recty.Bottom - recty.Top;
   w := recty.Right - recty.Left;
   for i := fcolors downto 0 do
   begin
     recty.Left  := muldiv(i - 1, w, fcolors);
     recty.Right := muldiv(i, w, fcolors);
     if fcolors1 then
     begin
       R := beginRGBvalue[0] + muldiv(j, RGBDifference[0], fcolors);
       G := beginRGBvalue[1] + muldiv(j, RGBDifference[1], fcolors);
       B := beginRGBvalue[2] + muldiv(j, RGBDifference[2], fcolors);
     end;
     Canvas.Brush.Color := RGB(R, G, B);
     patBlt(Canvas.Handle, recty.Left, recty.Top, Recty.Right - recty.Left, h, patcopy);
     Inc(j);
   end;
 end;
 // Case 1 
procedure TForm1.FormPaint(Sender: TObject);
 begin
   FillGradientRect(Form1.Canvas, rect(0, 0, Width, Height), $FF0000, $00000, $00FF);
 end;
 // Case 2 
procedure TForm1.FormPaint(Sender: TObject);
 var
   Row, Ht: Word;
   IX: Integer;
 begin
   iX := 200;
   Ht := (ClientHeight + 512) div 256;
   for Row := 0 to 512 do
   begin
     with Canvas do
     begin
       Brush.Color := RGB(Ix, 0, row);
       FillRect(Rect(0, Row * Ht, ClientWidth, (Row + 1) * Ht));
       IX := (IX - 1);
     end;
   end;
 end;
 { 
  Note, that the OnResize event should also call the FormPaint 
  method if this form is allowed to be resizable. 
  This is because if it is not called then when the 
  window is resized the gradient will not match the rest of the form. 
}
 {***********************************************************}
 {2. Another function}
 procedure TForm1.Gradient(Col1, Col2: TColor; Bmp: TBitmap);
 type
   PixArray = array [1..3] of Byte;
 var
   i, big, rdiv, gdiv, bdiv, h, w: Integer;
   ts: TStringList;
   p: ^PixArray;
 begin
   rdiv := GetRValue(Col1) - GetRValue(Col2);
   gdiv := GetgValue(Col1) - GetgValue(Col2);
   bdiv := GetbValue(Col1) - GetbValue(Col2);
   bmp.PixelFormat := pf24Bit;
   for h := 0 to bmp.Height - 1 do
   begin
     p := bmp.ScanLine[h];
     for w := 0 to bmp.Width - 1 do
     begin
       p^[1] := GetBvalue(Col1) - Round((w / bmp.Width) * bdiv);
       p^[2] := GetGvalue(Col1) - Round((w / bmp.Width) * gdiv);
       p^[3] := GetRvalue(Col1) - Round((w / bmp.Width) * rdiv);
       Inc(p);
     end;
   end;
 end;
 procedure TForm1.Button1Click(Sender: TObject);
 var
   BitMap1: TBitMap;
 begin
   BitMap1 := TBitMap.Create;
   try
     Bitmap1.Width := 300;
     bitmap1.Height := 100;
     Gradient(clred, clBlack, bitmap1);
     // So konnte man das Bild dann zB in einem TImage anzeigen 
    // To show the image in a TImage: 
    Image1.Picture.Bitmap.Assign(bitmap1);
   finally
     Bitmap1.Free;
   end;
 end;

Компонент градиентной раскраски областей.

Оформил: DeeCo

Автор: Александр Журавлев.

Табуляция в графическом ListBox.

Использование табуляции в ListВох'е когда компонент находится в стандартном режиме не составляет труда. Но что делать если надо использовать графическое отображение элементов списка? Ведь при этом надо самому писать обработчик отрисовки элементов с разбиением на колонки. Элементарное решение - использование API функции TabbedTextOut, однако результаты работы этой функции меня явно не удовлетворили. Пришлось-таки "выкручиваться"... Символ-разделитель можно использовать любой. Например, будем использовать символ "|", тогда обработчик OnDrawItem может выглядеть следующим образом:

procedure TBrowser.ListBox1DrawItem(Control: TWinControl; Index: Integer;
  Rect: TRect; State: TOwnerDrawState);
var
  S, Ss: string;
  P: Integer; // Флаг символа-разделителя
begin
  ListBox1.Canvas.FillRect(Rect);
  //Отрисовка графики
  ...
    //
  S := ListBox1.Items.Strings[Index];
  P := Pos('|', S);
  if P = 0 then
    Ss := S
  else
    // Если нет табуляции, то пишем всю строку,
    // иначе отрезаем кусок до разделителя
    Ss := Copy(S, 1, P - 1);
  ListBox1.Canvas.TextOut(Rect.Left + 20, Rect.Top + 2, Ss);
  if P > 0 then
    ListBox1.Canvas.TextOut(ListBox1.TabWidth, Rect.Top + 2, Copy(S, P + 1,
      Length(S) - P + 2));
end;

Не забудьте перед запуском поставить нужное значение TabWidth.

Компоненты для работы с графикой.

Оформил: DeeCo

Автор: Юрий.

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

А теперь рассмотрим вышеперечисленные пункты немного подробнее. Но для начала, несколько слов о принципах работы этих компонентов. Прежде всего они построены на основе массива объектов типа TBitmap. В 32 битных изображениях цвет кодируется 3 байтами - по одному на синий, зеленый и голубой, плюс добавляется один байт на альфа канал. В этот альфа канал записывается информация о том, следует ли при вставке одной картинки в другую использовать соответствующий пиксель (или игнорировать его). То есть по идее он может принимать два значения: 0 и 1. В этих компонентах использован несколько иной принцип использования альфа канала. Туда записывается число, которое представляет собой коэффициент, используемый при расчете двух пикселей двух различных картинок. То есть, если, скажем альфа канал равен 127, то результирующий пиксель будет являться средним арифметическим двух других пикселей. Значение альфа канала, равное 0 соответствует полной непрозрачности, а равное равное 255 - полной прозрачности вставляемой картинки. Процедура SetAlphaChannel устанавливает заданное значение альфа канала для всех пикселей картинки.

Также в компонент TGraph добавлено несколько функция для замены цветов. Все эти процедуры работают только с 24 битными рисунками.

procedure ChangeColor(ChangeColorProc: TChangeColorProc;
  Bitmap: TBitmap;
  Color: TColor);
TChangeColorProc = procedure(var R, G, B: Byte);

procedure ChangeColorEx(Bitmap: TBitmap;
  OldColor, NewColor: TColor;
  ChangingType: TChangingType);

procedure ChangeColorRange(Bitmap: TBitmap; IntensityRecLo,
  IntensityRecHi, NewIntensityRec: TIntensityRec;
  ChangingType: TChangingType);
TIntensityType = (itRed, itGreen, itBlue);
TIntensityRec = array[TIntensityType] of Byte;

procedure ChangeColorRange(Bitmap: TBitmap;
  IntensityType: TIntensityType;
  IntensityLo, IntensityHi: Byte;
  NewIntensityRec: TIntensityRec;
  ChangingType: TChangingType);

Вот, собственно все процедуры созданные для замены цвета. Вместе они представляют из себя довольно гибкое средство для работы с графикой. Еще одно достоинство - они работают достаточно быстро. Это касается также и других процедур, например на компьютере Pentium Celeron 400 расчет прозрачности двух картинок (обе были (конечно же) 32 битные, размером 1024 на 768) занимал на более 500 миллисекунд.

RefArray: TIntArrayTIntArray = array of Integer;

property Reference[Col, Row: Integer]: TGridCoord;
TGridCoord = record
  Col, Row: Integer;
end;

function GridCoord(Col, Row: Integer): TGridCoord;

TDrawPictureEvent = procedure(Sender: TObject; Rect: TRect;
  Index, Col, Row: Integer;
  var X, Y: Integer; Picture: TBitmap;
  var Background: TBitmap;
  var Continue: Boolean) of object;

procedure TGraph.AnimatedText(Canvas: TCanvas;
  Application: TApplication;
  Source: TBitmap;
  List: TStrings;
  Alignment: TAlignment;
  X, Y, Decrement: Integer;
  Delay: LongWord);

Заключение

Если Вам удалось прочитать всю это до конца, то я уверен, Вы сможете найти практическое применение для моих компонентов, а скачать их можно здесь — Graph.zip (11 K).

Графический редактор.

Оформил: DeeCo

Часть 1.

Приложение выполняет следующие функции:

SpeedButton: SBBrush, SBColor;
GroupIndex := 1;
AllowAllUp := true;
Glyph := ..\Images\Butons\brush.bmp;
Glyph := ..\Images\Butons\one2one.bmp;

Последовательность проектирования: ;
1. Заполнить форму;
2. var
  Bitmap: TBitMap;
  3. Form OnCreate;
  4. Form OnDestroy;
  5. MOpenClick;
  6. UndoClick;
  7. SBBrushClick и SBColor(запоминает текущий вид изображения);
  8. Image3MouseDown и копировать в Image4 MouseDown;

unit UGraphEdit;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, Buttons, ExtCtrls, Menus, ExtDlgs;
type
  TForm1 = class(TForm)
    Image1: TImage;
    Image2: TImage;
    Image3: TImage;
    Image4: TImage;
    SBBrush: TSpeedButton;
    SBColor: TSpeedButton;
    OpenPictureDialog1: TOpenPictureDialog;
    MainMenu1: TMainMenu;
    N1: TMenuItem;
    MOpen: TMenuItem;
    N2: TMenuItem;
    Undo: TMenuItem;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure MOpenClick(Sender: TObject);
    procedure UndoClick(Sender: TObject);
    procedure SBBrushClick(Sender: TObject);
    procedure Image3MouseDown(Sender: TObject; Button: TMouseButton; Shift:
      TShiftState; X, Y: Integer);
  private { Private declarations }
  public { Public declarations }
  end;
var
  Form1: TForm1;
implementation
{$R *.DFM}
var
  BitMap: TBitMap;
    //переменная для сохранения изображения, если его нужно будет востановить командой отменить
procedure
  TForm1.FormCreate(Sender: TObject);
var
  HW, I: integer;
begin
  BitMap := TBitMap.Create;
  {задание свойств кисти основного и
  вспомогательного цветов}
  Image1.Canvas.Brush.Color := clBlack;
  Image2.Canvas.Brush.Color := clWhite;
  {заполнение окон основного и вспомогательного
  цветов}
  with
    Image1.Canvas do
    FillRect(Rect(0, 0, Width, Height));
  with Image2.Canvas do
    FillRect(Rect(0, 0, Width, Height));
  {задание ширины элемента палитры
  цветов}
  HW := Image4.Width
    div 10;
  {закраска элементов палитры цветов}
  with
    Image4.Canvas do
    for I := 1 to 10 do
    begin
      case I of
        1: Brush.Color := clBlack;
        2: Brush.Color := clAqua;
        3: Brush.Color := clBlue;
        4: Brush.Color := clFuchsia;
        5: Brush.Color := clGreen;
        6: Brush.Color := clLime;
        7: Brush.Color := clMaroon;
        8: Brush.Color := clRed;
        9: Brush.Color := clYellow;
        10: Brush.Color := clWhite;
      end;
      Rectangle((I - 1) * HW, 0, I * HW, Height);
    end;

{рисование креста на холсте – только для
тестирования}
with Image3 do
begin
  Canvas.MoveTo(0, 0);
  Canvas.LineTo(Width, Height);
  Canvas.MoveTo(0, Height);
  Canvas.LineTo(Width, 0);
end;
BitMap.Assign(Image3.Picture);
end;
procedure TForm1.FormDestroy(Sender:
  TObject);
begin
  BitMap.Free;
end;
procedure TForm1.MOpenClick(Sender:
  TObject);
begin
  if OpenPictureDialog1.Execute then
  begin
    Image3.Picture.LoadFromFile(OpenPictureDialog1.FileName);
    BitMap.Assign(Image3.Picture);
  end;
end;
procedure TForm1.UndoClick(Sender:
  TObject);
begin
  Image3.Picture.Assign(BitMap);
end;
procedure
  TForm1.SBBrushClick(Sender: TObject);
begin
  if (Sender as TSpeedButton).Down then
    BitMap.Assign(Image3.Picture);
end;
procedure
  TForm1.Image3MouseDown(Sender: TObject; Button: TMouseButton; Shift:
  TShiftState; X, Y: Integer);
begin
  if (Sender = Image4) or SBColor.Down then
    {режим установки основного и вспомогательного
    цветов}
  begin
    if (Button = mbLeft) then
      with Image1.Canvas do
      begin
        {установка основного
        цвета}
        Brush.Color := (Sender as
          TImage).Canvas.Pixels[X, Y];
        FillRect(Rect(0, 0, Width, Height));
      end
    else
      with Image2.Canvas do
      begin
        {установка вспомогательного
        цвета}
        Brush.Color := (Sender as
          TImage).Canvas.Pixels[X, Y];
        FillRect(Rect(0, 0, Width, Height));
      end;
  end
  else if SBBrush.Down then
    with Image3.Canvas do
    begin
      {режим закраски указанной области
      холста}
      if
        Button = mbLeft then
        Brush.Color := Image1.Canvas.Brush.Color
      else
        Brush.Color := Image2.Canvas.Brush.Color;
      FloodFill(X, Y, Pixels[X, Y], fsSurface);
    end;
end;
end.

8. OnMouseDown – это основной код, осуществляющий как установку основного и вспомогательных цветов, так и функцию инструмента графического редактора – кисти. Если кнопка мыши нажата на палитре цветов, Image4, или если кнопка SBColor – кнопка указателя цвета утоплена, то приложение находится в режиме установки цветов. При нажатой левой кнопки мыши цвет пикселя под курсором мыши передается в окно основного цвета, а при нажатой правой кнопки – в окно вспомогательного цвета. Если кнопка мыши нажата на холсте, Image3, или если кнопка SBColor – кнопка указателя цвета утоплена, то приложение находится в режиме закраски указанной области рисунка. В этом случае в зависимости от нажатой кнопки мыши выбирается основной или вспомогательный цвет и функцией FloodFill производится закраска области, координаты внутренней точки которой указаны курсором мыши, а цвет – цветом пикселя, на который указывает мышь.

Функция выделения фрагмента осуществляется методом DrawFocusRect.В этом режиме
при событии onMouseDown холста – компонента Image3, выполняются операторы:
{запоминание начального положения курсора мыши}
X0 := X;
//запоминание координаты мыши X,Y в переменных X0,Y0;
Y0 := Y; //начальные координаты прямоугольной области – переменной R типа TRect;
{формирование начального положения области фрагмента};
R.TopLeft := Point(X, Y);
R.BottomRight := Point(X, Y); {рисование рамки}
Image3.DrawFocusRect(R);
  //рисуется рамка пока нулевого размера методом DrawFocusRect;
RBegin := true;
{утанавливается флаг начала выделения фрагмента RBegin;При событии onMouseMove компонента Image3, 
если установлен флаг RBegin, выпол-няются операторы:}

{Стирание прежней рамки фрагмента}
Image3.Canvas.DrawFocusRect(R);
  //метод DrawFocusRect рисует рамку с помощью операции XOR;
{формирование области R};
if X0 < X then //область, передаваемая в функцию DrawFocusRect
begin
  R.Left := X0;
  R.Right := X
end // должна быть сформирована так, что R.Left<R.Right и
else
begin
  R.Left := X;
  R.Right := X0
end; // R.Top<R.Buttom
if Y0 < Y then
begin
  R.Top := Y0;
  R.Bottom := Y
end
else
begin
  R.Top := Y;
  R.Bottom := Y0
end;
{Рисования новой рамки фрагмента}
Image3.Canvas.DrawFocusRect(R);
{Рамка,ограничивающая фрагмент нарисована. Если пользовательпомещает курсор внутрь выделенной
области и нажимает кнопку мыши (onMouseDown), выполняют-ся операторы:}
with Image3.Canvas do
begin
  ;
  X0 := X; //запоминание начального положения курсора мыши
  Y0 := Y;
  DrawFocusRect(R); {стирание прежней рамки}
  ;
  RDrag := true; //устанавливает флаг перетаскивания RDrag;
  REnd := false;
  {запоминание начального положения перетаскиваемого фрагмента в переменной R0 типа TRect};
  R0.TopLeft := R.TopLeft;
  R0.BottomRight := R.BottomRight;
  {запоминание методом  Assign изображения в момент начала перетаскивания в переменно BitMap,
  чтобы в процессе перетаскивания можно было восстанавливать испорченные места изображения и
  чтобы при желании пользователя можно было в дальнейшем отменить результат перетаскивания};
  BitMap.Assign(Image3.Picture);
  {установка цвета кисти равным вспомогательному цвету, хранящемуся в компоненте Image2};
  Brush.Color := Image2.Canvas.Brush.Color;
end;
{При событии onMouseMove компонента Image3, если установлен флаг RDrag, выпол-няются операторы:
восстановление изображения под перетаскиваемым фрагментом в его прежней позиции, (т.е. стирает фрагмент)
  копируя соответствующую область методом CopyRect из компо-нента BitMap };
CopyRect(R, BitMap.Canvas, R);
{если не нажата клавиша Ctrl - стирание изображения в R0(осуществляется вырезание) ме-тодом FillRect };
if not (ssCtrl in Shift) then
  FillRect(R0);
{формирование нового положения фрагмента }
R.Left := R.Left + X - X0;
R.Right := R.Right + X - X0;
R.Top := R.Top + Y - Y0;
R.Bottom := R.Bottom + Y - Y0;
{запоминание положения курсора мыши};
X0 := X;
Y0 := Y;
{рисование фрагмента в новом положении};
CopyRect(R, BitMap.Canvas, R0); {рисование рамки}
DrawFocusRect(R);
{Таким образом проводится операция выделения фрагрента и его перетаскивания.}

with Image3.Canvas do
begin
  Brush.Color := Image2.Canvas.Brush.Color; //задается цвет кисти;
  Pen.Color := Image1.Canvas.Brush.Color; //задается цвет пера;
  Rectangle(R.Left, R.Top, R.Right, R.Bottom);
end;

with Image3.Canvas do
begin
  Brush.Color := Image1.Canvas.Brush.Color;
  FrameRect(R); //метод FrameRect рисует цветом кисти;
end;

pmCopy – линии проводятся цветом, заданным в свойстве Color
pmBlack Always black
pmWhiteAlways white
pmNopUnchanged
pmNot Inverse of canvas background color
pmCopy Pen color specified in Color property
pmNotCopyInverse of pen color
pmMergePenNot Combination of pen color and inverse of canvas background
pmMaskPenNotCombination of colors common to both pen and inverse of canvas background.
pmMergeNotPen Combination of canvas background color and inverse of pen color
pmMaskNotPenCombination of colors common to both canvas background and inverse of pen
pmMerge Combination of pen color and canvas background color
pmNotMergeInverse of pmMerge: combination of pen color and canvas background color
pmMask Combination of colors common to both pen and canvas background
pmNotMaskInverse of pmMask: combination of colors common to both pen and canvas background
рmХогСложение с фоном по исключающему
{ИЛИ (линия появляется только в момент отпускания мыши)
рmNоtХогСложение с фоном по инверсному исключающему ИЛИ}

X0 := X;
Y0 := Y;
X1 := X;
Y1 := Y;
Image3.Canvas.Pen.Color := Image1.Canvas.Brush.Color;
  //устанавливается цвет пера;
Image3.Canvas.Pen.Mode := pmNotXor;
  //режим pmNotXor позволяет при движении мыши стирать изображение линии;

with Image3.Canvas do
begin
  {стирание прежней линии}
  MoveTo(X0, Y0);
    //стирается линия в прежнем положении (это необходимо, т.к. метод LineTo
  LineTo(X1, Y1);
    //рисует линию,начинающуюся в текущей позиции пера и заканчивающуюся
  {рисование новой линии}//в указанной точке, исключая эту конечную точку.
  MoveTo(X0, Y0); //рисуется новая линия;
  LineTo(X, Y);
  X1 := X; {запоминание новых координат конца линии}
  Y1 := Y;
end;

with Image3.Canvas do
begin
  MoveTo(X0, Y0); //стирание прежней линии;
  LineTo(X1, Y1);
  Pen.Mode := pmCopy; //рисование новой линии;
  MoveTo(X0, Y0);
  LineTo(X, Y);
end;

Image3.Canvas.Pixels[X, Y] := Image3.Canvas.Brush.Color;

Image3.Canvas.LineTo(X, Y);

procedure TForm1.MSaveClick(Sender: TObject);
begin
  if SavePictureDialog1.Execute then
  begin
    BitMap.Assign(Image3.Picture); //сохранение изображения;
    BitMap.SaveToFile(SavePictureDialog1.FileName); //запись в файл изображения;
  end;
end;

procedure TForm1.MCopyClick(Sender: TObject);
var
  BMCopy: TBitMap;
begin
  Image3.Canvas.DrawFocusRect(R); {стирание рамки}
  BMCopy := BitMap.Create; {создание временного объекта BMCopy }
  BMCopy.Width := R.Right - R.Left;
  BMCopy.Height := R.Bottom - R.Top;
  try
    {копирование объекта в BMCopy }
    BMCopy.Canvas.Copyrect(Rect(0, 0, BMCopy.Width, BMCopy.Height),
      Image3.Canvas, R);
    Image3.Canvas.DrawFocusRect(R); {восстановление рамки}
    ClipBoard.Assign(BMCopy); {копирование в Clipboard}
    if (Sender as TMenuItem).Name = 'MCut' then
    begin
      Image3.Canvas.Brush.Color := clWhite; {вырезание}
      Image3.Canvas.FillRect(R);
    end;
  finally
    {благодаря разделу finally память освобождается от временного объекта при любом исходе
    копирования: удачном или аварийном}
    BMCopy.Free; {освобождение памяти}
  end;
end;

procedure TForm1.MPasteClick(Sender: TObject);
var
  BMCopy: TBitMap;
begin
  BMCopy := BitMap.Create;
  try
    try
      BMCopy.LoadFromClipBoardFormat(cf_BitMap,
        ClipBoard.GetAsHandle(cf_Bitmap), 0);
      Image3.Canvas.CopyRect(Rect(0, 0, BMCopy.Width, BMCopy.Height);
        BMCopy.Canvas, Rect(0, 0, BMCopy.Width, BMCopy.Height));
    finally
      BMCopy.Free;
    end;
  except
    on EInvalidGraphic do
      ShowMessage('Ошибочный формат графики');
  end;
end;

TForm1 = class(TForm)
  MFile: TMenuItem;
  SBRect: TSpeedButton;
  SBRectang: TSpeedButton;
  SBFillRec: TSpeedButton;
  SBErase: TSpeedButton;
  SBPen: TSpeedButton;
  SBLine: TSpeedButton;
  MSave: TMenuItem;
  MCut: TMenuItem;
  MCopy: TMenuItem;
  MPaste: TMenuItem;
  SavePictureDialog1: TSavePictureDialog;
  procedure Image3MouseDown(Sender: TObject; Button:
    TMouseButton; Shift: TShiftState; X, Y: Integer); //доб.
  procedure SBBrushClick(Sender: TObject);
  procedure Image3MouseMove(Sender: TObject; Shift:
    TShiftState; X, Y: Integer);

procedure Image3MouseUp(Sender: TObject; Button:
  TMouseButton; Shift: TShiftState; X, Y: Integer);
  procedure MOpenClick(Sender: TObject);
    procedure MCopyClick(Sender: TObject);
      procedure MPasteClick(Sender: TObject);
        procedure MSaveClick(Sender: TObject);
          …………………………………………….
end;
implementation
{$R *.DFM}
var
  BitMap, BMCopy: TBitMap;
  R, R0: TRect;
  X0, Y0, X1, Y1: longint;
const
  RBegin: boolean = false; //флаг начала выделения фрагмента
  REnd: boolean = false; //
  RDrag: boolean = false; //флаг
  перетаскивания
  procedure
  TForm1.Image3MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if (Sender = Image4) or SBColor.Down then
    {режим установки основного и вспомогательного
    цветов}
  begin
    if (Button = mbLeft) then
      with Image1.Canvas do
      begin
        {установка основного
        цвета}
        Brush.Color := (Sender as
          TImage).Canvas.Pixels[X, Y];
        FillRect(Rect(0, 0, Width, Height));
      end
    else
      with Image2.Canvas do
      begin
        {установка вспомогательного
        цвета}
        Brush.Color := (Sender as TI //mage).Canvas.Pixels[X,Y];
          FillRect(Rect(0, 0, Width, Height));
      end;
  end
  else
    with Image3.Canvas do
    begin
      X0 := X;
      Y0 := Y;
      if SBPen.Down then
      begin
        {режим карандаша}
        MoveTo(X, Y);
        Pen.Color := Image1.Canvas.Brush.Color;
      end
      else if SBLine.Down then
      begin
        {режим линии}
        X1 := X;
        Y1 := Y;
        Pen.Mode := pmNotXor;
        Pen.Color := Image1.Canvas.Brush.Color;
      end
      else if SBBrush.Down then
      begin
        {режим закраски указанной области
        холста}
        if
          Button = mbLeft then
          Brush.Color := Image1.Canvas.Brush.Color
        else
          Brush.Color := Image2.Canvas.Brush.Color;
        FloodFill(X, Y, Pixels[X, Y], fsSurface);
      end
      else if SBErase.Down then
      begin
        {режим ластика}
        R := Rect(X - 6, Y - 6, X + 6, Y + 6);
        DrawFocusRect(R);
        Brush.Color := Image2.Canvas.Brush.Color;
        FillRect(Rect(X - 5, Y - 5, X + 5, Y + 5));
      end
      else if SBRect.Down or SBRectang.Down or
        SBFillRec.Downthen
      begin
      {режим работы с фрагментом}
      if REnd then
      begin
        {стирание прежней рамки}
        DrawFocusRect(R);
        if (X < R.Right) and (X > R.Left) and (Y > R.Top) and
          (Y < R.Bottom)
          {режим начала перетаскивания
        фрагмента} then
        begin
          {установка флагов}
          RDrag := true;
          REnd := false;
          {запоминание начального положения
          перетаскиваемого фрагмента}
          R0.TopLeft := R.TopLeft;
          R0.BottomRight := R.BottomRight;
          {запоминание
          изображения}
          BitMap.Assign(Image3.Picture);
          {установка
          цвета
          кисти}
          Brush.Color := Image2.Canvas.Brush.Color;
          MCopy.Enabled := false;
          MCut.Enabled := false;
        end;
      end
      else
      begin
        {режим начала рисования рамки
        фрагмента}
        RBegin := true;
        REnd := false;
        R.TopLeft := Point(X, Y);
        R.BottomRight := Point(X, Y);
        DrawFocusRect(R);
      end;
    end;
    end;
end;
procedure
  TForm1.SBBrushClick(Sender: TObject);
begin
  if (Sender as TSpeedButton).Down then
    BitMap.Assign(Image3.Picture);
  RBegin := false;
  RDrag := false;
  REnd := false;
end;
procedure
  TForm1.Image3MouseMove(Sender: TObject; Shift: TShiftState; X, Y:
  Integer);
begin
  if not (ssLeft in Shift) then
    exit;
  {режим линии}
  if SBLine.Down then
    with
      Image3.Canvas do
    begin
      {стирание прежней линии}
      MoveTo(X0, Y0);
      LineTo(X1, Y1);
      {рисование новой линии}
      MoveTo(X0, Y0);
      LineTo(X, Y);
      {запоминание новых координат конца
      линии}
      X1 := X;
      Y1 := Y;
    end
  else if SBPen.Down then
    Image3.Canvas.LineTo(X, Y)
  else if SBErase.Down then
    with Image3.Canvas do
    begin
      {режим ластика}
      DrawFocusRect(R);
      R := Rect(X - 6, Y - 6, X + 6, Y + 6);
      DrawFocusRect(R);
      FillRect(Rect(X - 5, Y - 5, X + 5, Y + 5));
    end
  else if (SBRect.Down and (RBegin or RDrag)) or
    SBRectang.Down or SBFillRec.Down then
    with Image3.Canvas do
    begin
      if RBegin then
      begin
        {Режим рисования рамки фрагмента}
        DrawFocusRect(R);
        if X0 < X then
        begin
          R.Left := X0;
          R.Right := X
        end
        else
        begin
          R.Left := X;
          R.Right := X0
        end;
        if Y0 < Y then
        begin
          R.Top := Y0;
          R.Bottom := Y
        end
        else
        begin
          R.Top := Y;
          R.Bottom := Y0
        end;
        DrawFocusRect(R);
      end
      else if SBRect.Down then
      begin
        {Режим перетаскивания фрагмента}
        {восстановление изображения под перетаскиваемым
        фрагментом}
        CopyRect(R, BitMap.Canvas, R);
        {если не нажата клавиша Ctrl - стирание
        изображения в R0}
        if not (ssCtrl in Shift) then
          FillRect(R0);
        {формирование нового положения фрагмента
        }
        R.Left := R.Left + X - X0;
        R.Right := R.Right + X - X0;
        R.Top := R.Top + Y - Y0;
        R.Bottom := R.Bottom + Y - Y0;
        {запоминание положения курсора мыши}
        X0 := X;
        Y0 := Y;
        {рисование фрагмента в новом
        положении}
        CopyRect(R, BitMap.Canvas, R0);
        {рисование
        рамки}
        DrawFocusRect(R);
      end;
    end;
end;
procedure
  TForm1.Image3MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  with Image3.Canvas do
  begin
    if SBLine.Down then
    begin
      MoveTo(X0, Y0);
      LineTo(X1, Y1);
      Pen.Mode := pmCopy;
      MoveTo(X0, Y0);
      LineTo(X, Y);
    end
    else if SBRect.Down then
    begin
      if RDrag then
        DrawFocusRect(R);
      if RBegin and not REndthen
      begin
        REnd := true;
        MCopy.Enabled := true;
        MCut.Enabled := true;
      end
    end
    else if SBRectang.Down then
    begin
      Brush.Color := Image1.Canvas.Brush.Color;
      FrameRect(R);
    end
    else if SBFillRec.Down then
    begin
      Brush.Color := Image2.Canvas.Brush.Color;
      Pen.Color := Image1.Canvas.Brush.Color;
      Rectangle(R.Left, R.Top, R.Right, R.Bottom);
    end
    else if
      SBErase.Downthen
      Image3.Canvas.DrawFocusRect(R);
    RBegin := false;
    RDrag := false;
  end;
end;
procedure
  TForm1.MCopyClick(Sender: TObject);
{var
MyFormat: Word;
AData: THandle;
APalette: HPALETTE;}
begin
  Image3.Canvas.DrawFocusRect(R);
  BMCopy := BitMap.Create;
  BMCopy.Width := R.Right - R.Left;
  BMCopy.Height := R.Bottom - R.Top;
  try
    BMCopy.Canvas.Copyrect(Rect(0, 0, BMCopy.Width, BMCopy.Height),
      Image3.Canvas, R);
    Image3.Canvas.DrawFocusRect(R);
    {BMCopy.SaveToClipBoardFormat(MyFormat,AData,APalette);
    ClipBoard.SetAsHandle(MyFormat,AData);}
    ClipBoard.Assign(BMCopy);
    if (Sender as TMenuItem).Name = 'MCut' then
    begin
      Image3.Canvas.Brush.Color := clWhite;
      Image3.Canvas.FillRect(R);
    end;
  finally
    BMCopy.Free;
  end;
end;
procedure
  TForm1.MPasteClick(Sender: TObject);
begin
  BMCopy := BitMap.Create;
  try
    try
      BMCopy.LoadFromClipBoardFormat(cf_BitMap,
        ClipBoard.GetAsHandle(cf_Bitmap), 0);
      Image3.Canvas.CopyRect(Rect(0, 0, BMCopy.Width, BMCopy.Height),
        BMCopy.Canvas, Rect(0, 0, BMCopy.Width, BMCopy.Height));
    finally
      BMCopy.Free;
    end;
  except
    on EInvalidGraphic do
      ShowMessage('Ошибочный формат графики');
  end;
end;
procedure
  TForm1.MSaveClick(Sender: TObject);
begin
  if SavePictureDialog1.Execute then
  begin
    BitMap.Assign(Image3.Picture);
    BitMap.SaveToFile(SavePictureDialog1.FileName);
  end;
end;
end.

Как сделать графический Hint.

Автор: http://www.swissdelphicenter.ch

{*********************************************************
 Mit Hilfe des folgendes Codes lassen sich leicht beliebige
 Hints erstellen. Dazu muss nur dir Prozedur "Paint" den
 Wьnsсhеn entsprechend angepasst werden.
 With the following Code you can simply create custom hints.
 You just have to change the procedur "Paint".
 *********************************************************}
type
  TGraphicHintWindow = class(THintWindow)
    constructor Create(AOwner: TComponent); override;
  private
    FActivating: Boolean;
  public
    procedure ActivateHint(Rect: TRect; const AHint: string); override;
  protected
    procedure Paint; override;
  published
    property Caption;
  end;
  {...}
constructor TGraphicHintWindow.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  {
   Hier кцnnеn beliebige Schrift Eigenschaften gesetzt
   werden.
   Here you can set custom Font Properties:
   }
  with Canvas.Font do
  begin
    Name := 'Arial';
    Style := Style + [fsBold];
    Color := clBlack;
  end;
end;
procedure TGraphicHintWindow.Paint;
var
  R: TRect;
  bmp: TBitmap;
begin
  R := ClientRect;
  Inc(R.Left, 2);
  Inc(R.Top, 2);
  {*******************************************************
   Der folgende Code ist ein Beispiel wie man die Paint
   Prozedur nutzen kann um einen benutzerdefinierten Hint
   zu erzeugen.
   The folowing Code ist an example how to create a custom
   Hint Object. :
   }
  bmp := TBitmap.Create;
  bmp.LoadfromFile('D:\hint.bmp');
  with Canvas do
  begin
    Brush.Style := bsSolid;
    Brush.Color := clsilver;
    Pen.Color := clgray;
    Rectangle(0, 0, 18, R.Bottom + 1);
    Draw(2, (R.Bottom div 2) - (bmp.Height div 2), bmp);
  end;
  bmp.Free;
  //Beliebige HintFarbe
  //custom Hint Color
  Color := clWhite;
  Canvas.Brush.Style := bsClear;
  Canvas.TextOut(20, (R.Bottom div 2) - (Canvas.Textheight(Caption) div 2),
    Caption);
  {********************************************************}
end;
procedure TGraphicHintWindow.ActivateHint(Rect: TRect; const AHint: string);
begin
  FActivating := True;
  try
    Caption := AHint;
    //Нцhе des Hints setzen setzen
    //Set the "Height" Property of the Hint
    Inc(Rect.Bottom, 14);
    //Breite des Hints setzen
    //Set the "Width" Property of the Hint
    Rect.Right := Rect.Right + 20;
    UpdateBoundsRect(Rect);
    if Rect.Top + Height > Screen.DesktopHeight then
      Rect.Top := Screen.DesktopHeight - Height;
    if Rect.Left + Width > Screen.DesktopWidth then
      Rect.Left := Screen.DesktopWidth - Width;
    if Rect.Left < Screen.DesktopLeft then
      Rect.Left := Screen.DesktopLeft;
    if Rect.Bottom < Screen.DesktopTop then
      Rect.Bottom := Screen.DesktopTop;
    SetWindowPos(Handle, HWND_TOPMOST, Rect.Left, Rect.Top, Width, Height,
      SWP_SHOWWINDOW or SWP_NOACTIVATE);
    Invalidate;
  finally
    FActivating := False;
  end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
  HintWindowClass := TGraphicHintWindow;
  Application.ShowHint := False;
  Application.ShowHint := True;
end;

Построение графика.

unit TestGrF;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls, DdhGraph;
type
  TForm1 = class(TForm)
    ColorDialog1: TColorDialog;
    FontDialog1: TFontDialog;
    Image1: TImage;
    Panel1: TPanel;
    Button1: TButton;
    Button2: TButton;
    CheckBox1: TCheckBox;
    Button3: TButton;
    DdhGraph1: TDdhGraph;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure CheckBox1Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
var
  Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
  ColorDialog1.Color := DdhGraph1.Color;
  if ColorDialog1.Execute then
    DdhGraph1.Color := ColorDialog1.Color;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
  FontDialog1.Font := DdhGraph1.Font;
  if FontDialog1.Execute then
    DdhGraph1.Font := FontDialog1.Font;
end;
procedure TForm1.CheckBox1Click(Sender: TObject);
begin
  if CheckBox1.Checked then
    DdhGraph1.BorderStyle := bsSingle
  else
    DdhGraph1.BorderStyle := bsNone;
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
  ColorDialog1.Color := DdhGraph1.LinesColor;
  if ColorDialog1.Execute then
    DdhGraph1.LinesColor := ColorDialog1.Color;
end;
end.

Загрузить исходный код проекта Загрузить библиотеку с компонентами

График и отображаемый в память файл.

unit MapGForm;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, SyncObjs, TeEngine, Series, ExtCtrls, TeeProcs, Chart, Grids,
  ComCtrls;
type
  TForm1 = class(TForm)
    Timer1: TTimer;
    Chart1: TChart;
    Series1: TBarSeries;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    hMapFile: THandle;
    MapFilePointer: Pointer;
  public
    procedure WmUser(var Msg: TMessage); message wm_user;
  end;
var
  Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
var
  Address: Pointer;
  X, Y, Total: Integer;
begin
  hMapFile := CreateFileMapping(
    $FFFFFFFF, // file handle ... or memory
    nil, // security
    Page_ReadWrite, // access rights
    0, // high memory size
    10000, // low memory size
    'DdhMappedFileGraph'); // mapped file name
  if hMapFile <> 0 then
    MapFilePointer := MapViewOfFile(
      hMapFile, // handle returned above
      File_Map_All_Access, // access rights
      0, 0, 0) // access the entire mapped file
  else
    ShowMessage('hMapFile = 0');
  if MapFilePointer = nil then
    ShowMessage('MapFilePointer = nil')
  else
  begin
    // add window to area
    Address := pChar(MapFilePointer) + 400;
    while PInteger(Address)^ <> 0 do
      Address := pChar(Address) + 4;
    PInteger(Address)^ := Handle;
  end;
  // start up chart
  Chart1.Series[0].Clear;
  for X := 0 to 9 do
  begin
    Total := 0;
    for Y := 0 to 9 do
    begin
      Address := pChar(MapFilePointer) + (X + Y * 10) * 4;
      Inc(Total, PInteger(Address)^);
    end;
    Chart1.Series[0].AddY(
      Total, IntToStr(X + 1), clRed);
  end;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
  UnMapViewOfFile(MapFilePointer);
  CloseHandle(hMapFile);
end;
procedure TForm1.WmUser(var Msg: TMessage);
var
  X, Y, Total: Integer;
  Address: Pointer;
begin
  // copy all the data to the graph
  for X := 0 to 9 do
  begin
    Total := 0;
    for Y := 0 to 9 do
    begin
      Address := pChar(MapFilePointer) + (X + Y * 10) * 4;
      Inc(Total, PInteger(Address)^);
    end;
    Chart1.Series[0].YValue[X] := Total;
  end;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
  X, Y: Integer;
  Address: Pointer;
begin
  X := Random(10);
  Y := Random(10);
  Address := pChar(MapFilePointer) + (X + Y * 10) * 4;
  PInteger(Address)^ := PInteger(Address)^ + Random(10);
  Address := pChar(MapFilePointer) + 400;
  while PInteger(Address)^ <> 0 do
  begin
    PostMessage(PInteger(Address)^, wm_user, 0, 0);
    Address := pChar(Address) + 4;
  end;
end;
initialization
  Randomize;
end.

График функции.

unit grfunc_;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
type
  TForm1 = class(TForm)
    procedure FormPaint(Sender: TObject);
    procedure FormResize(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
var
  Form1: TForm1;
implementation
{$R *.DFM}
// Функция, график которой надо построить
function f(x: real): real;
begin
  f := 2 * Sin(x) * exp(x / 5);
end;
// строит график функции
procedure GrOfFunc;
var
  x1, x2: real; // границы изменения аргумента функции
  y1, y2: real; // границы изменения значения функции
  x: real; // аргумент функции
  y: real; // значение функции в точке x
  dx: real; // приращение аргумента
  l, b: integer; // левый нижний угол области вывода графика
  w, h: integer; // ширина и высота области вывода графика
  mx, my: real; // масштаб по осям X и Y
  x0, y0: integer; // точка - начало координат
begin
 // область вывода графика
  l := 10; // X - координата левого верхнего угла
  b := Form1.ClientHeight - 20; // Y - координата левого верхнего угла
  h := Form1.ClientHeight - 40; // высота
  w := Form1.Width - 40; // ширина
  x1 := 0; // нижняя граница диапазона аргумента
  x2 := 25; // верхняя граница диапазона аргумента
  dx := 0.01; // шаг аргумента
 // найдем максимальное и минимальное значения
 //  функции на отрезке [x1,x2]
  y1 := f(x1); // минимум
  y2 := f(x1); // максимум
  x := x1;
  repeat
    y := f(x);
    if y < y1 then y1 := y;
    if y > y2 then y2 := y;
    x := x + dx;
  until (x >= x2);
 // вычислим масштаб
  my := h / abs(y2 - y1); // масштаб по оси Y
  mx := w / abs(x2 - x1); // масштаб по оси X
 // оси
  x0 := l;
  y0 := b - Abs(Round(y1 * my));
  with form1.Canvas do
  begin
   // оси
    MoveTo(l, b); LineTo(l, b - h);
    MoveTo(x0, y0); LineTo(x0 + w, y0);
    TextOut(l + 5, b - h, FloatToStrF(y2, ffGeneral, 6, 3));
    TextOut(l + 5, b, FloatToStrF(y1, ffGeneral, 6, 3));
   // построение графика
    x := x1;
    repeat
      y := f(x);
      Pixels[x0 + Round(x * mx), y0 - Round(y * my)] := clRed;
      x := x + dx;
    until (x >= x2);
    TextOut(17, 100, 'Delphi World Example');
  end;
end;
procedure TForm1.FormPaint(Sender: TObject);
begin
  GrOfFunc;
end;
// изменился размер окна программы
procedure TForm1.FormResize(Sender: TObject);
begin
  // очистить форму
  form1.Canvas.FillRect(Rect(0, 0, ClientWidth, ClientHeight));
  // построить график
  GrOfFunc;
end;
end.

Сетка и отображаемый в память файл.

unit MapGForm;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, SyncObjs, TeEngine, Series, ExtCtrls, TeeProcs, Chart, Grids,
  ComCtrls;
type
  TForm1 = class(TForm)
    StringGrid1: TStringGrid;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure StringGrid1SelectCell(Sender: TObject; Col, Row: Integer;
      var CanSelect: Boolean);
  private
    hMapFile: THandle;
    MapFilePointer: Pointer;
  public
    procedure WmUser(var Msg: TMessage); message wm_user;
  end;
var
  Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
var
  Address: Pointer;
begin
  hMapFile := CreateFileMapping(
    $FFFFFFFF, // file handle ... or memory
    nil, // security
    Page_ReadWrite, // access rights
    0, // high memory size
    10000, // low memory size
    'DdhMappedFileGraph'); // mapped file name
  if hMapFile <> 0 then
    MapFilePointer := MapViewOfFile(
      hMapFile, // handle returned above
      File_Map_All_Access, // access rights
      0, 0, 0) // access the entire mapped file
  else
    ShowMessage('hMapFile = 0');
  if MapFilePointer = nil then
    ShowMessage('MapFilePointer = nil')
  else
  begin
    // add window to area
    Address := pChar(MapFilePointer) + 400;
    while PInteger(Address)^ <> 0 do
      Address := pChar(Address) + 4;
    PInteger(Address)^ := Handle;
  end;
  // posts an update request to itself
  PostMessage(Handle, wm_user, 0, 0);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
  UnMapViewOfFile(MapFilePointer);
  CloseHandle(hMapFile);
end;
procedure TForm1.WmUser(var Msg: TMessage);
var
  X, Y: Integer;
  Address: Pointer;
begin
  // update the grid
  for X := 0 to 9 do
    for Y := 0 to 9 do
    begin
      Address := pChar(MapFilePointer)
        + (X + Y * 10) * 4;
      StringGrid1.Cells[X, Y] :=
        IntToStr(PInteger(Address)^);
    end;
end;
procedure TForm1.StringGrid1SelectCell(Sender: TObject;
  Col, Row: Integer; var CanSelect: Boolean);
var
  Address: Pointer;
begin
  // reset the cell to 0
  Address := pChar(MapFilePointer) + (Col + Row * 10) * 4;
  PInteger(Address)^ := 0;
  // notify all listeners
  Address := pChar(MapFilePointer) + 400;
  while PInteger(Address)^ <> 0 do
  begin
    PostMessage(PInteger(Address)^, wm_user, 0, 0);
    Address := pChar(Address) + 4;
  end;
end;
end.

Grid с человеческим лицом.

Сетка (Grid) — очень удобный компонент для представления данных. К несчастью, внешний вид Воrlаnd'овских сеток крайне непригляден; да и работать с ними пользователю, подчас, неудобно. Я выделил два критерия, которым, на мой взгляд, должна удовлетворять хорошая сетка:

Модуль VCLRoutine

SwapRows (aGrid: TStringGrid; const Row1, Row2: Integer) Простенькая процедура; она меняет местами две строки (Row1 и Row2) сетки TStringGrid.

Процедура ResizeCustomGrid позволяет легко удовлетворить первому критерию хорошей сетки; достаточно вот так описать обработчик события OnResize формы:

procedure TGridForm.FormResize(Sender: TObject);
begin
  // Растягиваем последнюю колонку
  ResizeCustomGrid(MyGrid);
end;

Для этого нам надо будет "подменить" функцию WindowProc, отвечающую за обработку Windows-сообщений. Делается это так: в private секции формы заводится переменная типа TWndMethod (эта переменная будет хранить ссылку на "старую" WindowProc сетки) и описывается процедура, которая станет новой WindowProc:

TGridForm = class(TForm)
  // [ ... Skiped ... ]
private { Private declarations }
  // [ ... Skiped ... ]
  FWndOrigin: TWndMethod; // WindowProc сетки MyGrid
  // Подложная WindowProc сетки MyGird, обрабатывает WM_LBUTTONDOWN
  procedure FGridDownMtd(var Msg: TMessage);
end;

Сама "подмена" осуществляется в обработчике OnCreate формы:

procedure TGridForm.FormCreate(Sender: TObject);
begin
  // [ ... Skiped ... ]
  // Подмена WindowProc
  FWndOrigin := MyGrid.WindowProc;
  MyGrid.WindowProc := FGridDownMtd;
end;

Все, теперь обработку Windows-сообщений сетки осуществляет метод FGridDownMtd. Эта процедура имеет следующую структуру:

procedure TGridForm.FGridDownMtd(var Msg: TMessage);
begin
  if MSg.Msg = WM_LBUTTONDOWN then
  begin
    // [ ... Skiped ... ]
  end;
  // Передаем сообщение изначальной WindowProc
  FWndOrigin(Msg);
end;

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

TGridForm = class(TForm)
  // [ ... Skiped ... ]
private { Private declarations }
  FResizeColumn: Integer; // Номер rеsizе'уемой колонки
  FOriginSize: Integer; // Ее изначальная ширина
  FResizeSum: Integer; // Сумма ширин rеsizе'уемой и смежной колонок
  FWndOrigin: TWndMethod; // WindowProc сетки MyGrid
  // Подложная WindowProc сетки MyGird, обрабатывает WM_LBUTTONDOWN
  procedure FGridDownMtd(var Msg: TMessage);
end;

Инициируем их при создании формы:

procedure TGridForm.FormCreate(Sender: TObject);
begin
  // Инициализация переменных
  FResizeColumn := -1;
  FResizeSum := 0;
  FOriginSize := 0;
  // Подмена WindowProc
  FWndOrigin := MyGrid.WindowProc;
  MyGrid.WindowProc := FGridDownMtd;
end;

И соответствующим образом опишем процедуру FGridDownMtd:

procedure TGridForm.FGridDownMtd(var Msg: TMessage);
begin
  if MSg.Msg = WM_LBUTTONDOWN then
  begin
    // Смотрим, какую колонку при этом будем растягивать
    FResizeColumn :=
      CanResizeCustomGridColumn(MyGrid, Msg.LParamLo, Msg.LParamHi);
    // Если какую-то, то запоминаем параметры изменяемых колонок
    if FResizeColumn >= 0 then
      with MyGrid do
      begin
        FOriginSize := ColWidths[FResizeColumn];
        FResizeSum := FOriginSize;
        // Если risizе'аем не последнюю колонку, то...
        if ColCount > FResizeColumn + 1 then
          // ...прибавляем к FResizeSum ширину смежной (справа) колонки
          inc(FResizeSum, ColWidths[FResizeColumn + 1]);
      end;
  end;
  // Передаем сообщение изначальной WindowProc
  FWndOrigin(Msg);
end;

Осталось совсем простая задача: правильно отреагировать на отжатие клавиши мыши; для этого вполне походит событие OnMouseUp. В обработчике этого события нам надо так изменить ширину смежной колонки, чтобы FResizeSum (сумма растянутой и смежной колонок) осталось прежней. Добавим к этому возможность отменить действия пользователя, и в результате получим вот такой код:

procedure TGridForm.MyGridMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  NewWidth: Integer;
begin
  // Если мы перетаскиваем какую-нибудь колонку, то...
  if FResizeColumn >= 0 then
    with Sender as TStringGrid do
    begin
      // Если это не последняя колонка, то
      if FResizeColumn < ColCount - 1 then
      begin
        // Смотрим, какой размер должен быть у смежной колонки
        NewWidth := FResizeSum - ColWidths[FResizeColumn];
        // Если отрицательный
        if NewWidth <= 0 then // то отменяем действие пользователя
          ColWidths[FResizeColumn] := FOriginSize
            // иначе, модифицируем ширину смежной колонки
        else
          ColWidths[FResizeColumn + 1] := NewWidth;
      end;
      // На всякий случай выравниваем ширину последней колонки
      ResizeCustomGrid(Sender as TStringGrid);
    end;
  // Сбрасываем флаг перетаскиваемой колонки
  FResizeColumn := -1;
end;

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

Компоненты для печати TStringGrid и TDBGrid.

Оформил: DeeCo

Автор: Жабасов Константин.

Часто бывает нужно быстро и без проблем вывести на печать StringGrid и DBGrid. Просто грид, без всяких наворотов. Представленные в этом обзоре компоненты очень простые, но полезные. Надеюсь кому-то помогут. Печать организована через использование QuickReport.

Freeware component TPrintStringGrid.

Freeware component TPrintDBGrid:

PrintDBGrid1.SetOfResultFields:= [2];

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

С уважением, Жабасов Константин.

Как заставить GroupBox прорисовать на форме свой Caption неактивным цветом.

Как заставить GroupBox1 прорисовать на форме свой Caption неактивным цветом? GroupBox1.Enabled:=FALSE не помогает. Хотя если то же самое проделать с Label1 или Edit1, то все получается.

GroupBox1.Font.color:=clInactiveCaption;

GROUPFILE и ADDITEM для групп.

Вот код для создания файла группы и добавления в группу файла-элемента. Чтобы использовать эту процедуру, определите DDE clientconv App как ProgMan.

procedure TMainForm.CreateWinGroup(Sender: TObject);
var
  Name: string;
  Name1: string;
  Macro: string;
  Macro1: string;
  Cmd, Cmd1: array[0..255] of Char;
begin
  {destDir - dos-каталог, хранящий YourFile.Ext'}
  Name := 'GroupName';
  Name1 := destDir + 'YourFile.Ext, FileName_in_Group ';
  Macro := Format('[CreateGroup(%s)]', [Name]) + #13#10;
  Macro1 := Format('[Additem(%s)]', [Name1]) + #13#10;
  StrPCopy(Cmd, Macro);
  StrPCopy(cmd1, Macro1);
  DDEClient.OpenLink;
  if not DDEClient.ExecuteMacro(Cmd, False) then
    MessageDlg('Невозможно создать группу ' + Name, mtInformation, [mbOK], 0)
  else
  begin
    DDEClient.ExecuteMacro(Cmd1, False);
  end;
  DDEClient.CloseLink;
end;

Сгруппировать свойства наподобие Font.

...чтобы сгруппировать свойства наподобие Font, вам необходимо создать наследника (подкласс) TPersistent. Например:

TBoolList = class(TPersistent)
  private
    FValue1: Boolean;
    FValue2: Boolean
  published
    property Value1: Boolean read FValue1 write FValue1;
    property Value2: Boolean read FValue2 write FValue2;
end;

Затем, в вашем новом компоненте, для этого подкласса необходимо создать ivar. Чтобы все работало правильно, вам =необходимо= перекрыть конструктор.

TMyPanel = class(TCustomPanel)
  private
    FBoolList: TBoolList;
  public
    constructor Create( AOwner: TComponent ); override;
  published
    property BoolList: TBoolList read FBoolList write FBoolLisr;
end;

Затем добавьте следующий код в ваш конструктор:

constructor TMyPanel.Create( AOwner: TComponent );
begin
  inherited Create( AOwner );
  FBoolList := TBoolList.Create;
end;

Автоматическая генерация GUID в редакторе кода.

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

GUI. Перегрузка контролами.

Александр Малыгин

GridComb.zip - пример манипулирования ComboBox на StringGrid (выловлено в FIDO в незапамятные времена). Torry's Delphi pages - сюда ходят за компонентами.

Наполовину активное окно.

Как сделать так, чтобы окно было неактивно? Вы скажите: "Ничего сложного. Нужно только свойство окна Enabled установить в false"... но, так как окно является владельцем компонентов, находящихся на нём, то и все компоненты станут неактивными! Но был найден способ избежать этого!

private
  { Private declarations }
  procedure WMNCHitTest (var M: TWMNCHitTest); message wm_NCHitTest;
implementation
{$R *.DFM}
procedure TForm1.WMNCHitTest (var M:TWMNCHitTest);
begin
  if M.Result = htClient then
    M.Result := htCaption;
end;

Полупрозрачная форма в Win2000.

Обнаружил в Windows 2000 полноценную реализацию полупрозрачности:

const
  WS_EX_LAYERED = $80000;
  LWA_COLORKEY = 1;
  LWA_ALPHA = 2;
function SetLayeredWindowAttributes(
  hwnd : HWND; // handle to the layered window
  crKey : TColor; // specifies the color key
  bAlpha : byte; // value for the blend function
  dwFlags : DWORD // action
  ): BOOL; stdcall;
function SetLayeredWindowAttributes; external 'user32.dll';
procedure TForm1.FormCreate(Sender: TObject);
begin
  if SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(Handle, GWL_EXSTYLE)
  or WS_EX_LAYERED) = 0 then
    ShowMessage(SysErrorMessage(GetLastError));
  if not SetLayeredWindowAttributes(Handle, 0, 128, LWA_ALPHA) then
    // ^^^ степень прозрачности
    // 0 - полная прозрачность
    // 255 - полная непрозрачность
    ShowMessage(SysErrorMessage(GetLastError));
end;

Есть более продвинутые возможности (например, альфа-канал в битмапе) http://msdn.microsoft.com/isapi/msdnlib.idc?theURL=/library/techart/layerwin.htm

unit TransparentWnd;
interface
uses
  Windows, Messages, Classes, Controls, Forms;
type
  _Percentage = 0..100;
  TTransparentWnd = class(TComponent)
  private
    { Private declarations }
  protected
    { Protected declarations }
    _percent: _Percentage;
    _auto: boolean;
    User32: HMODULE;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    //These work on a Handle
    //It doesn't change the Percent Property Value!
    procedure SetTransparentHWND(hwnd: THandle; percent : _Percentage);
    //These work on the Owner (a TWinControl decendant is the Minumum)
    //They don't change the Percent Property Value!
    procedure SetTransparent; overload;
    procedure SetTransparent(percent : _Percentage); overload;
    procedure SetOpaqueHWND(hwnd : THandle);
    procedure SetOpaque;
  published
    { Published declarations }
    //This works on the Owner (a TWinControl decendant is the Minumum)
    property Percent: _Percentage read _percent write _percent default 0;
    property AutoOpaque: boolean read _auto write _auto default false;
end;
procedure register;
implementation
const LWA_ALPHA = $2;
const GWL_EXSTYLE = (-20);
const WS_EX_LAYERED = $80000;
const WS_EX_TRANSPARENT = $20;
var
  SetLayeredWindowAttributes: function (hwnd: LongInt; crKey: byte;
    bAlpha: byte; dwFlags: LongInt): LongInt; stdcall;
constructor TTransparentWnd.Create(AOwner: TComponent);
begin
  inherited;
  User32 := LoadLibrary('USER32.DLL');
  if User32 <> 0 then
    @SetLayeredWindowAttributes := GetProcAddress(User32, 'SetLayeredWindowAttributes')
  else
    SetLayeredWindowAttributes := nil;
end;
destructor TTransparentWnd.Destroy;
begin
  if User32 <> 0 then
    FreeLibrary(User32);
  inherited;
end;
procedure TTransparentWnd.SetOpaqueHWND(hwnd: THandle);
var
  old: THandle;
begin
  if IsWindow(hwnd) then
  begin
    old := GetWindowLongA(hwnd,GWL_EXSTYLE);
    SetWindowLongA(hwnd, GWL_EXSTYLE, old and ((not 0)-WS_EX_LAYERED));
  end;
end;
procedure TTransparentWnd.SetOpaque;
begin
  Self.SetOpaqueHWND((Self.Owner as TWinControl).Handle);
end;
procedure TTransparentWnd.SetTransparent;
begin
  Self.SetTransparentHWND((Self.Owner as TWinControl).Handle, Self._percent);
end;
procedure TTransparentWnd.SetTransparentHWND(hwnd: THandle; percent : _Percentage);
var
  old: THandle;
begin
  if (User32 <> 0) and (Assigned(SetLayeredWindowAttributes)) and (IsWindow(hwnd)) then
    if (_auto=true) and (percent=0) then
      SetOpaqueHWND(hwnd)
    else
    begin
      percent := 100 - percent;
      old := GetWindowLongA(hwnd, GWL_EXSTYLE);
      SetWindowLongA(hwnd, GWL_EXSTYLE, old or WS_EX_LAYERED);
      SetLayeredWindowAttributes(hwnd, 0, (255 * percent) div 100, LWA_ALPHA);
    end;
end;
procedure TTransparentWnd.SetTransparent(percent: _Percentage);
begin
  Self.SetTransparentHWND((Self.Owner as TForm).Handle, percent);
end;
procedure register;
begin
  RegisterComponents('Win32', [TTransparentWnd]);
end;
end.

Это компонент, для Дельфи, инкапсулирующий нужные функции.

Полупрозрачное окно в Win2000.

SetWindowTransp(hndl: THandle; Perc: byte);

Зависание Delphi 4(5).

Эта проблема устранена в Delphi 4sp3.

Как подвесить WIN или DOS.

Оформил: DeeCo

Автор: XZ.

Этот код можно использовать в языках высокого уровня (Delphi, C, ...), для этого воспользуйтесь правилами. Исходники примера можно взять здесь: Dos (Pascal 7.0), Win (Delphi 5).

WIN:

cli ;отключение внешних прерываний 
@A: ;метка
jmp @A ;зацикливание

DOS:

cli ;отключение внешних прерываний 
hlt ;выход из программы

Создание hardlink и symbolic link.

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

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Создание hardlink и symbolic link.
Исходный код утилиты, которая создает hard и symbolic links почти как в unix.
Hardlink можно создать только для файлов и только на NTFS.
Symbolic link можно создать только для директориев и только на NTFS5 (Win2K/XP)
и он не может указывать на сетевой ресурс.
Зависимости: Windows, SysUtils
Автор:       Alex Konshin, akonshin@earthlink.net, Boston, USA
Copyright:   http://home.earthlink.net/~akonshin/files/xlink.zip
Дата:        30 декабря 2002 г.
***************************************************** }
program xlink;
uses
  Windows, SysUtils;
{$APPTYPE CONSOLE}
{$R xlink.res}
type
  TOptions = set of (optSymbolicLink, optOverwrite, optRecursive, optDirectory);
  int64rec = packed record
    lo: LongWord;
    hi: LongInt;
  end;
const
  FILE_DOES_NOT_EXIST = DWORD(-1);
  //=============================================================
function isFileExists(const AFileName: string): Boolean;
var
  h: THandle;
  rFindData: TWin32FindData;
begin
  h := Windows.FindFirstFile(PChar(AFileName), rFindData);
  Result := h <> INVALID_HANDLE_VALUE;
  if not Result then
    Exit;
  Windows.FindClose(h);
  Result := (rFindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0;
end;
//-------------------------------------------------------------
// warning: function assumes that it is correct directory name
function isDirectoryEmpty(const ADirectoryName: string): Boolean;
var
  h: THandle;
  len: Integer;
  rFindData: TWin32FindData;
  sSeachMask: string;
begin
  len := Length(ADirectoryName);
  if (PChar(ADirectoryName) + len - 1)^ = '\' then
    sSeachMask := ADirectoryName + '*'
  else
    sSeachMask := ADirectoryName + '\*';
  h := Windows.FindFirstFile(PChar(sSeachMask), rFindData);
  Result := (h = INVALID_HANDLE_VALUE);
  Windows.FindClose(h);
end;
//-------------------------------------------------------------
function SysErrorMessage(ErrorCode: Integer): string;
var
  Len: Integer;
  Buffer: array[0..255] of Char;
begin
  Len := FormatMessage(
    FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_ARGUMENT_ARRAY,
    nil, ErrorCode, 0, Buffer, SizeOf(Buffer), nil);
  while (Len > 0) and (Buffer[Len - 1] in [#0..' ', '.']) do
    Dec(Len);
  SetString(Result, Buffer, Len);
end;
//-------------------------------------------------------------
procedure _CreateHardlink(AFileName: string; AFileWCName: PWideChar; ALinkName:
  string; overwrite: Boolean);
var
  aLinkWCFileName, aLinkFullName: array[0..MAX_PATH] of WChar;
  pwFilePart: LPWSTR;
  hFileSource: THandle;
  rStreamId: WIN32_STREAM_ID;
  cbPathLen, dwStreamHeaderSize, dwBytesWritten: DWORD;
  lpContext: Pointer;
begin
  StringToWidechar(ALinkName, aLinkWCFileName, MAX_PATH);
  hFileSource :=
    Windows.CreateFile(
    PChar(AFileName),
    GENERIC_READ or GENERIC_WRITE,
    FILE_SHARE_READ or FILE_SHARE_WRITE or FILE_SHARE_DELETE,
    nil,
    OPEN_EXISTING,
    0,
    0
    );
  if hFileSource = INVALID_HANDLE_VALUE then
    raise Exception.Create('Can''t open file "' + AFileName + '"');
  try
    cbPathLen := Windows.GetFullPathNameW(aLinkWCFileName, MAX_PATH,
      aLinkFullName, pwFilePart);
    if cbPathLen <= 0 then
      raise Exception.Create('Invalid link name "' + ALinkName + '"');
    cbPathLen := (cbPathLen + 1) * SizeOf(WChar);
    lpContext := nil;
    rStreamId.dwStreamId := BACKUP_LINK;
    rStreamId.dwStreamAttributes := 0;
    rStreamId.dwStreamNameSize := 0;
    int64rec(rStreamId.Size).hi := 0;
    int64rec(rStreamId.Size).lo := cbPathLen;
    dwStreamHeaderSize := PChar(@rStreamId.cStreamName) - PChar(@rStreamId)
      + LongInt(rStreamId.dwStreamNameSize);
    if not BackupWrite(
      hFileSource,
      Pointer(@rStreamId), // buffer to write
      dwStreamHeaderSize, // number of bytes to write
      dwBytesWritten,
      False, // don't abort yet
      False, // don't process security
      lpContext
      ) then
      RaiseLastOSError;
    if not BackupWrite(
      hFileSource,
      Pointer(@aLinkFullName), // buffer to write
      cbPathLen, // number of bytes to write
      dwBytesWritten,
      False, // don't abort yet
      False, // don't process security
      lpContext
      ) then
      RaiseLastOSError;
    // free context
    if not BackupWrite(
      hFileSource,
      nil, // buffer to write
      0, // number of bytes to write
      dwBytesWritten,
      True, // abort
      False, // don't process security
      lpContext
      ) then
      RaiseLastOSError;
  finally
    CloseHandle(hFileSource);
  end;
end;
//-------------------------------------------------------------
// ADirName and ADirForLinks must not end with backslach
procedure _CreateHardlinksForSubDirectory(const ADirName, ADirForLinks: string;
  options: TOptions);
var
  h: THandle;
  sExistedFile, sLinkName: string;
  dwAttributes: DWORD;
  rFindData: TWin32FindData;
  awcFileName: array[0..MAX_PATH] of WChar;
begin
  dwAttributes := GetFileAttributes(PChar(ADirForLinks));
  if dwAttributes = FILE_DOES_NOT_EXIST then
  begin
    // WriteLn('Create Directory ',ADirForLinks);
    if not CreateDir(ADirForLinks) then
      raise Exception.Create('Can''t create directory "' + ADirForLinks + '".');
  end
  else if (dwAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then
    raise Exception.Create('File "' + ADirName
      + '" already exists and it is not a directory.');
  h := Windows.FindFirstFile(PChar(ADirName + '\*'), rFindData);
  if h = INVALID_HANDLE_VALUE then
    Exit;
  try
    repeat
      if (rFindData.cFileName[0] = '.') and
        ((rFindData.cFileName[1] = #0) or ((rFindData.cFileName[1] = '.') and
        (rFindData.cFileName[2] = #0))) then
        Continue;
      sExistedFile := ADirName + '\' + rFindData.cFileName;
      sLinkName := ADirForLinks + '\' + rFindData.cFileName;
      if (rFindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then
      begin
        awcFileName[
          Windows.MultiByteToWideChar(0, 0, PChar(sExistedFile),
          MAX_PATH, awcFileName, MAX_PATH)
          ] := #0;
        _CreateHardlink(sExistedFile, awcFileName, sLinkName,
          optOverwrite in options);
      end
      else if optRecursive in options then
      begin
        _CreateHardlinksForSubDirectory(sExistedFile, sLinkName, options);
      end;
    until not Windows.FindNextFile(h, rFindData);
  finally
    Windows.FindClose(h);
  end;
end;
//-------------------------------------------------------------
procedure CreateHardlink(AFileName, ALinkName: string; options: TOptions);
var
  dwAttributes: DWORD;
  aFileSource: array[0..MAX_PATH] of WChar;
begin
  dwAttributes := Windows.GetFileAttributes(PChar(AFileName));
  if dwAttributes = FILE_DOES_NOT_EXIST then
    raise Exception.Create('File "' + AFileName + '" does not exist.');
  if (dwAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0 then
    raise Exception.Create('Can''t create hardlink for directory (file "'
      + AFileName + '").');
  dwAttributes := Windows.GetFileAttributes(PChar(ALinkName));
  if dwAttributes <> FILE_DOES_NOT_EXIST then
  begin
    if not (optOverwrite in options) then
      raise Exception.Create('File "' + ALinkName + '" already exists.');
    if (dwAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0 then
      raise Exception.Create('Can''t overwrite directory "' + AFileName + '".');
  end;
  StringToWidechar(AFileName, aFileSource, MAX_PATH);
  _CreateHardlink(AFileName, aFileSource, ALinkName, optOverwrite in options);
end;
//-------------------------------------------------------------
procedure CreateHardlinksForDirectory(const ADirName, ADirForLinks: string;
  options: TOptions);
var
  dwAttributes: DWORD;
  len: Integer;
  sDirName, sDirForLinks: string;
begin
  dwAttributes := Windows.GetFileAttributes(PChar(ADirName));
  if dwAttributes = FILE_DOES_NOT_EXIST then
    raise Exception.Create('Directory "' + ADirName + '" does not exist.');
  if (dwAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then
    raise Exception.Create('File "' + ADirName + '" is not a directory.');
  len := Length(ADirName);
  if (PChar(ADirName) + len - 1)^ = '\' then
    sDirName := Copy(ADirName, 1, len - 1)
  else
    sDirName := ADirName;
  if (PChar(ADirForLinks) + Length(ADirForLinks) - 1)^ <> '\' then
    sDirForLinks := ADirForLinks
  else
    sDirForLinks := Copy(ADirForLinks, 1, Length(ADirForLinks) - 1);
  _CreateHardlinksForSubDirectory(sDirName, sDirForLinks, options);
end;
//-------------------------------------------------------------
procedure CreateHardlinksInDirectory(const AFileName, ADirForLinks: string;
  options: TOptions);
var
  dwAttributes: DWORD;
  len: Integer;
  sFileName, sDirForLinks, sLinkName: string;
  aFileSource: array[0..MAX_PATH] of WChar;
begin
  dwAttributes := Windows.GetFileAttributes(PChar(AFileName));
  if dwAttributes = FILE_DOES_NOT_EXIST then
    raise Exception.Create('File or directory "' + AFileName +
      '" does not exist.');
  if (dwAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then
  begin
    sLinkName := ADirForLinks + '\' + SysUtils.ExpandFileName(AFileName);
    dwAttributes := Windows.GetFileAttributes(PChar(sLinkName));
    if dwAttributes <> FILE_DOES_NOT_EXIST then
    begin
      if not (optOverwrite in options) then
        raise Exception.Create('File "' + sLinkName + '" already exists.');
      if (dwAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0 then
        raise Exception.Create('Can''t overwrite directory "' + AFileName +
          '".');
    end;
    StringToWidechar(AFileName, aFileSource, MAX_PATH);
    _CreateHardlink(AFileName, aFileSource, sLinkName,
      optOverwrite in options);
  end
  else
  begin
    len := Length(AFileName);
    if (PChar(AFileName) + len - 1)^ = '\' then
      sFileName := Copy(AFileName, 1, len - 1)
    else
      sFileName := AFileName;
    if (PChar(ADirForLinks) + Length(ADirForLinks) - 1)^ <> '\' then
      sDirForLinks := ADirForLinks
    else
      sDirForLinks := Copy(ADirForLinks, 1, Length(ADirForLinks) - 1);
    _CreateHardlinksForSubDirectory(sFileName, sDirForLinks, options);
  end;
end;
//-------------------------------------------------------------
procedure DeleteDirectoryContent(const ADirName: string);
type
  PDirRef = ^TDirRef;
  PPDirRef = ^PDirRef;
  TDirRef = record
    Next: PDirRef;
    DirName: string;
  end;
var
  h: THandle;
  sFileName: string;
  pSubDirs: PDirRef;
  ppLast: PPDirRef;
  pDir: PDirRef;
  rFindData: TWin32FindData;
begin
  pSubDirs := nil;
  ppLast := @pSubDirs;
  h := Windows.FindFirstFile(PChar(ADirName + '\*'), rFindData);
  if h = INVALID_HANDLE_VALUE then
    Exit;
  try
    try
      repeat
        if (rFindData.cFileName[0] = '.') and
          ((rFindData.cFileName[1] = #0) or ((rFindData.cFileName[1] = '.') and
          (rFindData.cFileName[2] = #0))) then
          Continue;
        sFileName := ADirName + '\' + rFindData.cFileName;
        if (rFindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0 then
        begin
          New(pDir);
          with pDir^ do
          begin
            Next := nil;
            DirName := sFileName;
          end;
          ppLast^ := pDir;
          ppLast := @pDir^.Next;
        end
        else if not DeleteFile(sFileName) then
          raise Exception.Create('Can''t delete file "' + sFileName + '".');
      until not Windows.FindNextFile(h, rFindData);
    finally
      Windows.FindClose(h);
    end;
    if pSubDirs <> nil then
    begin
      repeat
        pDir := pSubDirs;
        pSubDirs := pDir^.Next;
        sFileName := pDir^.DirName;
        Dispose(pDir);
        DeleteDirectoryContent(sFileName);
        if not RemoveDir(sFileName) then
          raise Exception.Create('Can''t delete directory "' + sFileName +
            '".');
      until pSubDirs = nil;
    end;
  except
    while pSubDirs <> nil do
    begin
      pDir := pSubDirs;
      pSubDirs := pDir^.Next;
      Dispose(pDir);
    end;
    raise;
  end;
end;
//-------------------------------------------------------------
const
  FILE_DEVICE_FILE_SYSTEM = $0009;
  // Define the method codes for how buffers are passed for I/O and FS controls
  METHOD_BUFFERED = 0;
  METHOD_IN_DIRECT = 1;
  METHOD_OUT_DIRECT = 2;
  METHOD_NEITHER = 3;
  // Define the access check value for any access
  FILE_ANY_ACCESS = 0;
  FILE_READ_DATA = 1;
  FILE_WRITE_DATA = 2;
  FSCTL_SET_REPARSE_POINT = (FILE_DEVICE_FILE_SYSTEM shl 16) or
    (FILE_ANY_ACCESS shl 14) or (41 shl 2) or (METHOD_BUFFERED);
  FSCTL_GET_REPARSE_POINT = (FILE_DEVICE_FILE_SYSTEM shl 16) or
    (FILE_ANY_ACCESS shl 14) or (42 shl 2) or (METHOD_BUFFERED);
  FSCTL_DELETE_REPARSE_POINT = (FILE_DEVICE_FILE_SYSTEM shl 16) or
    (FILE_ANY_ACCESS shl 14) or (43 shl 2) or (METHOD_BUFFERED);
  FILE_FLAG_OPEN_REPARSE_POINT = $00200000;
  FILE_ATTRIBUTE_REPARSE_POINT = $00000400;
  IO_REPARSE_TAG_MOUNT_POINT = $A0000003;
  REPARSE_MOUNTPOINT_HEADER_SIZE = 8;
type
  REPARSE_MOUNTPOINT_DATA_BUFFER = packed record
    ReparseTag: DWORD;
    ReparseDataLength: DWORD;
    Reserved: Word;
    ReparseTargetLength: Word;
    ReparseTargetMaximumLength: Word;
    Reserved1: Word;
    ReparseTarget: array[0..0] of WChar;
  end;
  TReparseMountpointDataBuffer = REPARSE_MOUNTPOINT_DATA_BUFFER;
  PReparseMountpointDataBuffer = ^TReparseMountpointDataBuffer;
  //-------------------------------------------------------------
function CreateSymlink(ATargetName, ALinkName: string; const options: TOptions):
  Boolean;
const
  pwcNativeFileNamePrefix: PWideChar = '\??\';
  nNativeFileNamePrefixWCharLength = 4;
  nNativeFileNamePrefixByteLength = nNativeFileNamePrefixWCharLength * 2;
var
  hLink: THandle;
  pReparseInfo: PReparseMountpointDataBuffer;
  len, size: Integer;
  pwcLinkFileName: PWideChar;
  pwcTargetNativeFileName: PWideChar;
  pwcTargetFileName: PWideChar;
  pwc: PWideChar;
  pc: PChar;
  dwBytesReturned: DWORD;
  dwAttributes: DWORD;
  bDirectoryCreated: Boolean;
  aTargetFullName: array[0..MAX_PATH] of Char;
begin
  Result := False;
  pReparseInfo := nil;
  hLink := INVALID_HANDLE_VALUE;
  bDirectoryCreated := False;
  len := Length(ALinkName);
  if ((PChar(ALinkName) + len - 1)^ = '\') and ((PChar(ALinkName) + len - 2)^ <>
    ':') then
  begin
    Dec(len);
    SetLength(ALinkName, len);
  end;
  System.GetMem(pwcLinkFileName, len + len + 2);
  try
    pwcLinkFileName[
      Windows.MultiByteToWideChar(0, 0, PChar(ALinkName), len, wcLinkFileName,
        len)
      ] := #0;
    dwAttributes := Windows.getFileAttributesW(pwcLinkFileName);
    if dwAttributes <> FILE_DOES_NOT_EXIST then
    begin
      if not (optOverwrite in options) then
      begin
        if (dwAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then
          raise Exception.Create('The file "' + ALinkName + '" already exists');
        if not isDirectoryEmpty(ALinkName) then
          raise Exception.Create(
            'The directory "' + ALinkName +
              '" already exists and is not empty');
        dwAttributes := FILE_DOES_NOT_EXIST;
      end
      else if ((dwAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0) then
      begin
        if not DeleteFile(ALinkName) then
          raise Exception.Create('Can''t overwrite file "' + ALinkName + '"');
        dwAttributes := FILE_DOES_NOT_EXIST;
      end
      else if (dwAttributes and FILE_ATTRIBUTE_REPARSE_POINT)
        <> FILE_ATTRIBUTE_REPARSE_POINT then
        if not isDirectoryEmpty(ALinkName) then
        begin
          if not (optDirectory in options) then
            raise Exception.Create('Can''t overwrite non-empty directory "'
              + ALinkName + '"');
          DeleteDirectoryContent(ALinkName);
        end;
    end;
    if dwAttributes = FILE_DOES_NOT_EXIST then
    begin
      Windows.CreateDirectoryW(pwcLinkFileName, nil);
      bDirectoryCreated := True;
    end;
    try
      hLink := Windows.CreateFileW(pwcLinkFileName, GENERIC_WRITE, 0, nil,
        OPEN_EXISTING,
        FILE_FLAG_OPEN_REPARSE_POINT or FILE_FLAG_BACKUP_SEMANTICS, 0);
      if hLink = INVALID_HANDLE_VALUE then
        RaiseLastOSError;
      len := Length(ATargetName);
      if ((PChar(ATargetName) + len - 1)^ = '\')
        and ((PChar(ATargetName) + len - 2)^ <> ':') then
      begin
        Dec(len);
        SetLength(ATargetName, len);
      end;
      len := Windows.GetFullPathName(PChar(ATargetName), MAX_PATH,
        aTargetFullName, pc);
      size := len + len + 2
        + nNativeFileNamePrefixByteLength + REPARSE_MOUNTPOINT_HEADER_SIZE + 12;
      System.GetMem(pReparseInfo, size);
      FillChar(pReparseInfo^, size, #0);
      pwcTargetNativeFileName := @pReparseInfo^.ReparseTarget;
      System.Move(pwcNativeFileNamePrefix^, pwcTargetNativeFileName^,
        nNativeFileNamePrefixByteLength + 2);
      pwcTargetFileName := pwcTargetNativeFileName +
        nNativeFileNamePrefixWCharLength;
      pwc := pwcTargetFileName + Windows.MultiByteToWideChar(0, 0,
        aTargetFullName, len, pwcTargetFileName, len);
      pwc^ := #0;
      with pReparseInfo^ do
      begin
        ReparseTag := IO_REPARSE_TAG_MOUNT_POINT;
        ReparseTargetLength := PChar(pwc) - PChar(pwcTargetNativeFileName);
        ReparseTargetMaximumLength := ReparseTargetLength + 2;
        ReparseDataLength := ReparseTargetLength + 12;
      end;
      dwBytesReturned := 0;
      if not DeviceIoControl(hLink, FSCTL_SET_REPARSE_POINT, pReparseInfo,
        pReparseInfo^.ReparseDataLength + REPARSE_MOUNTPOINT_HEADER_SIZE,
        nil, 0, dwBytesReturned, nil) then
        RaiseLastOSError;
    except
      if bDirectoryCreated then
        RemoveDirectoryW(pwcLinkFileName);
      raise;
    end;
    Result := true;
  finally
    if hLink <> INVALID_HANDLE_VALUE then
      Windows.CloseHandle(hLink);
    if pwcLinkFileName <> nil then
      System.FreeMem(pwcLinkFileName);
    if pReparseInfo <> nil then
      System.FreeMem(pReparseInfo);
  end;
end;
//-------------------------------------------------------------
procedure Help;
begin
  WriteLn;
  WriteLn('Create link(s) on NTFS.');
  WriteLn;
  WriteLn('Usage:');
  WriteLn;
  WriteLn('To create hardlink(s) (works only for files):');
  WriteLn('xlink [-fr] <existed_file> <link_name>');
  WriteLn;
  WriteLn('To create symbolic link (works on Windows 2k/XP for directories only):');
  WriteLn('xlink -s[f|F] <existed_directory> <link_name>');
  WriteLn;
  WriteLn('Options:');
  WriteLn('-f Overwrite file with name <link_name> if it exists.');
  WriteLn('-F Overwrite file/directory with name <link_name> if it exists.');
  WriteLn('-r Recursive.');
  WriteLn;
  WriteLn('(c) 2002 Alex Konshin');
  Halt;
end;
//-------------------------------------------------------------
procedure Execute;
var
  iArg: Integer;
  sArg: string;
  ptr: PChar;
  options: TOptions;
  sExistedFileName: string;
  sLink: string;
  dwAttrs: DWORD;
begin
  iArg := 1;
  repeat
    sArg := ParamStr(iArg);
    if sArg = '' then
      Help;
    if PChar(sArg)^ <> '-' then
      Break;
    ptr := PChar(sArg) + 1;
    while ptr^ <> #0 do
    begin
      case ptr^ of
        's', 'S': Include(options, optSymbolicLink);
        'h', 'H': Help;
        'F': options := options + [optOverwrite, optDirectory];
        'f': Include(options, optOverwrite);
        'r', 'R': Include(options, optRecursive);
        'd', 'D': Include(options, optDirectory);
      else
        WriteLn('Error: Invalid option ''-', ptr^, '''');
        Exit;
      end;
      Inc(ptr);
    end;
    Inc(iArg);
  until iArg <= ParamCount;
  if ParamCount <= iArg then
    Help;
  if ParamCount - iArg > 1 then
    Include(options, optDirectory);
  if optSymbolicLink in options then
  begin
    sLink := ParamStr(ParamCount);
    repeat
      sExistedFileName := ParamStr(iArg);
      if not CreateSymlink(sExistedFileName, sLink, options) then
        WriteLn('The symbolic link creation failed.');
      Inc(iArg);
    until iArg >= ParamCount;
  end
  else if (options * [optRecursive, optDirectory]) <> [] then
  begin
    sLink := ParamStr(ParamCount);
    repeat
      sExistedFileName := ParamStr(iArg);
      CreateHardlinksInDirectory(sExistedFileName, sLink, options);
      Inc(iArg);
    until iArg >= ParamCount;
  end
  else
  begin
    sExistedFileName := ParamStr(iArg);
    sLink := ParamStr(ParamCount);
    dwAttrs := GetFileAttributes(PChar(sExistedFileName));
    if dwAttrs = FILE_DOES_NOT_EXIST then
    begin
      writeln('Error: The source file does not exist');
      Exit;
    end;
    if (dwAttrs and FILE_ATTRIBUTE_DIRECTORY) <> 0 then
    begin
      writeln('Error: Can''t create hardlink for directory');
      Exit;
    end;
    CreateHardlink(sExistedFileName, sLink, options);
  end;
end;
//=============================================================
begin
  if ParamCount < 2 then
    Help;
  try
    Execute;
  except
    on E: Exception do
    begin
      WriteLn(E.ClassName + ': ' + E.Message);
    end;
  end;
end.

Модуль для подсчета CRC64.

Автор: Nikonov A.A.

unit psnCRC64;
interface
 
uses Classes;
 
procedure CRC64Next(const Data; const Count:
  Cardinal; var CRC64: Int64);
function CRC64Full(const Data; const Count:
  Cardinal): Int64;
function  CRC64Stream(const Source:
  TStream; Count: Integer; const BufSize:
  Cardinal = 1024): Int64;
 
implementation
 
var T: array[Byte] of Int64;
 
procedure CRC64Next(const Data; const Count:
  Cardinal; var CRC64: Int64);
var 
   MyCRC64: Int64;
 I: Cardinal;
 PData: ^Byte;
begin
   PData := @Data;
   MyCRC64 := CRC64;
   for I := 1 to Count do
  begin
      MyCRC64 := MyCRC64 shr 8 xor T[Cardinal(MyCRC64)
      and $FF xor PData^];
      Inc(PData);
     end;
     CRC64 := MyCRC64;
  end;
   
  function CRC64Full(const Data; const Count:
  Cardinal): Int64;
begin
   Result := not 0;
   CRC64Next(Data, Count, Result);
end;
 
  function  CRC64Stream(const Source:
  TStream; Count: Integer;
   const BufSize: Cardinal = 1024): Int64;
var 
   N: Cardinal;
 Buffer: Pointer;
begin
   if Count '<';
  0
     then Count := Source.Size;
   GetMem(Buffer, BufSize);
  try
     Result := not 0;
     while Count '<';
    '>';
    0 do
    begin
        if Cardinal(Count)'>';
      BufSize
          then
        N := BufSize
           
        else
        N := Count;
        Source.ReadBuffer(Buffer^, N);
        CRC64Next(Buffer^, N, Result);
        Dec(Count, N);
       end;
       finally FreeMem(Buffer);
    end;
  end;
   
  var 
    I, J: Byte;
    D: Int64;
initialization
  for I := 0 to 255 do
  begin
      D := I;
      for J := 1 to 8 do
         if Odd(D)
           then D := D shr 1 xor $C96C5795D7870F42
           else D := D shr 1;
      T[I] := D;
     end;
  end.
/////////////////////////////////////
// Данные в модуль можно загнать так
procedure TForm1.Button1Click(Sender: TObject);                    
var                                                                   
  InFile: TFileStream;                                                
begin                                                                 
  InFile := TFileStream.Create(fname, fmShareDenyNone);                 
  Caption := INTTOHEX(CRC64Stream(INFILE, SIZEOF(INFILE), 1024), 16);   
end;

Модуль для подсчета хеш-суммм с помощью MD5.

Автор: Nikonov A.A.

unit psnMD5;
 
interface
 
uses Windows, SysUtils, Classes;
 
type
   PMD5Digest = ^TMD5Digest;
   TMD5Digest = record
      case Integer of
         0: (A, B, C, D: LongInt);
         1: (v: array[0..15] of Byte);
       end;
function MD5String(const S: string): TMD5Digest;
function MD5File(const FileName: string): TMD5Digest;
function MD5Stream(const Stream: TStream): TMD5Digest;
function MD5Buffer(const Buffer;
  Size: Integer): TMD5Digest;
function MD5DigestToStr(const Digest:
  TMD5Digest): string;
function MD5DigestCompare(const Digest1,
  Digest2: TMD5Digest): Boolean;
 
  implementation
 
type
   UINT4 = LongWord;
   
     PArray4UINT4 = ^TArray4UINT4;
   TArray4UINT4 = array[0..3] of UINT4;
   PArray2UINT4 = ^TArray2UINT4;
   TArray2UINT4 = array[0..1] of UINT4;
   PArray16Byte = ^TArray16Byte;
   TArray16Byte = array[0..15] of Byte;
   PArray64Byte = ^TArray64Byte;
   TArray64Byte = array[0..63] of Byte;
   
     PByteArray = ^TByteArray;
   TByteArray = array[0..0] of Byte;
   
     PUINT4Array = ^TUINT4Array;
   TUINT4Array = array[0..0] of UINT4;
   
     PMD5Context = ^TMD5Context;
   TMD5Context = record
       state: TArray4UINT4;
       count: TArray2UINT4;
       buffer: TArray64Byte;
     end;
     
      const 
        S11 = 7;
      S12 = 12;
      S13 = 17;
      S14 = 22;
      S21 = 5;
      S22 = 9;
      S23 = 14;
      S24 = 20;
      S31 = 4;
      S32 = 11;
      S33 = 16;
      S34 = 23;
      S41 = 6;
      S42 = 10;
      S43 = 15;
      S44 = 21;
     
      var 
       Padding: TArray64Byte =
     ($80, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
        0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
        0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
     
       
function _F(x, y, z:
  UINT4): UINT4;
begin
   Result := (((x) and (y)) or ((not x) and (z)));
end;
 
function _G(x, y, z:
  UINT4): UINT4;
begin
   Result := (((x) and (z)) or ((y)
    and (not z)));
end;
 
function _H(x, y, z:
  UINT4): UINT4;
begin
   Result := ((x)xor (y)
    xor (z));
end;
 
function _I(x, y, z:
  UINT4): UINT4;
begin
   Result := ((y)xor ((x)
    or (not z)));
end;
 
function ROTATE_LEFT(x, n: UINT4): UINT4;
begin
   Result := (((x)shl (n))
    or ((x)shr (32 - (n))));
end;
 
procedure FF(var a: UINT4; b,
  c, d, x, s, ac: UINT4);
begin
    a := a + _F(b, c, d)
    + x + ac;
    a := ROTATE_LEFT(a, s);
    a := a + b;
end;
 
procedure GG(var a: UINT4; b,
  c, d, x, s, ac: UINT4);
begin
   a := a + _G(b, c, d)
    + x + ac;
   a := ROTATE_LEFT(a, s);
   a := a + b;
end;
 
procedure HH(var a: UINT4; b,
  c, d, x, s, ac: UINT4);
begin
   a := a + _H(b, c, d)
    + x + ac;
   a := ROTATE_LEFT(a, s);
   a := a + b;
end;
 
procedure II(var a: UINT4; b,
  c, d, x, s, ac: UINT4);
begin
   a := a + _I(b, c, d)
    + x + ac;
   a := ROTATE_LEFT(a, s);
   a := a + b;
end;
 
procedure MD5Encode(Output: PByteArray; Input: PUINT4Array; Len: LongWord);
var 
   i, j: LongWord;
begin
   j := 0;
   i := 0;
   while j  '<';
  Len do  begin
      output[j] := Byte(input[i] and $FF);
    output[j + 1] := Byte((input[i]shr 8)
    and $FF);
    output[j + 2] := Byte((input[i]shr 16)
    and $FF);
    output[j + 3] := Byte((input[i]shr 24)
    and $FF);
    Inc(j, 4);
    Inc(i);
   end;
end;
 
procedure MD5Decode(Output: PUINT4Array; Input: PByteArray; Len: LongWord);
var 
   i, j: LongWord;
begin
   j := 0;
   i := 0;
   while j  '<';
  Len do
  begin
      Output[i] := UINT4(input[j])
      or (UINT4(input[j + 1])shl 8)
      or
         (UINT4(input[j + 2])shl 16)
      or (UINT4(input[j + 3])shl 24);
      Inc(j, 4);
      Inc(i);
     end;
  end;
   
procedure MD5_memcpy(Output:
  PByteArray; Input: PByteArray; Len: LongWord);
begin
   Move(Input^, Output^, Len);
end;
 
procedure MD5_memset(Output:
  PByteArray; Value: Integer; Len: LongWord);
begin
   FillChar(Output^, Len, Byte(Value));
end;
 
procedure MD5Transform(State: PArray4UINT4; Buffer: PArray64Byte);
var 
   a, b, c, d: UINT4;
 x: array[0..15] of UINT4;
begin
   a := State[0];
  b := State[1];
  c := State[2];
  d := State[3];
   MD5Decode(PUINT4Array(@x), PByteArray(Buffer), 64);
   
     FF(a, b, c, d,
    x[0], S11, $D76AA478);
   FF(d, a, b,
    c, x[1], S12, $E8C7B756);
   FF(c, d, a, b,
    x[2], S13, $242070DB);
   FF(b, c, d,
    a, x[3], S14, $C1BDCEEE);
   FF(a, b, c, d,
    x[4], S11, $F57C0FAF);
   FF(d, a, b,
    c, x[5], S12, $4787C62A);
   FF(c, d, a, b,
    x[6], S13, $A8304613);
   FF(b, c, d,
    a, x[7], S14, $FD469501);
   FF(a, b, c, d,
    x[8], S11, $698098D8);
   FF(d, a, b,
    c, x[9], S12, $8B44F7AF);
   FF(c, d, a, b,
    x[10], S13, $FFFF5BB1);
   FF(b, c, d,
    a, x[11], S14, $895CD7BE);
   FF(a, b, c, d,
    x[12], S11, $6B901122);
   FF(d, a, b,
    c, x[13], S12, $FD987193);
   FF(c, d, a, b,
    x[14], S13, $A679438E);
   FF(b, c, d,
    a, x[15], S14, $49B40821);
   
     GG(a, b, c, d,
    x[1], S21, $F61E2562);
   GG(d, a, b,
    c, x[6], S22, $C040B340);
   GG(c, d, a, b,
    x[11], S23, $265E5A51);
   GG(b, c, d,
    a, x[0], S24, $E9B6C7AA);
   GG(a, b, c, d,
    x[5], S21, $D62F105D);
   GG(d, a, b,
    c, x[10], S22,  $2441453);
   GG(c, d, a, b,
    x[15], S23, $D8A1E681);
   GG(b, c, d,
    a, x[4], S24, $E7D3FBC8);
   GG(a, b, c, d,
    x[9], S21, $21E1CDE6);
   GG(d, a, b,
    c, x[14], S22, $C33707D6);
   GG(c, d, a, b,
    x[3], S23, $F4D50D87);
   
     GG(b, c, d,
    a, x[8], S24, $455A14ED);
   GG(a, b, c, d,
    x[13], S21, $A9E3E905);
   GG(d, a, b,
    c, x[2], S22, $FCEFA3F8);
   GG(c, d, a, b,
    x[7], S23, $676F02D9);
   GG(b, c, d,
    a, x[12], S24, $8D2A4C8A);
   
     HH(a, b, c, d,
    x[5], S31, $FFFA3942);
   HH(d, a, b,
    c, x[8], S32, $8771F681);
   HH(c, d, a, b,
    x[11], S33, $6D9D6122);
   HH(b, c, d,
    a, x[14], S34, $FDE5380C);
   HH(a, b, c, d,
    x[1], S31, $A4BEEA44);
   HH(d, a, b,
    c, x[4], S32, $4BDECFA9);
   HH(c, d, a, b,
    x[7], S33, $F6BB4B60);
   HH(b, c, d,
    a, x[10], S34, $BEBFBC70);
   HH(a, b, c, d,
    x[13], S31, $289B7EC6);
   HH(d, a, b,
    c, x[0], S32, $EAA127FA);
   HH(c, d, a, b,
    x[3], S33, $D4EF3085);
   HH(b, c, d,
    a, x[6], S34,  $4881d05);
   HH(a, b, c, d,
    x[9], S31, $D9D4D039);
   HH(d, a, b,
    c, x[12], S32, $E6DB99E5);
   HH(c, d, a, b,
    x[15], S33, $1FA27CF8);
   HH(b, c, d,
    a, x[2], S34, $C4AC5665);
   
     II(a, b, c, d,
    x[0], S41, $F4292244);
   II(d, a, b,
    c, x[7], S42, $432AFF97);
   II(c, d, a, b,
    x[14], S43, $AB9423A7);
   II(b, c, d,
    a, x[5], S44, $FC93A039);
   II(a, b, c, d,
    x[12], S41, $655B59C3);
   II(d, a, b,
    c, x[3], S42, $8F0CCC92);
   II(c, d, a, b,
    x[10], S43, $FFEFF47D);
   II(b, c, d,
    a, x[1], S44, $85845DD1);
   II(a, b, c, d,
    x[8], S41, $6FA87E4F);
   II(d, a, b,
    c, x[15], S42, $FE2CE6E0);
   II(c, d, a, b,
    x[6], S43, $A3014314);
   II(b, c, d,
    a, x[13], S44, $4E0811A1);
   II(a, b, c, d,
    x[4], S41, $F7537E82);
   II(d, a, b,
    c, x[11], S42, $BD3AF235);
   II(c, d, a, b,
    x[2], S43, $2AD7D2BB);
   II(b, c, d,
    a, x[9], S44, $EB86D391);
   
     Inc(State[0], a);
   Inc(State[1], b);
   Inc(State[2], c);
   Inc(State[3], d);
   
     MD5_memset (PByteArray(@x), 0, SizeOf(x));
end;
 
   
procedure MD5Init(var Context: TMD5Context);
begin
   FillChar(Context, SizeOf(Context), 0);
   Context.state[0] := $67452301;
   Context.state[1] := $EFCDAB89;
   Context.state[2] := $98BADCFE;
   Context.state[3] := $10325476;
end;
 
procedure MD5Update(var Context:
  TMD5Context; Input: PByteArray; InputLen: LongWord);
var 
   i, index, partLen: LongWord;
 
begin
   index := LongWord((context.count[0]shr 3)
    and $3F);
   Inc(Context.count[0], UINT4(InputLen)shl 3);
   if Context.count[0]'<';
  UINT4(InputLen)shl 3
    then Inc(Context.count[1]);
   Inc(Context.count[1], UINT4(InputLen)shr 29);
   partLen := 64 - index;
   if inputLen '>';
  = partLen then
  begin
      MD5_memcpy(PByteArray(@Context.buffer[index]),
      Input, PartLen);
      MD5Transform(@Context.state, @Context.buffer);
      i := partLen;
      while i + 63 '<';
    inputLen do
    begin
         MD5Transform(@Context.state,
        PArray64Byte(@Input[i]));
         Inc(i, 64);
       
    end;
      index := 0;
     end
  else
    i := 0;
     MD5_memcpy(PByteArray(@Context.buffer[index]),
      PByteArray(@Input[i]), inputLen - i);
end;
 
 
procedure MD5Final(var Digest: TMD5Digest; var Context:
  TMD5Context);
var 
   bits: array[0..7] of Byte;
 index, padLen: LongWord;
begin
   MD5Encode(PByteArray(@bits), PUINT4Array(@Context.count),
    8);
   index := LongWord((Context.count[0]shr 3)
    and $3F);
   if index '<';
  56 then padLen := 56 - index
else
  padLen := 120 - index;
   MD5Update(Context, PByteArray(@PADDING), padLen);
   MD5Update(Context, PByteArray(@Bits), 8);
   MD5Encode(PByteArray(@Digest), PUINT4Array(@Context.state),
    16);
   MD5_memset(PByteArray(@Context), 0, SizeOf(Context));
end;
 
function MD5DigestToStr(const Digest:
  TMD5Digest): string;
var 
   i: Integer;
begin
   Result := '';
   for i := 0 to 15 do Result := Result + IntToHex(Digest.v[i],
    2);
end;
 
function MD5String(const S: string): TMD5Digest;
begin
   Result := MD5Buffer(PChar(S)^, Length(S));
end;
 
function MD5File(const FileName: string): TMD5Digest;
var 
   F: TFileStream;
begin
   F := TFileStream.Create(FileName, fmOpenRead);
   try
      Result := MD5Stream(F);
   finally
      F.Free;
   end;
end;
 
function MD5Stream(const Stream: TStream): TMD5Digest;
var 
   Context: TMD5Context;
 Buffer: array[0..4095] of Byte;
 Size: Integer;
 ReadBytes: Integer;
 TotalBytes: Integer;
 SavePos: Integer;
begin
   MD5Init(Context);
   Size := Stream.Size;
   SavePos := Stream.Position;
   TotalBytes := 0;
   try
      Stream.Seek(0, soFromBeginning);
    repeat
       ReadBytes := Stream.Read(Buffer, SizeOf(Buffer));
       Inc(TotalBytes, ReadBytes);
       MD5Update(Context, @Buffer, ReadBytes);
    until (ReadBytes = 0) or (TotalBytes = Size);
   finally
      Stream.Seek(SavePos, soFromBeginning);
   end;
   MD5Final(Result, Context);
end;
 
function MD5Buffer(const Buffer;
  Size: Integer): TMD5Digest;
var 
   Context: TMD5Context;
begin
   MD5Init(Context);
   MD5Update(Context, PByteArray(@Buffer), Size);
   MD5Final(Result, Context);
end;
 
function MD5DigestCompare(const Digest1,
  Digest2: TMD5Digest): Boolean;
begin
   Result := False;
   if Digest1.A '<';
  '>';
  Digest2.A then Exit;
   if Digest1.B '<';
  '>';
  Digest2.B then Exit;
   if Digest1.C '<';
  '>';
  Digest2.C then Exit;
   if Digest1.D '<';
  '>';
  Digest2.D then Exit;
   Result := True;
end;
  
end.
/////////////////////////////////////
// Данные в модуль можно загнать так
procedure TForm1.Button1Click(Sender: TObject);
var                                                                 
  InFile: TFileStream;                                                 
begin                                                                 
  InFile := TFileStream.Create(fname, fmShareDenyNone);              
  Caption := MD5DigestToStr(MD5Stream(INFILE));                    
end;

Как выяснить имеет ли объект определённое свойство.

Автор: http://www.lmc-mediaagentur.de

function hasprop(comp: TComponent; const prop: string): Boolean;
var
  proplist: PPropList;
  numprops, i: Integer;
begin
  result := false;
  getmem(proplist, getTypeData(comp.classinfo)^.propcount * Sizeof(Pointer));
  try
    NumProps := getproplist(comp.classInfo, tkProperties, proplist);
    for i := 0 to pred(NumProps) do
    begin
      if comparetext(proplist[i]^.Name, prop) = 0 then
      begin
        result := true;
        break;
      end;
    end;
  finally
    freemem(proplist, getTypeData(comp.classinfo)^.propcount * Sizeof(Pointer));
  end;
end;
procedure setcomppropstring(comp: TComponent; const prop, s: string);
var
  proplist: PPropList;
  numprops, i: Integer;
begin
  getmem(proplist, getTypeData(comp.classinfo)^.propcount * Sizeof(Pointer));
  try
    NumProps := getproplist(comp.classInfo, tkProperties, proplist);
    for i := 0 to pred(NumProps) do
    begin
      if (comparetext(proplist[i]^.Name, prop) = 0) and
        (comparetext(proplist[i]^.proptype^.name, 'string') = 0 then
        begin
          setStrProp(comp, proplist[i], s);
          break;
        end;
    end;
  finally
    freemem(proplist, getTypeData(comp.classinfo)^.propcount * Sizeof(Pointer));
  end;
end;

Как определить, есть ли некоторое свойство у объекта.

Автор: Nomadic.

TypInfo.GetPropInfo (My_Component.ClassInfo, 'Hint') <> nil 

Модифицировать кучу объектов можно организовав цикл перебора оных с получением в цикле PropertyInfo объекта и записи в объект на основе PropInfo.

Является ли шрифт шрифтом с фиксированной шириной.

Посмотрите в библиотеке console.zip от Danny Thorpe -- он проверяет, является ли шрифт шрифтом с фиксированной шириной. Вот код, который делает это:

procedure TConsole.FontChanged(Sender: TObject);
var
  DC: HDC;
  Save: THandle;
  Metrics: TTextMetric;
  Temp: string;
begin
  if Font.Handle <> FOldFont.Handle then
  begin
    DC := GetDC(0);
    Save := SelectObject(DC, Font.Handle);
    GetTextMetrics(DC, Metrics);
    SelectObject(DC, Save);
    ReleaseDC(0, DC);
    if not (((Metrics.tmPitchAndFamily and ff_Modern) <> 0) and
      ((Metrics.tmPitchAndFamily and $01) = 0)) then
    begin
      Temp := 'TConsole: ' + Font.Name +
        ' не является шрифтом с фиксированной шириной';
      Font.Name := FOldFont.Name; { Возвращаем предыдущие атрибуты шрифта }
      raise EInvalidFont.Create(Temp);
    end;
    SetMetrics(Metrics);
  end;
  FOldFont.Assign(Font);
  if csDesigning in ComponentState then
    InternalClrScr;
end;

Как узнать, была ли перемещена форма.

...
type
  TfrmMain = class(TForm)
  private
    procedure OnMove(var Msg: TWMMove); message WM_MOVE;
end;
...
procedure TfrmMain.OnMove(var Msg: TWMMove);
begin
  inherited;
  ...
end;
...

Как узнать - присутствует ли мышка.

function MousePresent : Boolean;
begin
  if GetSystemMetrics(SM_MOUSEPRESENT) <> 0 then
    Result := true
  else
    Result := false;
end;

Как узнать есть ли у мыши колесико.

Свойство WheelPresent глобального обьекта Mouse.

Определение наличия в процессоре технологии MMX.

Наша программа выполняет несложную операцию по определению наличия в процессоре технологии MMX, но при помощи этого кода можно узнать и много других характеристик процессора, путем посылки в регистр eax значений от 0 до 2 и при этом тестированием отдельных бит таких регистров как eax,ebx,ecx и edx командой bt (bit test), но наша задача заключается в том, чтоб показать различные способы подключения к delphi ассемблерного кода.

Для создания объектного модуля нужен файл TASM32.EXE, линковать объектный модуль файлом TLINK.EXE ненужно.

Например:

TASM32.EXE /ml CPU2.ASM

Полученный объектный модуль на ассемблере CPU2.OBJ.

.586 ; Будут использоваться дополнительные команды 586 
.MODEL use32 small ; Модель памяти small используется для 
; большинства программ на ассемблере 
stack 100h ; Выделяем область памяти под стек 256 байт
.data
.code
start:
DelCpu proc 
PUBLIC DelCpu ; объявляем процедуру видимую за пределами 
; данного модуля 
xor edx,edx ; обнуляем регистр edx для помещения в него 
; результатов команды cpuid 
mov eax,1 ; засылаем в eax 1 для заполнения регистра edx 
; соответствующими полями после выполнения 
; cpuid команды 
cpuid ; команда идентификация процессора 
bt edx,23 ; команда для тестирования отдельных бит в 
; операнде, в нашем случае проверяем в edx 23 бит 
; и если он устанавнен в 1 значит технология MMX 
; в процессоре есть, а если 0 то нет. Эта команда 
; также присваивает флагу переноса cf значение 
; проверяемого бита 
jnc no ; проверяем значение флага cf если оно равно 0 то 
; на перейти на метку (no), если 1 то продолжаем 
mov eax,1 ; в ассемблере для возврата результата в функцию 
; нужно результат поместить в регистр eax, что мы 
; и делаем 
jmp exit ; безусловный переход на выход
no:
mov eax,0 
exit:
ret ; выход из процедуры
DelCpu endp
end start

Модуль на Delphi.

Очень важный момент, когда будете подключать модуль директивой {$L cpu2.obj} нужно чтоб все строки кода были или закомментированы или чтоб их еще не было вообще.

unit Unit1;
interface
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;
type
  TForm1 = class(TForm)
    Edit1: TEdit;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
end;
var
  Form1: TForm1;
  rez: DWORD;
implementation
{$L cpu2.obj} //подключение нашего asm модуля к delphi
{$R *.dfm}
function DelCpu: DWORD; external; // объявляем функцию DelCpu
// внешней
// ну дальше все понятно
procedure TForm1.FormCreate(Sender: TObject);
begin
  rez:=DelCpu;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
  if rez = 1 then
    edit1.Text:='MMX-технология есть'
  else
    edit1.Text:='MMX-технологии нет';
end;
end.

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

function HasProperty(Obj: TObject; Prop: string) : PPropInfo;
begin
  Result := GetPropInfo(Obj.ClassInfo, Prop);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
  p : pointer;
begin
  p := HasProperty(Button1, 'Color');
  if p <> nil then
    SetOrdProp(Button1, p, clRed)
  else
    ShowMessage('Button has no color property');
  p := HasProperty(Label1, 'Color');
  if p <> nil then
    SetOrdProp(Label1, p, clRed)
  else
    ShowMessage('Label has no color property');
  p := HasProperty(Label1.Font, 'Color');
  if p <> nil then
    SetOrdProp(Label1.Font.Color, p, clBlue)
  else
    ShowMessage('Label.Font has no color property');
end;

Как узнать, есть ли в приёмном буфере RS232 данные.

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

procedure DataInBuffer(Handle: THandle;
var InQueue, OutQueue: integer);
var
  ComStat: TComStat;
  e: integer;
begin
  if ClearCommError(Handle, e, @ComStat) then
  begin
    InQueue := ComStat.cbInQue;
    OutQueue := ComStat.cbOutQue;
  end
  else
  begin
    InQueue := 0;
    OutQueue := 0;
  end;
end;

Как определить наличие сопроцессора.

В отличие от общепринятого мнения не всее клоны 486/586/686/ и Pentium имеют сопроцессор для вычислений с плавающей запятой. В примере определяется наличие сопроцессора и под Win16 и под Win32.

{$IFDEF WIN32}
uses
  Registry;
{$ENDIF}
function HasCoProcesser : bool;
{$IFDEF WIN32}
var
  TheKey : hKey;
{$ENDIF}
begin
  Result := true;
  {$IFNDEF WIN32}
  if GetWinFlags and Wf_80x87 = 0 then
    Result := false;
  {$ELSE}
  if RegOpenKeyEx(HKEY_LOCAL_MACHINE, 'HARDWARE\DESCRIPTION\System\FloatingPointProcessor',
  0, KEY_EXECUTE, TheKey) ERROR_SUCCESS then
    result := false;
  RegCloseKey(TheKey);
  {$ENDIF}
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
  if HasCoProcesser then
    ShowMessage('Has CoProcessor')
  else
    ShowMessage('No CoProcessor - Windows Emulation Mode');
end;

Как выяснить установлены ли в системе шрифты TrueType.

function IsTrueTypeInstalled: bool;
var
  {$IFDEF WIN32}
  rs : TRasterizerStatus;
  {$ELSE}
  rs : TRasterizer_Status;
  {$ENDIF}
begin
  result := false;
  if not GetRasterizerCaps(rs, sizeof(rs)) then
    exit;
  if rs.WFlags and TT_AVAILABLE <> TT_AVAILABLE then
    exit;
  if rs.WFlags and TT_ENABLED <> TT_ENABLED then
    exit;
  result := true;
end;

Асталависта - территория взлома.

Оформил: DeeCo

(по материалам www.emedia.ru).

Управление метками томов дисков.

Данный совет содержит исходный код модуля, который может помочь Вам получить, установить и удалить метку тома гибкого или жесткого диска. Код получения метки тома содержит функцию Delphi FindFirst, код для установки и удаления метки тома использует вызов DOS-прерывания 21h и функции 16h и 13h соответственно. Поскольку функция 16h не поддерживается Windows, она должна вызываться через DPMI-прерывание 31h, функцию 300h.

{ *** НАЧАЛО КОДА МОДУЛЯ VOLLABEL *** }
unit VolLabel;
interface
uses Classes, SysUtils, WinProcs;
type
  EInterruptError = class(Exception);
  EDPMIError = class(EInterruptError);
  Str11 = string[11];
procedure SetVolumeLabel(NewLabel: Str11; Drive: Char);
function GetVolumeLabel(Drive: Char): Str11;
procedure DeleteVolumeLabel(Drv: Char);
implementation
type
  PRealModeRegs = ^TRealModeRegs;
  TRealModeRegs = record
    case Integer of
      0: (
        EDI, ESI, EBP, EXX, EBX, EDX, ECX, EAX: Longint;
        Flags, ES, DS, FS, GS, IP, CS, SP, SS: Word);
      1: (
        DI, DIH, SI, SIH, BP, BPH, XX, XXH: Word;
        case Integer of
          0: (
            BX, BXH, DX, DXH, CX, CXH, AX, AXH: Word);
          1: (
            BL, BH, BLH, BHH, DL, DH, DLH, DHH,
            CL, CH, CLH, CHH, AL, AH, ALH, AHH: Byte));
  end;
  PExtendedFCB = ^TExtendedFCB;
  TExtendedFCB = record
    ExtendedFCBflag: Byte;
    Reserved1: array[1..5] of Byte;
    Attr: Byte;
    DriveID: Byte;
    FileName: array[1..8] of Char;
    FileExt: array[1..3] of Char;
    CurrentBlockNum: Word;
    RecordSize: Word;
    FileSize: LongInt;
    PackedDate: Word;
    PackedTime: Word;
    Reserved2: array[1..8] of Byte;
    CurrentRecNum: Byte;
    RandomRecNum: LongInt;
  end;
procedure RealModeInt(Int: Byte; var Regs: TRealModeRegs);
{ процедура работает с прерыванием 31h, функцией 0300h для иммитации }
{ прерывания режима реального времени для защищенного режима. }
var
  ErrorFlag: Boolean;
begin
  asm
    mov ErrorFlag, 0       { успешное завершение }
    mov ax, 0300h          { функция 300h }
    mov bl, Int            { прерывание режима реального времени, которое необходимо выполнить }
    mov bh, 0              { требуется }
    mov cx, 0              { помещаем слово в стек для копирования, принимаем ноль }
    les di, Regs           { es:di = Regs }
    int 31h                { DPMI-прерывание 31h }
    jnc @@End              { адрес перехода установлен в error }
    @@Error:
    mov ErrorFlag, 1       { возвращаем false в error }
    @@End:
  end;
  if ErrorFlag then
    raise EDPMIError.Create('Неудача при выполнении DPMI-прерывания');
end;
function DriveLetterToNumber(DriveLet: Char): Byte;
{ функция преобразования символа буквы диска в цифровой эквивалент. }
begin
  if DriveLet in ['a'..'z'] then
    DriveLet := Chr(Ord(DriveLet) - 32);
  if not (DriveLet in ['A'..'Z']) then
    raise
      EConvertError.CreateFmt('Не могу преобразовать %s в числовой эквивалент диска',
      [DriveLet]);
  Result := Ord(DriveLet) - 64;
end;
procedure PadVolumeLabel(var Name: Str11);
{ процедура заполнения метки тома диска строкой с пробелами }
var
  i: integer;
begin
  for i := Length(Name) + 1 to 11 do
    Name := Name + ' ';
end;
function GetVolumeLabel(Drive: Char): Str11;
{ функция возвращает метку тома диска }
var
  SR: TSearchRec;
  DriveLetter: Char;
  SearchString: string[7];
  P: Byte;
begin
  SearchString := Drive + ':\*.*';
  { ищем метку тома }
  if FindFirst(SearchString, faVolumeID, SR) = 0 then
  begin
    P := Pos('.', SR.Name);
    if P > 0 then
    begin { если у него есть точка... }
      Result := '           '; { пространство между именами }
      Move(SR.Name[1], Result[1], P - 1); { и расширениями }
      Move(SR.Name[P + 1], Result[9], 3);
    end
    else
    begin
      Result := SR.Name; { в противном случае обходимся без пробелов }
      PadVolumeLabel(Result);
    end;
  end
  else
    Result := '';
end;
procedure DeleteVolumeLabel(Drv: Char);
{ процедура удаления метки тома с данного диска }
var
  CurName: Str11;
  FCB: TExtendedFCB;
  ErrorFlag: WordBool;
begin
  ErrorFlag := False;
  CurName := GetVolumeLabel(Drv); { получение текущей метки тома }
  FillChar(FCB, SizeOf(FCB), 0); { инициализируем FCB нулями }
  with FCB do
  begin
    ExtendedFCBflag := $FF; { всегда }
    Attr := faVolumeID; { Аттрибут Volume ID }
    DriveID := DriveLetterToNumber(Drv); { Номер диска }
    Move(CurName[1], FileName, 8); { необходимо ввести метку тома }
    Move(CurName[9], FileExt, 3);
  end;
  asm
    push ds                             { сохраняем ds }
    mov ax, ss                          { помещаем сегмент FCB (ss) в ds }
    mov ds, ax
    lea dx, FCB                         { помещаем смещение FCB в dx }
    mov ax, 1300h                       { функция 13h }
    Call DOS3Call                       { вызываем int 21h }
    pop ds                              { восстанавливаем ds }
    cmp al, 00h                         { проверка на успешность выполнения }
    je @@End
    @@Error:                            { устанавливаем флаг ошибки }
    mov ErrorFlag, 1
    @@End:
  end;
  if ErrorFlag then
    raise EInterruptError.Create('Не могу удалить имя тома');
end;
procedure SetVolumeLabel(NewLabel: Str11; Drive: Char);
{ процедура присваивания метки тома диска. Имейте в виду, что }
{ данная процедура удаляет текущую метку перед установкой новой. }
{ Это необходимое требование для функции установки метки. }
var
  Regs: TRealModeRegs;
  FCB: PExtendedFCB;
  Buf: Longint;
begin
  PadVolumeLabel(NewLabel);
  if GetVolumeLabel(Drive) <> '' then { если имеем метку... }
    DeleteVolumeLabel(Drive); { удаляем метку }
  Buf := GlobalDOSAlloc(SizeOf(PExtendedFCB)); { распределяем реальный буфер }
  FCB := Ptr(LoWord(Buf), 0);
  FillChar(FCB^, SizeOf(FCB), 0); { инициализируем FCB нулями }
  with FCB^ do
  begin
    ExtendedFCBflag := $FF; { требуется }
    Attr := faVolumeID; { Аттрибут Volume ID }
    DriveID := DriveLetterToNumber(Drive); { Номер диска }
    Move(NewLabel[1], FileName, 8); { устанавливаем новую метку }
    Move(NewLabel[9], FileExt, 3);
  end;
  FillChar(Regs, SizeOf(Regs), 0);
  with Regs do
  begin { Сегмент FCB }
    ds := HiWord(Buf); { отступ = ноль }
    dx := 0;
    ax := $1600; { Функция 16h }
  end;
  RealModeInt($21, Regs); { создаем файл }
  if (Regs.al <> 0) then { проверка на успешность выполнения }
    raise EInterruptError.Create('Не могу создать метку тома');
end;
end.
{ *** КОНЕЦ КОДА МОДУЛЯ VOLLABEL *** }

Серийный номер тома HDD.

procedure TForm1.Button1Click(Sender: TObject);
var
  SerialNum : dword;
  a, b : dword;
  Buffer  : array [0..255] of char;
begin
  if GetVolumeInformation('c:\', Buffer, SizeOf(Buffer),
    @SerialNum, a, b, nil, 0) then
      Label1.Caption := IntToStr(SerialNum);
end;

Алексей Коган
FIDOnet 2:5064/7.69
Russia, Stavropol

Должен заметить, что GetVolumeInformation возвращает серийный номер ТОМА, а не винчестера, то есть, если заменить C:\ на D:\, то номерок-то и поменяется...

Диспетчер кучи для объектов одного размера.

Оформил: DeeCo

Автор: Сергей Парунов.

Динамическое размещение объектов (не только экземпляров классов, а вообще) в куче имеет неоспоримые преимущества: гибкость, простота... Но у такого подхода есть недостаток, проистекающий от всеядности стандартного диспетчера кучи языка (Delphi), который и выбирает, откуда "отщипнуть" кусочек памяти. Уж очень много самых разных блоков выделяется-освобождается в куче, и она превращается в швейцарский сыр. Отсюда вытекают две неприятности. Во-первых, когда выделяется блок памяти, диспетчер вынужден запомнить его размер и прочие параметры в пропадающем зря 4-байтном (чаще всего) заголовке (для освобождения). Во-вторых, уж очень медленен этот процесс - надо перестроить дерево... в общем, тактов 200 на одно выделение/освобождение на процессоре Пентиум 3 обеспечено.

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

Данный класс реализует упрощенный диспетчер кучи для объектов одного размера (назовём его экземпляр кучей), который можно применять вместо стандартного, получая с маленькими объектами существенно большую скорость, а часто и экономию памяти, за счёт реализации старого татаро-монгольского принципа: "меньше чем по десять тысяч мы даже в гости не ходим" ((c) Александр Борянский, Сергей Козлов).

with psnFixSzMemMgr.Create(16) do
begin // куча создана
  Ptr := FixNew; // Выделяем блок в 16 байт.
  ... // Делаем всё, что нам надо.
  FixDsp(Ptr); // Блок, указуемый Ptr, возвращён в кучу. Вообще-то
  // этот шаг перед самым разрушением кучи
  // необязателен, это стоит делать, только когда
  // есть надежда на повторное использование блока.
  Destroy; // Куча разрушена.
end;

Статистика: с 8-12-байтными блоками втрое обгоняет стандартный, с возрастанием блока до 48 байт практически сравнивается с ним. Экономия памяти при хорошем наполнении составляет почти 4 байта на блок.

У него есть недостаток, вытекающий из назначения. Рассмотрим в общих чертах его работу. Он выделяет большой массив памяти, нарезает его блоками и скармливает нам, пока он не кончится, выделяет следующий и т.д. Но определением того факта, что в массиве уже нет ни одного используемого блока, и освобождением массива этот диспетчер кучи не занимается по соображениям скорости. Иными словами, грубо говоря, если Вы выделили 1024 блока памяти по 16 байт, а затем все их освободили, пропадёт 16 кБ памяти до освобождения либо заполнения заново этой кучи.

Но динамические структуры чаще всего применяются однократно или не уменьшаются так резко в ходе работы. Не проблема и реализовать несколько замедленный вариант диспетчера кучи с автоосвобождением. Более того, если идёт интенсивная работа с мелкими блоками, вероятность того, что полностью освободится целый массив, невелика. А если не смущает некоторая замедленность работы, то для блоков произвольного размера можно воспользоваться API (LocalAlloc, HeapCreate и пр.), позволяющими реализовать отдельную кучу.

У отдельной кучи вообще есть большой плюс - динамическую структуру данных, размещённую в общей куче, долго и в некоторых случаях сложно уничтожать (утечки памяти). А тут это делается просто деструктором (это НЕ касается структур, содержащих длинные строки, динамические массивы и интерфейсы, а также объектов с таковыми - тут, увы, можно применять разве что SetMemoryManager и TObject.NewInstance...).

Я обнаружил, что запрошенная посредством VirtualAlloc (как делает "настоящий" диспетчер памяти) память в окне CPU Delphi 5 отображается как мусор: изменить память там можно, а посмотреть - нет (с всплывающей подсказкой в редакторе кода всё нормально). Так что диспетчер реализован как надстройка над стандартным, что, конечно, несколько снижает скорость, но зато позволяет уменьшить потери памяти на фрагментацию для небольших объёмов (VirtualAlloc не размещает память меньше чем по странице - 4 кБ на процессорах линии IA32).

type
  psnFixSzMemMgr = class
  private
    FLastCommit, {указатель на последний выделенный массив, в начале которого -
    указатель на предпоследний...}
    FEmptyBlock: Pointer; {указатель на последний пустой блок из списка, в
    начале которого - указатель на предпоследний...}
    FBlockSize, FCommitSize, FFillCycles: Integer;
  public
    constructor Create(
      const BlockSize: Integer; {Размер выделяемых блоков памяти. Реально
      округляется в большую сторону до величины, кратной 4.}
      const CommitBlocks: Integer = 127 {Количество блоков в выделяемых
      массивах. Должно быть больше 1 (иначе зачем огород городить?), а для
      скорости желательно не меньше 31. Реально увеличивается до ближайшего
      сверху нечётного значения (алгоритм требует это для высокой скорости).}
      );
    function FixNew: Pointer; {Выделяет блок памяти размера BlockSize и
    возвращает ссылку на эту память. Выполнено в виде функции во избежание
    обязательного преобразования типов параметра, передаваемого по ссылке.}
    procedure FixDsp(const Ptr: Pointer); {Освобождает блок памяти, выделенный
    ранее в данном экземпляре класса, указуемый параметром Ptr.}
    destructor Destroy; override;
  end;
implementation
constructor psnFixSzMemMgr.Create(const BlockSize, CommitBlocks: Integer);
begin
  FBlockSize := (BlockSize + 3) and $7FFFFFFC;
  FCommitSize := (CommitBlocks and $7FFFFFFE + 1) * FBlockSize + 4;
  FFillCycles := CommitBlocks shr 1 - 1; {заполняем в один присест два блока, и
  цикл оформим от нуля: for I:= 0 to FFillCycles, быстрее будет}
end;
function psnFixSzMemMgr.FixNew: Pointer;
var
  P, P2: Pointer;
  I, DBlockSize: Integer;
begin
  if not Assigned(FEmptyBlock) then
  begin {выделим массив}
    GetMem(P, FCommitSize);
    Pointer(P^) := FLastCommit;
    FLastCommit := P;
    Inc(PChar(P), 4);
    Pointer(P^) := nil;
    P2 := Pointer(Integer(P) + FBlockSize);
    DBlockSize := FBlockSize shl 1;
    for I := 0 to FFillCycles do
    begin {надо сделать список пустых блоков}
      Pointer(P2^) := P;
      Inc(PChar(P), DBlockSize);
      Pointer(P^) := P2;
      Inc(PChar(P2), DBlockSize);
    end;
    FEmptyBlock := P;
  end;
  Result := FEmptyBlock;
  FEmptyBlock := Pointer(Result^);
end;
procedure psnFixSzMemMgr.FixDsp(const Ptr: Pointer);
begin
  Pointer(Ptr^) := FEmptyBlock;
  FEmptyBlock := Ptr;
end;
destructor psnFixSzMemMgr.Destroy;
var
  P: Pointer;
begin
  while Assigned(FLastCommit) do
  begin
    P := FLastCommit;
    FLastCommit := Pointer(P^);
    FreeMem(P, FCommitSize);
  end;
  inherited;
end;

Hello, MiniProg.

Автор: Иванов Петр ака Brodia@a Специально для Королевства Delphi

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

Ну что же, первый шаг, создание директории проекта, назовем его MiniProg, в которой расположим поддиректории:

Теперь начнем выполнять пункт 2 наших требований, т.е. создавать тестирующую программу. В подкаталоге DUNIT расположены некоторые необходимые нам файлы, взятые из оригинального DUNIT , версии от 2002/01/17. И так, создаем новый проект, закрываем Unit1.pas, отказываемся от сохранения, проект назовем, без особой фантазии, testMiniProg.dpr и сохраняем в TEST. Удаляем всё из этого файла и помещаем в него такой код:

program testMiniProg;
uses
  Forms,
  TestFrameWork,
  GUITestRunner;
{$R *.res}
begin
  Application.Initialize;
  GUITestRunner.RunRegisteredTests;
end.

В настройках проекта, на странице Directories/Conditionals, заполняем поля Output directory и Unit output directory, так же, как и у проекта MiniProg. Дополнительно пропишем в Search path поддиректорий SOURCE и DUNIT. Вот теперь, можно создать новый unit с названием (как бы вы думали?) testAppl.pas и следующим содержанием:

unit testAppl;
interface
uses
  TestFramework, SysUtils, Controls, Forms, Appl;
type
  TTestUnitAppl = class(TTestCase)
  published
  end;
implementation
initialization
  TestFramework.RegisterTest(TTestUnitAppl.Suite);
end.

Попытаемся разобраться с проблемой масштабирования форм. Проведя то, что обычно называется предварительным расследованием; покопавшись в интернет, заглянув в хелп, почитав книги, спросив товарищей (нужное подчеркнуть); выяснилось что, можно принудить форму автоматически масштабировать собственные размеры, а так же размеры и положение размещенных на ней визуальных компонентов, при изменении размера экранного шрифта. Для этого необходимо проверить и если нужно установить свойства формы, в нашем случае FMain, ParentFont = False, Scaled = True, AutoScroll = False и PixelsPerInch равный PixelsPerInch текущего экрана. Данное утверждение верно для форм созданных с помощью Delphi 6.2, для более ранних версий не проверялось. Но, судя по количеству воплей на различных форумах - у некоторых такая проблема была. Впрочем, помнится, еще у М. Канту в "Delphi 2 for Windows95/NT" существовала небольшая глава, освещающая именно такой подход. После рассмотрения исходных кодов VCL Delphi выяснилось, что существует другая проблема, связанная с масштабированием. Дело в том, что свойства Constraints компонентов, к большому сожалению, не масштабируются. Придется заняться этим отдельно, иначе может нарушиться внешний вид формы. Что делает программа, когда создает форму? Если у формы установлены свойства как было указано выше, то в зависимости от того, отличается PixelsPerInch (сокращенно PPI) формы от PPI экрана или нет, происходит умножение значений местоположения компонентов на "новый" PPI и деление на "старый" PPI (в действительности, конечно, всё сложнее, но на первых порах и такого понимания достаточно). Будем называть эту функцию ScaleValue. Откроем проект testMiniProg, и откроем в нем файлы testAppl.pas и Appl.pas из поддиректории SOURCE. Теперь самое странное: в testAppl.pas создаем процедуру проверки TestScaleValue, и объявляем её в published свойствах TTestUnitAppl:

unit testAppl;
interface
uses
  TestFramework, SysUtils, Controls, Forms, Appl;
type
  TTestUnitAppl = class(TTestCase)
  published
    procedure TestScaleValue;
  end;
implementation
procedure TTestUnitAppl.TestScaleValue;
var
  Test: integer;
begin
  Test := ScaleValue(120,96,120);
  Check( Test = 96, Format('return wrong %d',[Test]));
end;
initialization
  TestFramework.RegisterTest(TTestUnitAppl.Suite);
end.

Главное действие в этом unit, происходит в теле процедуры TestScaleValue, по вызову функции Check, в которой проходит проверки первого параметра, и если он False, то тест считается неудачным. Второй параметр функции Check - сообщение, в котором можно написать, в краткой форме, всё, что вы думаете об отрицательном результате тестирования :). Почему, при заданных значениях входных параметров, в результате должно получиться именно 96? - можно понять в результате несложных математических преобразований исходной формулы. Менее успешные математики могут проверить на калькуляторе :). Что же, мы создали тестирующую процедуру, которая проверит корректность работы нашей функции, при чем сделает это автоматически, стоит лишь запустить тесты. Следует сказать, что проверяться функция будет при каждом запуске тестовой программы, т.е. если вы впоследствии поменяете текст функции, и сделаете это некорректно, то программа тут же сообщит вам об этом. Еще одним положительным свойством такого тестирования, является то, что в саму программу не вносится ни каких посторонних тестирующих и проверяющих функций. Далее, в файле Appl.pas, создаем саму функцию:

function ScaleValue(Value, NewPPI, OldPPI: integer): integer;
begin
  Result := MulDiv(Value, NewPPI, OldPPI);
end;

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

procedure TTestUnitAppl.TestDsgnVsRtmPPI;
begin
  Check( DsgnPPI = RtmPPI, Format('Design time PixelsPerInch not %d DPI',
    [RtmPPI]));
end;

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

function RtmPPI: integer;
begin
  Result := Screen.PixelsPerInch;
end;
function DsgnPPI: integer;
begin
  Result := 120;
end;
function IsChangePPI: boolean;
begin
  Result := DsgnPPI <> RtmPPI;
end;

Пришло время заняться процедурой, которая будет масштабировать Constraints компонентов. Собственно говоря, это свойство наследуется от TControl, по этому, будем обращаться именно к нему. Подумаем, как тестировать изменение Constraints. Первое, что приходит в голову, это создать специальную тестовую форму. Конечно, такой путь несколько сложноват, однако эта форма, скорее всего, пригодиться и в дальнейшем. Выбираем меню File | New | Form, даем название testForm и сохраняем как testUnit в поддиректории TEST, если Delphi предложит сохранить еще и проект, смело откажитесь. Не забудьте установить свойства формы так, как было описано ранее. Добавьте, в uses Appl. Проверьте, в меню Project | Options, новая форма должна располагаться в Available Forms, то есть не должна создаваться автоматически, при запуске приложения. Создайте в Events формы событие OnClose:

procedure TtestForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Action := caFree;
end;

Это заставит удалиться форму из памяти самостоятельно, после закрытия. Не забудьте, выполнить, для testAppl.pas, дополнение через File | Use Unit: Вот, теперь создадим TestChangeConstraints. Что бы легче было тестировать, и избежать неоднозначности, воспользуемся опытом тестирования ScaleValue и зададим размеры формы кратные 120, например 480, после масштабирования должно получиться 384. Так как, отдельные числа используются в unit более чем один раз, то вынесем их в константы.

const
  testOldPPI = 120;
  testNewPPI = 96;
...
procedure TTestUnitAppl.TestChangeConstraints;
var
  OK1, OK2: boolean;
  Size1, Size2: integer;
begin
  OK1 := False;
  OK2 := False;
  Size1 := testOldPPI * 4;
  Size2 := ScaleValue(Size1, testNewPPI, testOldPPI);
  testForm := TtestForm.Create(Application);
  try
    testForm.Constraints.MaxHeight := Size1;
    testForm.Constraints.MinHeight := Size1;
    testForm.Constraints.MaxWidth := 0;
    testForm.Constraints.MinWidth := Size1;
    ChangeConstraints(testForm as TControl, testNewPPI, testOldPPI);
    OK1 := (testForm.Constraints.MaxHeight = Size2) and
      (testForm.Constraints.MinHeight = Size2) and
      (testForm.Constraints.MaxWidth = 0) and
      (testForm.Constraints.MinWidth = Size2);
    ChangeConstraints(testForm as TControl, testOldPPI, testNewPPI);
    OK2 := (testForm.Constraints.MaxHeight = Size1) and
      (testForm.Constraints.MinHeight = Size1) and
      (testForm.Constraints.MaxWidth = 0) and
      (testForm.Constraints.MinWidth = Size1);
  finally
    testForm.Close;
    Check(OK1 and OK2, 'failed test');
  end;
end;

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

procedure ChangeConstraints(Control: TControl; NewPPI, OldPPI: integer);
begin
  with Control.Constraints do
  begin
    if MaxHeight > 0 then MaxHeight := ScaleValue(MaxHeight, NewPPI, OldPPI);
    if MinHeight > 0 then MinHeight := ScaleValue(MinHeight, NewPPI, OldPPI);
    if MaxWidth > 0 then MaxWidth := ScaleValue(MaxWidth, NewPPI, OldPPI);
    if MinWidth > 0 then MinWidth := ScaleValue(MinWidth, NewPPI, OldPPI);
  end;
end;

Запускаем тест - "Шеф!!! Всё пропало!!!" - в чем же дело? А дело в том, что Constraints для минимальных и максимальных значений взаимозависимы. Максимальное значение не может быть меньше минимального и наоборот, и если происходит присвоение некорректного, с этой точки зрения значения, то оно изменяется в нужную сторону. Такое поведение весьма логично, но нас оно не всегда устраивает, по тому что, нам бы хотелось, что бы такое выравнивание сработало после наших изменений. Кстати, вот вам и первый пойманный баг, и довольно хитрый :). Поспешный поиск дихлофоса от Borland. , среди методов TControl, напоминавших по духу, что-то вроде DisabledAlign ничего не дал. Пришлось воспользоваться простым дедовским антитараканным средством - типа "тапочек":

procedure ChangeConstraints(Control: TControl; NewPPI, OldPPI: integer);
begin
  with Control.Constraints do
  begin
    if NewPPI > OldPPI then
    begin
      if MaxHeight > 0 then MaxHeight := ScaleValue(MaxHeight, NewPPI, OldPPI);
      if MinHeight > 0 then MinHeight := ScaleValue(MinHeight, NewPPI, OldPPI);
      if MaxWidth > 0 then MaxWidth := ScaleValue(MaxWidth, NewPPI, OldPPI);
      if MinWidth > 0 then MinWidth := ScaleValue(MinWidth, NewPPI, OldPPI);
    end
    else
    begin
      if MinHeight > 0 then MinHeight := ScaleValue(MinHeight, NewPPI, OldPPI);
      if MaxHeight > 0 then MaxHeight := ScaleValue(MaxHeight, NewPPI, OldPPI);
      if MinWidth > 0 then MinWidth := ScaleValue(MinWidth, NewPPI, OldPPI);
      if MaxWidth > 0 then MaxWidth := ScaleValue(MaxWidth, NewPPI, OldPPI);
    end;
  end;
end;

Тест, зеленый цвет, "едем" дальше... Дальше? А дальше, расположим на testForm какие-нибудь визуальные компоненты, ...даааа побольше :). В принципе, TestChangeConstraints показал, что процедура работает успешно, с наследником TForm, но не мешало бы, проверить её и с другими компонентами, хотя бы некоторую их часть (нет у нас такого требования - тестировать VCL). Так как предполагаемый процесс тестирования вполне однообразен, то создадим функцию, которой будем передавать компонент, из числа тех, которые расположены на форме, а возвращать она будет - "да" или "нет".

function TTestUnitAppl.TestScaleControl(Control: TControl): boolean;
var
  OK1, OK2: boolean;
  Size1, Size2: integer;
begin
  OK1 := False;
  OK2 := False;
  Size1 := testOldPPI;
  Size2 := ScaleValue(Size1, testNewPPI, testOldPPI);
  testForm := TtestForm.Create(Application);
  try
    Control.Constraints.MaxHeight := Size1;
    Control.Constraints.MinHeight := 0;
    Control.Constraints.MaxWidth := Size1;
    Control.Constraints.MinWidth := Size1;
    ChangeConstraints(Control, testNewPPI, testOldPPI);
    OK1 := (Control.Constraints.MaxHeight = Size2) and
      (Control.Constraints.MinHeight = 0) and
      (Control.Constraints.MaxWidth = Size2) and
      (Control.Constraints.MinWidth = Size2);
    ChangeConstraints(Control, testOldPPI, testNewPPI);
    OK2 := (Control.Constraints.MaxHeight = Size1) and
      (Control.Constraints.MinHeight = 0) and
      (Control.Constraints.MaxWidth = Size1) and
      (Control.Constraints.MinWidth = Size1);
  finally
    testForm.Close;
    Result := OK1 and OK2;
  end;
end;

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

procedure TTestUnitAppl.TestScaleLabel;
begin
  Check(TestScaleControl(testForm.Label1 as TControl), 'failed test ');
end;

Если все тесты проходят успешно, то с определенной долей вероятности можно утверждать, что мы теперь знаем, как настроить форму так, что бы она автоматически масштабировались, по крайней мере в пределах, которые обеспечивает Delphi. Так же сможем масштабировать Constraints отдельно взятого контрола окна, при необходимости. Думаю, сфера использования ChangeConstraints довольно ограниченна, но в большинстве случаев результаты, полученные с помощью таких простых средств - вполне удовлетворительные. Можно было бы разработать функцию, которая бы сама изменяла Constraints у всех элементов формы. Желающие могут попробовать свои силы самостоятельно, не забудьте только прислать пример с тестом, и он будет включен в проект. По моему скромному мнению, решить эту проблему кардинально и качественно, можно лишь на уровне изменения исходного кода VCL. Хотя, "неумение" Constraints корректировать свои значения во время масштабирование окна и не является "официальным" багом но, очень хочется надеяться, что авторы Delphi 7 позаботятся об этом. Конечно, всегда можно создать собственный вариант формы, в котором проблема будет решена, но для данного проекта это будет расцениваться как выход за рамки требований (см. пункт.1). Впрочем, повторюсь, если у кого-то есть возможность исправить - пишите. И так, мы провели некоторые технологические тесты, и убедились в работоспособности функций и процедур основной программы. Пришло время заняться функциональными тестами, то есть тестами, в которых проводится общая проверка на соответствие наших решений требованиям. Наиболее наблюдательные читатели должны были заметить, что к самой программе мы еще и не прикасались, но уже имеем для неё несколько работоспособных функций :). Проводить функциональное тестирование можно по-разному, и в принципе, лучше всего на рабочем приложении. У нас, его пока нет, кроме того, оценить правильность масштабирования можно на любом примере, ведь от нас не требуется реакция (нажатие кнопки, движение мыши и т.д.). Нам нужно просто посмотреть. Так что, воспользуемся testForm и разместим на ней 3 компонента TLabel. В свойство Caption каждой занесем такой текст "0123456789". У Label2 установим Constraints равными Width, у Label3 минимальное и максимальное значения отличающееся не менее чем на 50%, у Label4 минимальное и максимальное значения отличающееся на 5%.

procedure TTestUnitAppl.TestFuncScale;
begin
  if IsChangePPI then
  begin
    testForm := TtestForm.Create(Application);
    try
      testForm.ShowModal;
    finally
      testForm.Close;
    end;
  end;
  Check(True, 'very strange ');
end;

Declaimer aka Отмазка.

Проект создан в Delphi6 MiniProg.zip (44.3K).

Hello, MiniProg 2.

Автор: Иванов Петр ака Brodia@a Специально для Королевства Delphi

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

Данная тема уже не раз поднималась на просторах Королевства, например, здесь или здесь. Огромное множество материала, на данную тематику, чьей то щедрой рукой, разбросано по интернету. Правда, все методы однотипные и сводятся к тому, что программа, при запуске, проверяет какой-нибудь признак, если он не обнаружен - то запускается, если же присутствует... В этом месте возможны самые различные реакции, от сообщений, с требованием ответа/нажатия кнопки, до коварнейших систем оповещения создателей (например, как у M$ XP :). Признаком может служить, либо проверка наличия определенного окна, либо отметка в конфигурационном файле/регистре, либо банальный файл, создаваемый при запуске приложения и удаляемый при выходе из него. Более сложные системы, профессионального уровня, обращаются за советом, "можно, или нельзя", к специализированным лицензионным серверам. Мы пойдем другим путем, наверное, самым простым, будем проверять наличие определенного мьютекса, реакция же будет вежливая - просто активизация окна. Данный метод не нов. Определенно, он работоспособен, но не мешало бы создать тест, который бы нас убедил, что это так. И это еще одна рекомендация XtremeProgramming - не лениться и стараться тестировать как можно больше. Вообще, если бы программисты знали, как много ошибок может быть, в казалось бы, в надежном и простом коде: Откроем testMiniProg.dpr и в файле testAppl.pas создадим следующую процедуру:

Const
  StrFailedTest = 'failure test';
...
procedure TTestUnitAppl.TestFindPrevInstance;
var
  Test1, Test2: boolean;
  Temp: THandle; 
begin
  Temp := Mutex;
  Test1 := not FindPrevInstance('Test');
  Test2 := FindPrevInstance('Test');
  StopPrevInstance;
  Check(Test1 and Test2, strFailedTest);
  Mutex := Temp; 
end;

Сами функции располагаются в Appl.pas и выглядят так:

Var
  Mutex: THandle = 0;
...
function FindPrevInstance(Name: string): boolean;
var
  Temp: THandle;
begin
  Temp := CreateMutex(nil, False, PChar(Name));
  Result := (GetLastError = ERROR_ALREADY_EXISTS);
  if Result then
    CloseHandle(Temp)
  else
    Mutex := Temp;
end;
procedure StopPrevInstance;
begin
  if Mutex > 0 then
    CloseHandle(Mutex);
end;

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

Unit testAppl;
...
procedure TTestUnitAppl.TestShowPrevInstance;
begin
  Check(ShowPrevInstance('DUnit'), strFailedTest);
end;
unit Appl;
...
function ShowPrevInstance(Name: string): boolean;
var
  PrevInstance: HWND;
begin
  Result := False;
  PrevInstance := FindWindow('TApplication', PChar(Name));
  if PrevInstance <> 0 then
  begin
    if IsIconic(PrevInstance) then
      ShowWindow(PrevInstance, SW_RESTORE);
    SetForegroundWindow(PrevInstance);
    Result := True;
  end;
end;

Компилируем, запускаем, проверяем - все работает, как требуется. Следует отметить, что в данном случае, тестировалось только возвращаемое ShowPrevInstance значение, сам эффект 'показа' незаметен. По этому, что бы ни уподобляться тому сапожнику, который без сапог, внесем в testMiniProg.dpr изменения, добавим в секцию uses модуль Appl и следующий код:

program testMiniProg;
uses
  Appl in '..\SOURCE\Appl.pas', 
  Forms, TestFrameWork, GUITestRunner,
  testAppl in 'testAppl.pas',
  testUnit in 'testUnit.pas' {testForm};
{$R *.res}
begin
  if FindAndShowPrevInstance('DUnit') then
    Halt
  else
  try
    Application.Initialize;
    Application.Title := 'DUnit';
    GUITestRunner.RunRegisteredTests;
  finally
    StopPrevInstance;
  end;
end.

В модуль Appl.pas, поместим функцию FindAndShowPrevInstance, которая будет искать и активизировать предыдущую копию программы. Её тестирование проведем на функциональном уровне, так как технологическое тестирование, хоть и возможно, но реализовывать его будет обременительно. Впрочем, желающие могут попробовать, не забудьте только мне показать, очень интересно.

function FindAndShowPrevInstance(Name: string): boolean;
begin
  Result := FindPrevInstance(Name);
  if Result then
    ShowPrevInstance(Name);
end;

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

Способность сохранять в конфигурационном файле какие-нибудь значения, например, положение и размеры окна, так же была освещена в интернет очень широко. В RxLib, есть неплохой компонент, умеющий многое, я сам пользовался им когда-то. По этому не будем изобретать ничего нового, но просто воспользуемся уже известными приемами. Почему именно ini-файл, а не регистр, или не способ хранение свойств компонентов, так как это делает Delphi? Свои плюсы и минусы есть у всех подходов, но для наших целей вполне хватит возможностей ini-файла. Будем считать, что ini-файл располагается в директории вместе с программой и имеет такое же имя, но другое расширение, например "ini" :). Традиционно, свойства окна хранят в отдельной секции ini-файла, с уникальным, для данного приложения именем. Используем для этого имя формы. И так, тесты:

procedure TTestUnitAppl.TestGetIniFileName;
begin
  Check(ExtractFileName(GetIniFileName) = 'testMiniProg' + cfgFileExt,
    strFailedTest);
end;
procedure TTestUnitAppl.TestGetSectionName;
begin
  Check(GetSectionName(Screen.Forms[0]) = 'GUITestRunner', strFailedTest);
end;

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

Const
  cfgFileExt = '.ini';
...
function GetIniFileName: string;
begin
  Result := ChangeFileExt(Application.ExeName, cfgFileExt);
end;
function GetSectionName(Component: TComponent): string;
begin
  Result := Component.Name;
end;

Вооружившись этими знаниями можно придти к выводу, что придется вносить изменения в функцию RtmPPI и DsgnPPI, и вычислять их результат иначе, чем было сделано ранее. Идея проста, использовать для масштабирования высоту текста, времени создания формы и времени выполнения приложения. Судя по всему - это более корректный способ, однако, в названиях переменных и процедур сохранена аббревиатура PPI. Остается вопрос, где, во время исполнения, взять высоту текста времени создания, ведь при создании окна все размеры изменяются. В принципе, все интересующие нас числа хранятся в ресурсах программы и можно попробовать прочитать их оттуда. Но, все попытки обратиться к ресурсам формы в программе, использую стандартные и рекомендованные для этого средства, ни к чему не привели. Точнее, нужные ресурсы программы успешно читаются, но уже в измененном виде, так уж устроен метод TCustomForm.ReadState :(. По этому, попытаемся прочитать данные из ресурса, так же, как это делает Delphi, но в сильно упрощенном варианте. Если вы загляните в исходный код VCL и просмотрите всё, что хоть как-то касается загрузки ресурсов программы, то поймете, зачем эти упрощения. Сведений, в литературе и интернете, связанных с вопросами чтения ресурсов во время исполнения программы, без создания самих компонентов, очень мало. К моему сожалению, практически, я ничего не нашел, и если кто-то знает, где есть подобного рода информация - поделитесь ссылкой. Текст функции, которая читает ресурсы определенной формы, выглядит так:

unit Appl;
...
function ReadFormRes(ResName: string; List: TStringList): boolean;
var
  Prop, Value: string;
  Stream: TResourceStream;
  Reader: TReader;
  HRsrc: THandle;
begin
  List.Clear;
  HRsrc := FindResource(HInstance, PChar(ResName), RT_RCDATA);
  Result := HRsrc <> 0;
  if not Result then Exit;
  Stream := TResourceStream.Create(HInstance, ResName, RT_RCDATA);
  Reader := TReader.Create(Stream, 4096);
  try
    Reader.ReadSignature;
    Reader.ReadStr;
    Reader.ReadStr;
    while not Reader.EndOfList do
    begin
      Prop := Reader.ReadStr;
      Value := strNil;
      case Reader.NextValue of
        vaInt8, vaInt16, vaInt32:
          Value := IntToStr(Reader.ReadInteger);
        vaString:
          Value := Reader.ReadString;
        else
          Reader.SkipValue;
      end;
      if Value <> strNil then
        List.Add(Format('%s = %s',[Prop,Value]));
    end;
    Reader.CheckValue(vaNull);
  finally
    Reader.Free;
    Stream.Free;
  end;
end;

Как я уже говорил, здесь представлен упрощенный вариант, который ищет определенный ресурс в программе, и сообщает в результате найден он или нет, а так же заполняет List набором строк найденных свойств и их значений. В список записываются не все свойства, а только те, которые определены в ресурсе и имеют тип, либо целого числа, либо строки, и принадлежат самой форме. При желании, можно организовать рекурсивный обход всех компонентов окна и чтение их свойств. Полный тест для данной функции не приводится, по той простой причине, что он довольно велик и явно выходит за рамки данной статьи. Может быть в другой статье :). Скажу лишь что, при построении такого рода функции, вряд ли стоит эмулировать полностью весь процесс загрузки ресурсов программы. В нашем случае, необходимо прочитать лишь некоторые свойства окна, что мы и сделаем. Конечно, можно поступить и так; создать пустую форму, у которой будет известна высота текста времени создания, но во время выполнения программы нам будет известно её масштабированное значение, что, собственно говоря, и нужно. Но, лично мне такой путь не нравиться, как по стилю решения проблемы, так и по тому, что при таком подходе возможна проблема с Constraints. Тестирующая функция довольно проста, хотя, конечно же, при тестировании полного варианта она выглядит иначе:

Procedure TtestUnitAppl.TestReadFormRes;
var
  List: TStringList;
  Test: boolean;
begin
  List := TStringList.Create;
  try
    ReadFormRes('TGUITestRunner', List);
    Test := List.Values['Caption'] = 'DUnit: An Xtreme testing framework';
  finally
    List.Free;
    Check(Test, strFailedTest);
  end;
end;

Изменим функцию RtmPPI таким образом, что бы она вычисляла, во время выполнения программы, высоту текста, для определенного нами окна. Соответственно DsgnPPI, изменится так, что вычисление её результата будет происходить с использованием ReadFormRes. Дополнительно, что бы избежать ошибок при определении RtmPPI, в ситуации, когда окно еще не создано, нам понадобится функция, которая по имени окна будет искать его в списке созданных форм и возвращать указатель на найденную форму, иначе nil.

Unit testAppl;
...
procedure TTestUnitAppl.TestFindForm;
var
  Test1, Test2, Test3: boolean;
begin
  Test1 := FindForm('testForm') = nil;
  testForm := TtestForm.Create(Application);
  try
    Test2 := FindForm('testForm') <> nil;
  finally
    testForm.Free;
    Test3 := FindForm('testForm') = nil;
  end;
  Check(Test1 and Test2 and Test3, strFailedTest);
end;
unit Appl;
...
function FindForm(FormName: string): TCustomForm;
var
  I: integer;
begin
  Result := nil;
  for I := 0 to Screen.FormCount - 1 do
    if Screen.Forms[I].Name = FormName then
    begin
      Result := Screen.Forms[I];
      Break;
    end;
end;

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

unit Appl;
...
const
  strDelphiMagicText = '0';
  strResTextHeight = 'TextHeight';
...
function RtmPPI(FormName: string): integer;
var
  Form: TCustomForm;
begin
  Result := 0;
  Form := FindForm(FormName);
  if Form <> nil then
    Result := Form.Canvas.TextHeight(strDelphiMagicText);
end;
function DsgnPPI(FormName: string): integer;
var
  List: TStringList;
  Form: TCustomForm;
begin
  List := TStringList.Create;
  try
    Form := FindForm(FormName);
    if Form <> nil then
    begin
      ReadFormRes(Form.ClassName, List);
      Result := StrToInt(List.Values[strResTextHeight]);
    end;
  finally
    List.Free;
  end;
end;

Эти функции проверяют наличие определенного окна . Если значение не равно nil, то считается, что форма уже создана, и у неё можно определить PPI's. Если форма еще не создана, то возвращается 0. В случае успешного выполнения функции, результатом будет значение высоты текста, отличное от 0. Так как сами функции несколько усложнились, то необходимо расширить их тестирование. Изменится так же, процедура TestDsgnVsRtmPPI, но функциональность её сохраниться, и даже несколько расшириться. Функция IsChangePPI удалена, из-за её несоответствия текущему моменту.

const
  testPPI = 16;
...
procedure TTestUnitAppl.TestRtmPPI;
var
  Test: boolean;
begin
  testForm := TtestForm.Create(Application);
  try
    Test := RtmPPI('testForm') = testForm.Canvas.TextHeight(strDelphiMagicText);
  finally
    testForm.Free;
    Check(Test, strFailedTest);
  end;
end;
procedure TTestUnitAppl.TestDsgnPPI;
var
  OldPPI, PPI: integer;
begin
  testForm := TtestForm.Create(Application);
  try
    OldPPI := DsgnPPI('testForm');
  finally
    testForm.Free;
    Check(OldPPI = testPPI, Format('DsgnPPI=%d, not %d', [OldPPI, testPPI]));
  end;
end;
procedure TTestUnitAppl.TestDsgnVsRtmPPI;
var
  Test: boolean;
  Text: string;
  OldPPI, NewPPI: integer;
begin
  Test := False;
  Text := strFailedTest;
  testForm := TtestForm.Create(Application);
  try
    OldPPI := RtmPPI('testForm');
    NewPPI := DsgnPPI('testForm');
    if (OldPPI > 0) and (NewPPI > 0) then
    begin
      Test := OldPPI = NewPPI;
      if not Test then
        Text := Format('DsgnPPI=%d not equal RtmPPI=%d DPI', [OldPPI, NewPPI]);
    end;
  finally
    testForm.Free;
    Check(Test, Text);
  end;
end;

Вроде бы все подготовительные действия выполнены, можно попытаться сохранить/восстановить состояние формы. Текст тестовой функции TestSaveLoadFormState можно посмотреть в testAppl.pas. Логика проверки следующая, создается окно, с некоторой задержкой демонстрируется, запоминается состояние окна в локальной переменной и сохраняется в ini-файле. Устанавливаются другие значения состояния окна, перемещается, сворачивается в левый нижний угол, выжидается некоторое время. Восстанавливается состояние окна, сохраненное в ini-файле. Дополнительно, проводится проверка значений состояния окна, до и после сохранения/восстановления. Если же вас не убедят результаты тестов, то всегда можно будет заглянуть в файл ini и посмотреть всё своими глазами. Сами процедуры сохранения/восстановления, и все процедуры к которым они обращаются, приведены поименно ниже:

...
procedure WriteIniShowCmd;
procedure ReadIniShowCmd;
procedure WriteIniFlags;
procedure ReadIniFlags;
procedure WriteIniWidth;
procedure ReadIniWidth;
procedure WriteIniHeight;
procedure ReadIniHeight;
procedure WriteIniLeft;
procedure ReadIniLeft;
procedure WriteIniTop;
procedure ReadIniTop;
procedure ScaleFormConstraints;
procedure SaveFormState;
procedure LoadFormState;
...

Declaimer aka Отмазка.

Все копирайты, если они известны, указаны. Иначе, автор не известен или копирайт утерян.

Доступ к справочной информации.

Ниже, в качестве примера, приведена процедура обработки события Onclick для кнопки Справка (Button4) диалогового окна программы решения квадратного уравнения.

// щелчок на кнопке Справка
procedure TForm1.Button4Click(Sender: TObject);
begin
  winhelp(Form1.Handle, 'sqroot.hip', HELP_CONTEXT, 1);
end;

Чтобы создать справочную систему, нужно:

Последние три из перечисленных выше шагов выполняются в программе HTML Help Workshop.

Обработать нажатие на кнопку Help в диалоговом окне.

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

type
   TForm1 = class(TForm)
   private
     procedure wmNCLButtonDown(var Msg: TWMNCLButtonDown); message WM_NCLBUTTONDOWN;
     procedure wmNCLButtonUp(var Msg: TWMNCLButtonUp); message WM_NCLBUTTONUP;
   end;
 var
   Form1: TForm1;
 implementation
 {$R *.DFM}
 procedure TForm1.wmNCLButtonDown(var Msg: TWMNCLButtonDown);
 begin
   if Msg.HitTest = HTHELP then
   begin
     Msg.Result := 0; // swallow mouse down on biHelp border icon 
  end
   else
     inherited;
 end;
 procedure TForm1.wmNCLButtonUp(var Msg: TWMNCLButtonUp);
 begin
   if Msg.HitTest = HTHELP then
   begin
     Msg.Result := 0;
     ShowMessage('Hi!'); // Show your help here 
  end
   else
     inherited;
 end;