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

ВИДЕОКУРС ВЗЛОМ
выпущен 1 марта!


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

БОЛЬШОЙ FAQ ПО DELPHI



Как показать округлённое окошко подсказки в Tray в Windows2000

В Windows 2000, формат структуры NotifyIconData, которая используется для работы с иконками в Трее (которая, кстати, называется "The Taskbar Notification Area" :) значительно отличается от предыдущий версий Windows. Однако, эти изменения НЕ отражены в юните ShellAPI.pas в Delphi 5.

Итак, нам понадобится преобразованный SHELLAPI.H, в котором присутствуют все необходимые объявления:


 uses Windows;
 
 type
   NotifyIconData_50 = record // определенная в shellapi.h
     cbSize: DWORD;
     Wnd: HWND;
     uID: UINT;
     uFlags: UINT;
     uCallbackMessage: UINT;
     hIcon: HICON;
     szTip: array[0..MAXCHAR] of AnsiChar;
     dwState: DWORD;
     dwStateMask: DWORD;
     szInfo: array[0..MAXBYTE] of AnsiChar;
     uTimeout: UINT; // union with uVersion: UINT;
     szInfoTitle: array[0..63] of AnsiChar;
     dwInfoFlags: DWORD;
   end {record};
 
 const
   NIF_INFO = $00000010;
 
   NIIF_NONE = $00000000;
   NIIF_INFO = $00000001;
   NIIF_WARNING = $00000002;
   NIIF_ERROR = $00000003;
 

А это набор вспомогательных типов:


 type
   TBalloonTimeout = 10..30 {seconds};
   TBalloonIconType = (bitNone, // нет иконки
     bitInfo,    // информационная иконка (синяя)
     bitWarning, // иконка восклицания (ж¸лтая)
     bitError);  // иконка ошибки (краснаа)
 

Теперь мы готовы приступить к созданию округлённых подсказок! Для этого воспользуемся следующей функцией:


 uses SysUtils, Windows, ShellAPI;
 
 function DZBalloonTrayIcon(const Window: HWND; const IconID: Byte;
   const Timeout: TBalloonTimeout; const BalloonText, BalloonTitle:
   string; const BalloonIconType: TBalloonIconType): Boolean;
 const
   aBalloonIconTypes: array[TBalloonIconType] of
     Byte = (NIIF_NONE, NIIF_INFO, NIIF_WARNING, NIIF_ERROR);
 var
   NID_50: NotifyIconData_50;
 begin
   FillChar(NID_50, SizeOf(NotifyIconData_50), 0);
   with NID_50 do begin
     cbSize := SizeOf(NotifyIconData_50);
     Wnd := Window;
     uID := IconID;
     uFlags := NIF_INFO;
     StrPCopy(szInfo, BalloonText);
     uTimeout := Timeout * 1000;
     StrPCopy(szInfoTitle, BalloonTitle);
     dwInfoFlags := aBalloonIconTypes[BalloonIconType];
   end; {with}
   Result := Shell_NotifyIcon(NIM_MODIFY, @NID_50);
 end;
 

Вызывается она следующим образом:

 DZBalloonTrayIcon(Form1.Handle, 1, 10,
   'this is the balloon text', 'title', bitWarning);
 

Иконка, должна быть предварительно добавлена с темже дескриптором окна и IconID (в данном примере Form1.Handle и 1).

Можете попробовать все три типа иконок внутри всплывающей подсказки.

P.S. На всякий случай, ниже представлены функции для добавление/удаления иконок в трее:


 uses SysUtils, Windows, ShellAPI;
 
 {добавление иконки}
 
 function DZAddTrayIcon(const Window: HWND; const IconID: Byte; const Icon:
   HICON; const Hint: string = ''): Boolean;
 var
   NID: NotifyIconData;
 begin
   FillChar(NID, SizeOf(NotifyIconData), 0);
   with NID do begin
     cbSize := SizeOf(NotifyIconData);
     Wnd := Window;
     uID := IconID;
     if Hint = '' then begin
       uFlags := NIF_ICON;
     end {if} else begin
       uFlags := NIF_ICON or NIF_TIP;
       StrPCopy(szTip, Hint);
     end {else};
     hIcon := Icon;
   end {with};
   Result := Shell_NotifyIcon(NIM_ADD, @NID);
 end;
 
 {добавляет иконку с call-back сообщением}
 
 function DZAddTrayIconMsg(const Window: HWND; const IconID: Byte;
   const Icon: HICON; const Msg: Cardinal; const Hint: string = ''): Boolean;
 var
   NID: NotifyIconData;
 begin
   FillChar(NID, SizeOf(NotifyIconData), 0);
   with NID do begin
     cbSize := SizeOf(NotifyIconData);
     Wnd := Window;
     uID := IconID;
     if Hint = '' then begin
       uFlags := NIF_ICON or NIF_MESSAGE;
     end {if} else begin
       uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
       StrPCopy(szTip, Hint);
     end {else};
     uCallbackMessage := Msg;
     hIcon := Icon;
   end {with};
   Result := Shell_NotifyIcon(NIM_ADD, @NID);
 end;
 
 {удаляет иконку}
 
 function DZRemoveTrayIcon(const Window: HWND; const IconID: Byte): Boolean;
 var
   NID: NotifyIconData;
 begin
   FillChar(NID, SizeOf(NotifyIconData), 0);
   with NID do begin
     cbSize := SizeOf(NotifyIconData);
     Wnd := Window;
     uID := IconID;
   end {with};
   Result := Shell_NotifyIcon(NIM_DELETE, @NID);
 end;
 

Несколько заключительных замечаний:

  • Нет необходимости использовать большую структуру NotifyIconData_50 для добавления или удаления иконок, старая добрая структура NotifyIconData прекрасно подойдёт для этого.
  • Для callback сообщения можно использовать WM_APP + что-нибудь.
  • Используя различные IconID, легко можно добавить несколько различных иконок из одного родительского окна и работать с ними по их IconID.



Исправление загрузки RTF текста через поток

Автор: Лагонский Сергей Николаевич

Я после дня игры в X-COM стал думать как мне поменьше ходов потратить, идя по комнате, чтобы потом хватило дверь открыть!

В версии Borland Delphi 3 Client/Server я обнаружил, что при загрузке текста формата RTF методом "LoadFromStream" в компонент TRichEdit он не интерпретируется как RTF, а отображается полностью (со всеми управляющими символами). Разбираясь в исходном тексте модуля COMCTRLS.PAS (дата создания: 4 августа 1997 года, размер: 391728 байт) я нашел причину, из-за которой вышеуказанный метод не работал как надо. Ниже я привожу исходный и исправленный тексты реализации метода "TRichEditStrings.LoadFromStream" (измененные строки отмечены символом "!"):

1. Исходный текст


 procedure TRichEditStrings.LoadFromStream(Stream: TStream);
 var
   EditStream: TEditStream;
   Position: Longint;
   TextType: Longint;
   StreamInfo: TRichEditStreamInfo;
   Converter: TConversion;
 begin
   StreamInfo.Stream := Stream;
   if FConverter <> nil then
     Converter := FConverter
   else
     Converter := RichEdit.DefaultConverter.Create;
   StreamInfo.Converter := Converter;
   try
     with EditStream do
     begin
       dwCookie := LongInt(Pointer(@StreamInfo));
       pfnCallBack := @StreamLoad;
       dwError := 0;
     end;
     Position := Stream.Position;
     if PlainText then
       TextType := SF_TEXT
     else
       TextType := SF_RTF;
     SendMessage(RichEdit.Handle, EM_STREAMIN, TextType, Longint(@EditStream));
     if (TextType = SF_RTF) and (EditStream.dwError <> 0) then
     begin
       Stream.Position := Position;
       ! if PlainText then
         TextType := SF_RTF
           !
         else
         TextType := SF_TEXT;
 
       SendMessage(RichEdit.Handle, EM_STREAMIN, TextType, Longint(@EditStream));
       if EditStream.dwError <> 0 then
         raise EOutOfResources.Create(sRichEditLoadFail);
     end;
   finally
     if FConverter = nil then
       Converter.Free;
   end;
 end;
 

2. Текст с исправлением:


 procedure TRichEditStrings.LoadFromStream(Stream: TStream);
 var
   EditStream: TEditStream;
   Position: Longint;
   TextType: Longint;
   StreamInfo: TRichEditStreamInfo;
   Converter: TConversion;
 begin
   StreamInfo.Stream := Stream;
   if FConverter <> nil then
     Converter := FConverter
   else
     Converter := RichEdit.DefaultConverter.Create;
   StreamInfo.Converter := Converter;
   try
     with EditStream do
     begin
       dwCookie := LongInt(Pointer(@StreamInfo));
       pfnCallBack := @StreamLoad;
       dwError := 0;
     end;
     Position := Stream.Position;
     if PlainText then
       TextType := SF_TEXT
     else
       TextType := SF_RTF;
     SendMessage(RichEdit.Handle, EM_STREAMIN, TextType, Longint(@EditStream));
     if (TextType = SF_RTF) and (EditStream.dwError <> 0) then
     begin
       Stream.Position := Position;
       ! if PlainText then
         TextType := SF_TEXT
           !
         else
         TextType := SF_RTF;
 
       SendMessage(RichEdit.Handle, EM_STREAMIN, TextType, Longint(@EditStream));
       if EditStream.dwError <> 0 then
         raise EOutOfResources.Create(sRichEditLoadFail);
     end;
   finally
     if FConverter = nil then
       Converter.Free;
   end;
 end;
 




Как сохранить RTF в TBlobField

Иисyс изменил твою жизнь. Сохранить? (Да/Нет)

В этом примере поле 'Table1Memo' это paradox 'formatted memo'. Оно так же может быть полем blob.

Через TBlobStream содержимое контрола RichEdit можно загружать или сохранять в базу данных:


 procedure TForm1.BtnGetClick(Sender: TObject);
 var
   bs: TBlobStream;
 begin
   bs := nil;
   with Table1 do
     try
       open;
       first;
       bs := TBlobStream.Create(table1memo, bmread);
       Richedit1.plaintext := false;
       Richedit1.Lines.Loadfromstream(bs);
     finally
       bs.free;
       close;
     end;
 end;
 
 procedure TForm1.BtnPutClick(Sender: TObject);
 var
   bs: TBlobStream;
 begin
   bs := nil;
   with Table1 do
     try
       open;
       first;
       edit;
       bs := TBlobStream.Create(table1memo, bmwrite);
       Richedit1.plaintext := false;
       Richedit1.Lines.Savetostream(bs);
       post;
     finally
       bs.free;
       close;
     end;
 end;
 




Массив констант во время выполнения приложения

Автор: Peter Below

...хорошо, непосредственно это синтаксис не поддерживает, поскольку массив констант Array of Const подобен открытым массивам, главным образом в части характеристик времени компиляции. Но вы можете обойти этот неприятный момент, обладая хотя бы начальными знаниями того, как реализован открытый массив. Что нам для этого необходимо: динамически размещенный массив array of TVarRec, который "принимает" ваши параметры, и "псевдоним" (alias) функции Format, позволяющий работать с таким массивом без "ругани" со стороны компилятора.


 type
   { объявляем тип для динамического массива array of TVarRecs }
   TVarArray = array[0..High(Word) div Sizeof(TVarRec) - 1] of TVarRec;
   PVarArray = ^TVarArray;
 
   { Объявляем alias-тип для функции Format. Передаваемые параметры будут иметь
   в стеке тот же самый порядок вызова, что и при нормальном вызове Format }
   FormatProxy = function(const aFormatStr: string; var aVarRec: TVarRec;
     highIndex: Integer): string;
 
   { AddVarRecs копирует параметры, передаваемые в массиве A в pRecs^, начиная
   с pRecs^[atIndex]. highIndex - самый большой доступный индекс pRecs, число
   распределенных элементов - 1. }
 
 procedure AddVarRecs(pRecs: PVarArray; atIndex, highIndex: Integer; const A:
   array of const);
 var
   i: Integer;
 begin
   if pRecs <> nil then
     for i := 0 to High(A) do
     begin
       if atIndex <= highIndex then
       begin
         pRecs^[atIndex] := A[i];
         Inc(atIndex);
       end { If }
       else
         Break;
     end; { For }
 end; { AddVarRecs }
 
 procedure TScratchMain.SpeedButton2Click(Sender: TObject);
 var
   p: PVarArray;
   S: string;
   Proxy: FormatProxy;
 begin
   { распределяем массив для четырех параметров, индексы - 0..3 }
   GetMem(p, 4 * Sizeof(TVarRec));
   try
     { добавляем параметры последующими вызовами AddVarRecs }
     AddVarRecs(p, 0, 3, [12, 0.5, 'Шаблон']);
     AddVarRecs(p, 3, 3, ['Тест']);
 
     { получаем полномочия Format }
     @Proxy := @SysUtils.Format;
 
     { Вызов с динамически сгенерированным массивом параметров.
     Естественно, строка формата может также быть сформирована
     и во время выполнения программы. }
     S := Proxy('Целое: %d, Реальное: %4.2f, Строки: %s, %s', p^[0], 3);
 
     { выводим результат }
     ShowMessage(S);
   finally
     FreeMem(p, 4 * Sizeof(TVarRec));
   end;
 end;
 

Я надеюсь вы поняли принцип. Естественно, имеются ограничения. Вы можете передавать в AddVarRecs числовые величины, строковые переменные и литералы, но не в коем случае не строковые выражения! В этом случае компилятор должен для хранения результата сформировать в стеке временную строку, передать ее в AddVarRecs (или лучше по адресу в TVarRec), и она может прекратить свое существование или может быть перезаписана в стеке другими данными, если в конечном счете вы передадите в Proxy целый массив!

Тестировалось только в Delphi 1.0!




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

Учитывая пожелания пользователей, фирма Microsoft объявила, что она внесёт изменение в название Windows 2000, теперь эта операционная система будет называться Windows 2000 beta ДВАДЦАТЬ ПЯТЬ. P.S. (А чё? Ведь существует-же W2000 beta 3 RELEASE CANDIDATE 1)

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

Данная функция может оказаться весьма полезной в случае наличия нескольких одинаковых областей на форме с необходимостью синхронизации изменений в течение некоторого промежутка времени. Процедура создания дубликата проста до безобразия: разместите на TPanel или на другом родительском компоненте необходимые элементы управления и сделайте: "newpanel := DuplicateComponents(designedpanel)".


 uses
   SysUtils, Windows, Messages, Classes, Graphics, Controls,
   Forms, Dialogs, ExtCtrls, StdCtrls, IniFiles, TypInfo, Debug;
 
 type
   TUniqueReader = class(TReader)
     LastRead: TComponent;
     procedure ComponentRead(Component: TComponent);
     procedure SetNameUnique(
       Reader: TReader;
       Component: TComponent;
       var Name: string
       );
   end;
 
 implementation
 
 procedure TUniqueReader.ComponentRead(Component: TComponent);
 begin
   LastRead := Component;
 end;
 
 // Задаем уникальное имя считываемому компоненту, например,
 // "Panel2", если "Panel1" уже существует
 
 procedure TUniqueReader.SetNameUnique(
   Reader: TReader;
   Component: TComponent; // Считываемый компонент
   var Name: string // Имя компонента для дальнейшей модификации
   );
 var
   i: Integer;
   tempname: string;
 begin
   i := 0;
   tempname := Name;
   while Component.Owner.FindComponent(Name) <> nil do
   begin
     Inc(i);
     Name := Format('%s%d', [tempname, i]);
   end;
 end;
 
 function DuplicateComponents(
   AComponent: TComponent // исходный компонент
   ): TComponent; // возвращаемся к созданию нового компонента
 
   procedure RegisterComponentClasses(
     AComponent: TComponent
     );
   var
     i: integer;
   begin
     RegisterClass(TPersistentClass(AComponent.ClassType));
     if AComponent is TWinControl then
       if TWinControl(AComponent).ControlCount > 0 then
         for i := 0 to
           (TWinControl(AComponent).ControlCount - 1) do
 
           RegisterComponentClasses(TWinControl(AComponent).Controls[i]);
   end;
 
 var
   Stream: TMemoryStream;
   UniqueReader: TUniqueReader;
   Writer: TWriter;
 begin
   result := nil;
   UniqueReader := nil;
   Writer := nil;
 
   try
     Stream := TMemoryStream.Create;
     RegisterComponentClasses(AComponent);
 
     try
       Writer := TWriter.Create(Stream, 4096);
       Writer.Root := AComponent.Owner;
       Writer.WriteSignature;
       Writer.WriteComponent(AComponent);
       Writer.WriteListEnd;
     finally
       Writer.Free;
     end;
 
     Stream.Position := 0;
     try
       // создаем поток, перемещающий данные о компоненте в конструктор
       UniqueReader := TUniqueReader.Create(Stream, 4096);
       UniqueReader.OnSetName := UniqueReader.SetNameUnique;
       UniqueReader.LastRead := nil;
 
       if AComponent is TWinControl then
 
         UniqueReader.ReadComponents(
           // считываем компоненты и суб-компоненты
 
           TWinControl(AComponent).Owner,
           TWinControl(AComponent).Parent,
           UniqueReader.ComponentRead
           )
       else
 
         UniqueReader.ReadComponents(
           // читаем компоненты
 
           AComponent.Owner,
           nil,
           UniqueReader.ComponentRead
           );
       result := UniqueReader.LastRead;
     finally
       UniqueReader.Free;
     end;
   finally
     Stream.Free;
   end;
 end;
 




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

Автор: Xavier

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


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

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


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




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


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




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

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


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




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

Виндоват - испраглюсь!


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

ещё...


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




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

Автор: Lindsay Reichmann

Возможен ли вызов функций редактора полей (Fields Editor) во время выполнения программы?

Да. Если вы определили поля во время разработки приложения, то во время выполнения можно менять их свойства (например, Size).

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


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




RTTI в действии

Интернетчик проснулся ночью. Смотрит - вокруг темно, фонари не горят, ничего не видно. "Network is unreachable", - подумал Интернетчик.

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

Для справки:

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

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

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


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

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


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

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




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

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


 If ( Sender is TLabel ) then..
 

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


 TLabel( Sender ).Caption
 

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


 formname:=(myform as tobject).name;
 

или


 formname:=(myform as tcontrol).name;
 

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

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


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

Это даст желаемый эффект без дополнительного кодирования в обработчике формы OnCreate.

'Sender' может и не быть формой, которую вы пытаетесь обработать, и ваша программа получит исключительную ситуацию, сообщающую о неверном приведении типа. Я не уверен в том, что содержание (если оно есть) Sender в действительности является самой формой.

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


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

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


 Label1.Caption := Form1.Name ;
 

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


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


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

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


 name := 'AName';
 

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


 name := 'MyForm';
 

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




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

Автор: Mike Scott

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

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

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


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




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

Землетрясение в Штатах сорвало выступление Билла Гейтса. Наконец-то старый спор всех пользователей компьютеров: "кто главнее и круче - Билл или Бог?" полностью разрешен в пользу последнего. Билли посрамлен.


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




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

"Се, гpядет с облаками, и yзpит Его всякое око. И возpыдают пеpед Hим все племена земные. Ей, аминь." - так или пpимеpно так дpевний пpозаик Иоанн по пpозвищy Богослов пpоpочествyет в своих "Откpовениях" о гpядyщем yжасном WINDOWS.

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


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

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


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




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

Фидошник едет в тpоллейбyсе и оpет:
- Сакс, сакс!!!!
Бабyлька pядом говоpит емy:
- Hy что все сакс, да сакс... Ты еще какие-нибyдь слова знаешь?
- Да, Windows...
- А что это?
- САКС!!!!!


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




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

Автор: Thomas von Stetten

Новость: фирма MICROSOFT, для увеличения надёжности работы своего сервера, установила на него операционную систему UNIX.

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


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


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




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

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


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

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

  • Desk.cpl - свойства экрана
  • Inetcpl.cpl - свойства Internet
  • Intl.cpl - свойства "Язык и Стандарты"
  • Joy.cpl - игровые устройства
  • Mmsys.cpl - свойства мультимедиа
  • Modem.cpl - свойства модемы
  • Netcpl.cpl - сеть
  • Odbccp32.cpl - ODBC Data Source Administrator
  • Password.cpl - свойства пароли
  • Powercfg.cpl - свойства "Управление электропитанием"
  • Access.cpl - свойства "Специальные возможности"
  • Sticpl.cpl - свойства "Сканеры м камеры"
  • Sysdm.cpl - свойства системы
  • Telephon.cpl - параметры набора номера
  • Appwiz.cpl - установка и удаление программ
  • Main.cpl - мышь
  • Timedate.cpl - свойства "Дата и время"
  • dtccfg.cpl - настройка клиента MS DTC
  • Mlcfg32.cpl - свойства Microsoft Outlook
  • Findfast.cpl - Microsoft FrontPage
  • bdeadmin.cpl - BDE Administrator
  • ibmgr.cpl - Interbase manager



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

Автор: Shadow

Предлагаю Вашему вниманию пример, который изменяет приоритет приложения. Изменение приоритета следует использовать с осторожностью, так как присвоение слишком высокого приоритета может привести к медленной работе остальных программ и системы в целом. См. Win32 help for SetThreadPriority() function.

Пример:


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




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

- Что делать, если мышь уже дошла до края коврика, а курсор еще не дошел до края экрана?
Возможные ответы:
- перестать пользоватся мышью
- выбросить такой маленький коврик
- купить новый "экран"
- осторожно придерживая большим пальцем курсор мыши, двигать монитор
- прогнать драйвер мыши под отладчиком
- Windows СУКС, этот Билли даже мышь нормальную не может сделать, Linux forever!
- запустить антивирус!
- да у тебя просто руки кривые!
- сколько раз можно задавать один и тот же вопрос, предлагаю внести его в FAQ
- Е...! про мышей - это не к нам


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




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


В зоопаpке pебенок, возбужденно тыча пальцем
на клетку с пpиматами (обезьянами :), кpичит:
- Мама ! Мама ! Смотpи - пpогpаммисты !
- Почему ты так pешил ?
- Они как папа ! - не мытые, лохматые и мозоль на попе !!!


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




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

О, Гюльчатай, сними же свой скринсейвер!

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


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




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

Автор: Nomadic

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

Функция должна быть __stdcall (или WINAPI, что то же самое ;)) и иметь четыре аргумента. Первый - HWND окна, порождаемого rundll32 (можно использовать в качестве owner'а своих dialog box'ов), второй - HINSTANCE задачи, третий - остаток командной строки (LPCSTR, даже под NT), четвертый - не знаю ;).

Hапример -

int __stdcall __declspec(dllexport) Test
 (
 HWND hWnd,
 HINSTANCE hInstance,
 LPCSTR lpCmdLine,
 DWORD dummy
 )
 {
 MessageBox(hWnd, lpCmdLine, "Command Line", MB_OK);
 return 0;
 }
Исполняем таким образом -
rundll32 test.dll,_Test@16 this is a command line
выдаст message box со строкой "this is a command line".

На Паскале -


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

Давненько я ждал эту инфоpмацию! Сел пpовеpять и наткнулся на очень забавную вещь. А именно -- пусть у нас есть исходник на Си пpимеpно такого вида:

int WINAPI RunDll( HWND hWnd, HINSTANCE hInstance, LPCSTR lpszCmdLine, DWORD dummy );
 ......
 int WINAPI RunDllW( HWND hWnd, HINSTANCE hInstance, LPCWSTR lpszCmdLine, DWORD dummy );
 ......
и .def-файл пpимеpно такого вида:
EXPORTS
 RunDll
 RunDllA=RunDll
 RunDllW

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




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

Автор: Олег Кулабухов

Заходит старушка в трамвай, предупреждая всех что у нее в сумке яйца. Проходя мимо молодого человека, задевает его маленький мешочек. ОН:
- Ах..., острожнее, тв@ю мать.
ОНА, слегка ударяя по мешку ножкой:
- А что у тебя там?
ОН, ударяя ногой по ее сумке со всей дури и разбивая к чертям собачьим все яйца.
- ДУРА! Там же ВИНЧЕСТЕР!


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




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

- Почему программисты не заливают в машину 95-й бензин?
- Боятся, что повиснет.

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


 function ServiceStart(aMachine, aServiceName: string ): boolean;
 // aMachine это UNC путь, либо локальный компьютер если пусто
 var
   h_manager,h_svc: SC_Handle;
   svc_status: TServiceStatus;
   Temp: PChar;
   dwCheckPoint: DWord;
 begin
   svc_status.dwCurrentState := 1;
   h_manager := OpenSCManager(PChar(aMachine), nil, SC_MANAGER_CONNECT);
   if h_manager > 0 then
   begin
     h_svc := OpenService(h_manager, PChar(aServiceName),
     SERVICE_START or SERVICE_QUERY_STATUS);
     if h_svc > 0 then
     begin
       temp := nil;
       if (StartService(h_svc,0,temp)) then
         if (QueryServiceStatus(h_svc,svc_status)) then
         begin
           while (SERVICE_RUNNING <> svc_status.dwCurrentState) do
           begin
             dwCheckPoint := svc_status.dwCheckPoint;
             Sleep(svc_status.dwWaitHint);
             if (not QueryServiceStatus(h_svc,svc_status)) then
               break;
             if (svc_status.dwCheckPoint < dwCheckPoint) then
             begin
               // QueryServiceStatus не увеличивает dwCheckPoint
               break;
             end;
           end;
         end;
       CloseServiceHandle(h_svc);
     end;
     CloseServiceHandle(h_manager);
   end;
   Result := SERVICE_RUNNING = svc_status.dwCurrentState;
 end;
 
 
 function ServiceStop(aMachine,aServiceName: string ): boolean;
 // aMachine это UNC путь, либо локальный компьютер если пусто
 var
   h_manager, h_svc: SC_Handle;
   svc_status: TServiceStatus;
   dwCheckPoint: DWord;
 begin
   h_manager:=OpenSCManager(PChar(aMachine),nil, SC_MANAGER_CONNECT);
   if h_manager > 0 then
   begin
     h_svc := OpenService(h_manager,PChar(aServiceName),
     SERVICE_STOP or SERVICE_QUERY_STATUS);
     if h_svc > 0 then
     begin
       if(ControlService(h_svc,SERVICE_CONTROL_STOP, svc_status))then
       begin
         if(QueryServiceStatus(h_svc,svc_status))then
         begin
           while(SERVICE_STOPPED <> svc_status.dwCurrentState)do
           begin
             dwCheckPoint := svc_status.dwCheckPoint;
             Sleep(svc_status.dwWaitHint);
             if(not QueryServiceStatus(h_svc,svc_status))then
             begin
               // couldn't check status
               break;
             end;
             if(svc_status.dwCheckPoint < dwCheckPoint)then
               break;
           end;
         end;
       end;
       CloseServiceHandle(h_svc);
     end;
     CloseServiceHandle(h_manager);
   end;
   Result := SERVICE_STOPPED = svc_status.dwCurrentState;
 end;
 

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


 function ServiceGetStatus(sMachine, sService: string ): DWord;
 var
   h_manager, h_service: SC_Handle;
   service_status: TServiceStatus;
   hStat: DWord;
 begin
   hStat := 1;
   h_manager := OpenSCManager(PChar(sMachine) ,nil, SC_MANAGER_CONNECT);
   if h_manager > 0 then
   begin
     h_svc := OpenService(h_manager,PChar(sService), SERVICE_QUERY_STATUS);
     if h_svc > 0 then
     begin
       if(QueryServiceStatus(h_svc, service_status)) then
         hStat := service_status.dwCurrentState;
       CloseServiceHandle(h_svc);
     end;
     CloseServiceHandle(h_manager);
   end;
   Result := hStat;
 end;
 

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

  • SERVICE_STOPPED
  • SERVICE_RUNNING
  • SERVICE_PAUSED
  • SERVICE_START_PENDING
  • SERVICE_STOP_PENDING
  • SERVICE_CONTINUE_PENDING
  • SERVICE_PAUSE_PENDING

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




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


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




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


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




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

Надпись на могиле пpогpаммеpа:
Пpичина смеpти: Run-time error at 18:12:97
Пpичина pождения: GPF at: 18:12:97

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

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


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

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

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


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

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

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


 Memo4
 Memo1
 Memo3
 Memo2
 
 

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


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

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


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

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




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

Для dBase:


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

Для Paradox:


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

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

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

Пpимеp для Paradox:


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




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

Сдает новый русский компьютер по гарантии. Смотрят - у монитора здоровенная дыра пробита в правом нижнем углу.
- Как же это так?
- Да вы чё мне продали!!! Я полгорода держу!!! Передо мною вся братва строится!!! А тут какая-то скрепка мне пальцами да у виска крутит!!!


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




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

Автор: Eugene Kasnerik

Приказ министра обороны по русификации сообщений WINDOWS.
Yes - Есть!
No - Никак нет!
OK - Так точно!
Pause - Можно оправиться и закурить.
Stop - Смирно!
Continue - Вольно!
Abort - Расстрелять!
Retry - Кругом!
Ignore - Выполнить любой ценой!
Login - Стой, кто идет?
Password - Предъявите пропуск!
Shutdown - Отбой!
Access denied - Не положено!
Message - Рапорт.
Exception - Нештатная ситуация.
А вместо слова WINDOW, приказываю использовать - АМБРАЗУРА.

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

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

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

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

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

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

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


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

на:


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

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

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

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

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


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

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


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

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

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


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

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




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

Автор: Lloyd

Функция Soundex определяет схожесть звучания двух слов. Алгоритм Soundex опубликован в одной из статей журнала PC Magazine и предназначен для работы с английским языком (может кто-нибудь портирует для работы с нашим могучим? Пишите). Функции передается строка. Возвращаемое Soundex значение также имеет тип строки. Эта величина может сохраняться в базе данных или сравниваться с другим значением Soundex. Если два слова имеют одинаковое значение Soundex, можно предположить, что звучат они одинаково (более или менее).

Вы должны иметь в виду, что алгоритм Soundex игнорирует первую букву слова. Таким образом, "won" и "one" будут иметь различное значение Soundex, а "Won" и "Wunn" - одинаковое.

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


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

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


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

Дополнение

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

Пример:

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



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

В трамвае:
- Девушка! А девушка! А вы наверно программистка?
- Да, но как вы догадались?!!
- У вас очень глупое лицо!
- ДУРАК!!!
- Да, я тоже программист...

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

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

  • заголовок
  • заголовок для нашего RCDATA ресурса
  • собственно данные - RCDATA ресурс

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

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


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

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

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


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

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

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

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

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


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

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

ResID
тот же самый ID , который был присвоен ресурсу
ResType: WAVEFILE, BITMAP, CURSOR, CUSTOM
это типы ресурсов, с которыми возможно работать, но у меня получилось успешно проделать процедуру только с CUSTOM
FileName
это имя файла, который мы хотим создать из ресурса



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

Автор: Steve Schafer

Format винту не товарищ.

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


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

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


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

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


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




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

Автор: Michael Vincze

Я решил проблему записи массива TBitmap в файл и его повторного чтения.

Идея заключается в загрузке каждого TBitmap во временный TMemoryStream. Член TMemoryStream.Size информирует о размере данных, которые нужно сохранить на диске. Затем мы пишем размер и сопровождаем его данными типа TFileStream. Эту манипуляцию мы проделываем для каждого TBitmap в массиве.

Для процедуры чтения сначала мы должны считать из потока размер данных TBitmap. Затем мы распределяем область для типа TMemoryStream полученного размера и считываем данные. Затем переписываем из TFileStream в TMemoryStream. И, наконец, мы читает из TMemoryStream сам TBitmap. Эту манипуляцию мы проделываем для каждого TBitmap в массиве.

Ниже я привел код, который я реально использовал. Код из игры Bingo, которую я разрабатываю, имеет сетку 5x5, чьи ячейки содержат изображение.

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


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




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

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


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




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

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


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




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

Автор: Vladimir Timonin

[Q:]Мне нужно использовать clipboard для сохранения данных в собственном формате и я хочу для этого написать набор процедур ввода/вывода с использованием потоков (streams). Возможно ли создать объект TMemoryStream, эаполнить его и поместить в Clipboard?

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

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

Далее вы должны выполнить шаги:

1. Создать поток (memory stream) и записать туда данные.
2. Создать глобальный буфер в памяти и скопировать поток туда.
3. Вызвать Clipboard.SetAsHandle(), чтобы поместить буфер в Clipboard.

Пример:


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

Внимание: не уничтожайте буфер, созданный с GlobalAlloc. Поскольку вы поместили его в Clipboard, это уже дело clipboard'а его уничтожить. Опять же, получая буфер из Clipboard, не уничтожайте этот буфер - просто сделайте копию содержимого.

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


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




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

РЕКЛАМА!!!
Телефонный звонок в 2 часа ночи. Сонный мужик подходит к телефону:
- АЛЛО?!!!
Тишина. Кладет трубку. Ровно через 45 секунд опять звонок.
- АЛЛО?!!!!
Тишина. И так повторяентся 74 раза с регулярностью 45 секунд. Мужик:
- ПИИИИИИИи (длинный продолжительный писк, которым на телевидении заглушают матные слова) На другом конце провода довольный СисОп с лыбой во всю широту натуры, обнимающий небольшую коробочку. Голос за кадром:
- Делай всё, что тебе нравится вместе с модемом ZyXel!!!


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




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


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




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

Приведу код WindowRestorer - восстановителя размера и состояния окна.

ОПИСАНИЕ: Вы наверное замечали, что профессионально написанные программы "запоминают" состояние и позицию окон с момента их последнего показа? А большинство RAD-приложений это игнорируют? Вы можете исправить эту ошибку, взяв на вооружение этот модуль. Он позволяет сохранять позицию, размер и состояние окна, поэтому пользователь, открыв его вновь, увидит его в том же состоянии, в котором он видел его в последний раз.

ИСПОЛЬЗОВАНИЕ: Поместите WINRSTOR в список используемых модулей главной или любой другой формы, состояние, размер и позицию которой вы хотите сохранить. (Если вы сэкономить время и для восстановления дочерних форм использовать WinSaveChildren и WinRestoreChildren из главной формы, вы должны объявить этот модуль только в главной форме.)

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


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

Или так:


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

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


 GlobalWinRestorer.free;
 

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


 GlobalWinRestorer.SaveChildren(Self, [default]);
 

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


 GlobalWinRestorer.SaveWin(Self, [WHATSAVE_ALL]);
 

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


 GlobalWinRestorer.RestoreWin(Self, [default]);
 

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


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

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


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




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

Пришел програмист фотки печатать дал негатив служащим а они его спрашивают:
- В каком формате печатать?
- В "jpg" конечно

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


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




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

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

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

Начнем с TMailClient.


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

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


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

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


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

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

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


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

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


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

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


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

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

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

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


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




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


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




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

Привет, дорогая моя! Наконец-то я добилась от этого придурка разрешения пользоваться компьютером! Он даже сделал мне собственный почтовый ящик, так что теперь мы сможем общаться не только по телефону. Пиши мне на адрес ***@JIZNI.NET

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


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




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


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




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

Разговор двух украинских программистов.
- Слышь Микола, как москали КД-ПЗУ называют?
- Как?
- CD-ROM!
- Поубывал бы.


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




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

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

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


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




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

Приведенный ниже модуль демонстрирует принцип использования GetDeviceCaps для получения исчерпывающей информации о вашем принтере, включая HORZRES и VERTRES (горизонтальное и вертикальное разрешение в пикселах) на дюйм бумаги. Используя значения LOGPIXELSX и LOGPIXELSY, вы можете откалибровать принтер для точного задания количества точек на дюйм в горизонтальном и вертикальном направлениях.

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

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


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




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

Автор: Mike Scott

Сын системного администратора перед сном просит папу:
- Па-па... Расскажи сказку про умного, толкового, доброго, смелого юзера...

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

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


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

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




<< ВЕРНУТЬСЯ В ОГЛАВЛЕНИЕ



Материалы находятся на сайте https://exelab.ru/pro/



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


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