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

ВИДЕОКУРС ВЗЛОМ
выпущен 2 сентября!


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

БОЛЬШОЙ FAQ ПО DELPHI



Список шрифтов, совместимых одновременно с экраном и с принтером

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

Пример:


 uses Printers, CommDlg;
 
 procedure TForm1.Button1Click(Sender: TObject);
  var cf: TChooseFont; lf: TLogFont; tf: TFont;
 begin
   if PrintDialog1.Execute then
   begin
     cf.hdc := Printer.Handle;
     cf.lpLogFont := @lf;
     cf.iPointSize := Form1.Canvas.Font.Size * 10;
     cf.Flags := CF_BOTH or CF_INITTOLOGFONTSTRUCT or
      CF_EFFECTS or CF_SCALABLEONLY or CF_WYSIWYG;
     cf.rgbColors := Form1.Canvas.Font.Color;
     tf.COlor := cf.RgbColors;
     Form1.Canvas.Font.Assign(tf);
     tf.Free;
     Form1.Canvas.TextOut(10, 10, 'Test');
   end;
 end;
 




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

Автор: Ralph Friedman

Сын программера приходит из школы. Отец:
- Как диктант?
- Да так. Всего две ошибки. Hо, в общем, скомпилировался.

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

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

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

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


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

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




Пособие по написанию компонентов

Содержание:

  • Почему я сел писать это пособие
  • Начало. Для чего нужны компоненты
  • Шаг 1. Придумывание идеи
  • Шаг 2. Создание пустого модуля компонента
  • Шаг 3. Начинаем разбираться во всех директивах
  • Шаг 4. Пишем процедуры и функции.
  • Шаг 5. Устанавливаем компонент

Теперь изучим более сложные вещи:

  • Создание свойств своего типа
  • Имплантируем таймер в компонент
  • Переустановка компонента
  • Дополнительная информация

Почему я сел писать это пособие

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

Для чего нужны компоненты

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

Шаг 1. Придумывание идеи

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

Для создания нового класса можно выделить 4 случая:

  1. Создание Windows-элемента управления (TWinControl)
  2. Создание графического элемента управления (TGraphicControl)
  3. Создание нового класса или элемента управления (TCustomControl)
  4. Создание невизуального компонента (не видимого) (TComponent)

Теперь попробую объяснить что же такое визуальные и невизуальные компоненты. Визуальные компоненты видны во время работы приложения, с ними напрямую может взаимодействовать пользователь, например кнопка Button - является визуальным компонентом.

Невизуальные компоненты видны только во время разработки приложения (Design-Time), а во время работы приложения (Run-Time) их не видно, но они могут выполнять какую-нибудь работу. Наиболее часто используемый невизуальный компонент - это Timer.

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

Шаг 2. Создание пустого модуля компонента

Рассматривать этот шаг я буду исходя из устройства Дельфи 3, в других версиях этот процесс не сильно отличается. Давайте попробуем создать кнопку, у которой будет доступна информация о количестве кликов по ней.

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

Закройте проекты, которые вы разрабатывали (формы и модули)

В основном меню выберите Component -> New Component...

Перед вами откроется диалоговое окно с названием "New Component"

В поле Ancestor Type (тип предка) выберите класс компонента, который вы хотите модифицировать. В нашем случае вам надо выбрать класс TButton

В поле Class Name введите имя класса, который вы хотите получить. Имя обязательно должно начинаться с буквы "T". Мы напишем туда, например, TCountBtn

В поле Palette Page укажите имя закладки на которой этот компонент появиться после установки. Введем туда MyComponents (теперь у вас в Делфьи будет своя закладка с компонентами!).

Поле Unit File Name заполняется автоматически, в зависимости от выбранного имени компонента. Это путь куда будет сохранен ваш модуль.

В поле Search Path ничего изменять не нужно.

Теперь нажмите на кнопку Create Unit и получите следующее:


 unit CountBtn;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls;
 
 type
   TCountBtn = class(TButton)
   private
     { Private declarations }
   protected
     { Protected declarations }
   public
     { Public declarations }
   published
     { Published declarations }
 end;
 
 procedure register;
 
 implementation
 
 procedure register;
 begin
   RegisterComponents('MyComponents', [TCountBtn]);
 end;
 
 end.
 

Шаг 3. Начинаем разбираться во всех директивах

Что же здесь написано? да собственно пока ничего интересного. Здесь объявлен новый класс TCountBtn и процедура регистрации вашего компонента в палитре компонентов.

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


 FCount: integer;
 

Буква "F" должна присутсвовать обязательно. Здесь мы создали скрытое поле Count, в котором и будет храниться число кликов по кнопке.

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


 procedure Click; override;
 

Это указывает на то, что мы будем обрабатывать щелчок мыши по компоненту. Слово "override" указывает на то, что мы перекроем стандартное событие OnClick для компонента предка.

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


 procedure ShowCount;
 

Осталась последняя директива Published. В ней также используется объявления доступных пользователю, свойств и методов компонента. Для того, чтобы наш компонент появился на форме необходимо описать метод создания компонента (конструктор), можно прописать и деструктор, но это не обязательно. Следует обратить внимание на то, что если вы хотите, чтобы какие-то свойства вашего компонента появились в Инспекторе Объектов (Object Inspector) вам необходимо описать эти свойства в директиве Published. Это делается так: property Имя_свойства (но помните здесь букву "F" уже не нужно писать), затем ставиться двоеточие ":" тип свойства, read процедура для чтения значения, write функция для записи значения;. Но похоже это все сильно запутано. Посмотрите, что нужно написать для нашего компонента и все поймете:


 constructor Create(aowner: Tcomponent); override; //Конструктор
 property Count: integer read FCount write FCount; //Свойство Count
 

Итак все объявления сделаны и мы можем приступить к написанию непосредственно всех объявленных процедур.

Шаг 4. Пишем процедуры и функции.

Начнем с написания конструктора. Это делается примерно так:


 constructor TCountBtn.Create(aowner:Tcomponent);
 begin
   inherited create(Aowner);
 end;
 

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

Теперь мы напишем процедуру обработки щелчка мышкой по кнопке:


 procedure Tcountbtn.Click;
 begin
   inherited click;
   FCount := FCount + 1;
 end;
 

"Inherited click" означает, что мы повторяем стандартные методы обработки щелчка мышью (зачем напрягаться и делать лишнюю работу:)).

У нас осталась последняя процедура ShowCount. Она может выглядеть примерно так:


 procedure TCountBtn.ShowCount;
 begin
   Showmessage('По кнопке '+ caption+' вы сделали: '+inttostr(FCount)+' клик(а/ов)');
 end;
 

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

И если вы все поняли и сделали правильно, то у вас должно получится следующее:


 unit CountBtn;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls, ExtCtrls;
 
 type
   TCountBtn = class(TButton)
   private
     { Private declarations }
     FCount: integer;
   protected
     { Protected declarations }
     procedure Click; override;
   public
     { Public declarations }
     procedure ShowCount;
   published
     { Published declarations }
     property Count: integer read FCount write FCount;
     constructor Create(aowner: Tcomponent); override;
   end;
 
 procedure register;
 
 implementation
 
 procedure register;
 begin
   RegisterComponents('DelphiWorld Components', [TCountBtn]);
 end;
 
 constructor TCountBtn.Create(aowner:Tcomponent);
 begin
   inherited create(Aowner);
 end;
 
 procedure Tcountbtn.Click;
 begin
   inherited click;
   FCount := FCount + 1;
 end;
 
 procedure TCountBtn.ShowCount;
 begin
   Showmessage('По кнопке '+ caption+' вы сделали: '+
   inttostr(FCount)+' клик(а/ов)');
 end;
 
 end.
 

Скорее сохраняйтесь, дабы не потерять случайным образом байты набранного кода:)).

Шаг 5. Устанавливаем компонент

Если вы сумели написать и понять, все то что здесь предложено, то установка компонента не должна вызвать у вас никаких проблем. Все здесь делается очень просто. В главном меню выберите пункт Component -> Install Component. перед вами открылось диалоговое окно Install Component. В нем вы увидите две закладки: Into exsisting Package и Into new Package. Вам предоставляется выбор установить ваш компонент в уже существующий пакет или в новый пакет соответственно. Мы выберем в уже существующий пакет.

В поле Unit File Name напишите имя вашего сохранненого модуля (естественно необходимо еще и указать путь к нему), а лучше воспользуйтесь кнопкой Browse и выберите ваш файл в открывшемся окне.

В Search Path ничего изменять не нужно, Делфьи сама за вас все туда добавит.

В поле Package File Name выберите имя пакета, в который будет установлен ваш компонент. Мы согласимся с предложенным по умолчанию пакетом.

Теперь нажимаем кнопочку Ok. И тут появиться предупреждение Package dclusr30.dpk will be rebuilt. Continue? Дельфи спрашивает: "Пакет такой-то будет изменен. Продолжить?". Конечно же надо ответить "Да". И если вы все сделали правильно, то появиться сообщение, что ваш компонент установлен. Что ж можно кричать Ура! Это ваш первый компонент.

Создание свойств своего типа

Теперь мы попробуем создать свойство нестандартного типа. Рассмотрим это на примере метки - TLabel. У этого компонента есть такое свойство: Alignment. Оно может принимать следующие значения: taLeftJustify, taCenter, taRightJustify. Приступаем к созданию свойства. Ничего интересного мне придумать не удалось, но тем не менее я вам покажу это на примере того свойства, которое я придумал. Оно очень простое и поможет вам разобраться. Свойство будет называться ShowType (тип TShowTp), в нашем компоненте оно будет отвечать за отображение свойства Count. Если пользователь установит свойство ShowType в Normal, то кнопка будет работать, как и работала. А если пользователь присвоит этому свойтсву значение CountToCaption, то количество кликов, будет отображаться на самой кнопке.

Для начале нам необходимо объявить новый тип. Описание типа нужно добавить после слова Type. Вот так это выглядело вначале:


 type
   TCountBtn = class(TButton)
 

Вот так это должно выглядеть:


 type
   TShowTp = (Normal, CountToCaption);
   TCountBtn = class(TButton)
 

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

Теперь нам понадобиться создать поле этого типа. Это мы уже умеем и делать и поэтому не должно вызвать никаких сложностей. В директиву Private напишите:


 FShowType: TShowTp;
 

Мы создали поле ShowType, типа TShowTp.

Конечно же необходимо добавить это свойство в инспектор объектов:


 property ShowType: TshowTp read FshowType write FShowType;
 

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


 procedure Tcountbtn.Click;
 begin
   inherited click;
   FCount := Fcount + 1;
   if ShowType = Normal then
     Caption := Caption;
   if ShowType = CountToCaption then
     Caption := 'Count = ' + inttostr(count);
 end;
 

Объясню что произошло. Вначале мы увеличиваем счетчик на единицу. Затем проверяем какое значение имеет свойство ShowType. Если Normal, то ничего не делаем, а если CountToCaption, то в надпись на кнопке выводим количество кликов. Не так уж и сложно как это могло показаться с первого раза.

Имплантируем таймер в компонент

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

После раздела uses, где описаны добавленные в программу модули, объявите переменную типа TTimer. Назовем ее Timer. Приведу небольшой участок кода:


 unit CountBtn;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls, ExtCtrls;
 
 var
   Timer: TTimer;
 
 type
 

Дальше в директиву Protected необходимо добавить обработчик события OnTimer для нашего таймера. Это делается так:


 procedure OnTimer(Sender: TObject);
 

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


 constructor TCountBtn.Create(aowner: Tcomponent);
 begin
   inherited create(Aowner);
   Timer := TTimer.Create(self);
   Timer.Enabled := true;
   Timer.OnTimer := OnTimer;
   Timer.Interval := 10000;
 end;
 

Здесь создается экземпляр нашего таймера и его свойству Iterval (измеряется в миллисекундах) присваивается значение 10000 (то есть 10 секунд если по простому).

Собственно осталось написать саму процедуру OnTimer. Я сделал это так:


 procedure TCountBtn.OnTimer(Sender: TObject);
 begin
   FCount := FCount * 2;
 end;
 

Вот примерно то, что у вас должно получиться в конце:


 unit CountBtn;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls, ExtCtrls;
 
 var
   Timer: TTimer;
 
 type
   TShowTp = (Normal, CountToCaption);
   TCountBtn = class(TButton)
   private
     { Private declarations }
     FCount: integer;
     FShowType: TShowTp;
   protected
     { Protected declarations }
     procedure OnTimer(Sender: TObject);
     procedure Click; override;
   public
     { Public declarations }
     procedure ShowCount;
   published
     { Published declarations }
     property Count: integer read FCount write FCount;
     constructor Create(aowner: Tcomponent); override;
     property ShowType: TshowTp read FshowType write FShowType;
   end;
 
 procedure register;
 
 implementation
 
 procedure register;
 begin
   RegisterComponents('Mihan Components', [TCountBtn]);
 end;
 
 constructor TCountBtn.Create(aowner:Tcomponent);
 begin
   inherited create(Aowner);
   Timer:=TTimer.Create(self);
   Timer.Enabled:=false;
   Timer.OnTimer:=OnTimer;
   Timer.Interval:=1000;
 end;
 
 procedure Tcountbtn.Click;
 begin
   inherited click;
   FCount:=Fcount+1;
   Timer.Enabled:=true;
   if ShowType = Normal then
     Caption:=Caption;
   if ShowType = CountToCaption then
     Caption:='Count= '+inttostr(count);
 end;
 
 procedure TCountBtn.ShowCount;
 begin
   Showmessage('По кнопке '+ caption+' вы сделали: '+
   inttostr(FCount)+' клик(а/ов)');
 end;
 
 procedure TCountBtn.OnTimer(Sender: TObject);
 begin
   FCount:=FCount*2;
 end;
 
 end.
 

Если у вас что-то не сработало, то в начале проверьте все ли у вас написано правильно. Затем проверьте может у вас не хватает какого-нибудь модуля в разделе Uses.

Переустановка компонента

Очень часто бывает необходимо переустановить ваш компонент. Если вы попробуете сделать это путем выбора Component->Install Component, то Дельфи вас честно предупредит о том, что пакет уже содержит модуль с таким именем. Перед вами открывается окно с содержимым пакета. В нем вы должны найти имя вашего компонента и удалить его (либо нажать кнопочку Remove). Теперь в пакете уже нет вашего компонента. Затем проделайте стандартную процедуру по установке компонента.




Компонент DirectoryTree

Данный компонент действует и выглядит аналогично левой части окна Проводника в Windows. Компонент позволяет выбирать диск (дисковод) и / или директорию и реагировать на событие OnChange. Компонент правильно работает даже во время прорисовки, то есть не даст открыть диск во время прорисовки.

Компонент будет зарегистрирован как 'Samples'.


 unit DirectoryTree;
 
 {$R-,T-,H+,X+}
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
   Dialogs, ComCtrls, ImgList, StdCtrls, FileCtrl;
 
 const
   Rootname : string = 'My Computer';
 
 type
   TDirectoryTree = class(TCustomTreeView)
   private
     { Private declarations }
     fImageList : TCustomImageList;
     fDirectory : string;
     fOnChange : TNotifyEvent;
     fDirLabel : TLabel;
     fDirLabelSet : Boolean;
     fFileList : TFileListbox;
     fDirList : TDirectoryTree;
     fTreenodes : TTreenodes;
     fCurDrive : string;
 
     //Procedure SetDirLabel(Value : TLabel);
     //Procedure SetDirLabelCaption;
     procedure FindDirs(S : string; T : TTreenode);
     procedure GetNodeInfo(T : TTreenode);
     procedure fChanges; dynamic;
     //Procedure SetFileListBox(Value : TFileListBox);
     //Function MinimizeName(const Filename : TFileName;
     // Canvas : TCanvas; MaxLen : Integer): TFileName;
     //procedure CutFirstDirectory(var S : TFileName);
 
   protected
     { Protected declarations }
     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
     X, Y: Integer); override;
 
   public
     { Public declarations }
     constructor Create(AOwner : TComponent); override;
     destructor Destroy; override;
     procedure UpDate; reintroduce;
     procedure FindDrives; dynamic;
     procedure CreateWnd; override;
 
   published
     { Published declarations }
     {--- свойства ---}
     property Align;
     property Anchors;
     //Property AutoExpand;
     //Property BiDiMode;
     //Property BorderStyle;
     //Property BorderWidth;
     //Property ChangeDelay;
     property Color;
     property Constraints;
     property Cursor;
     //Property DirLabel : TLabel
     // read fDirLabel write SetDirLabel;
     property Directory : string
     read fDirectory write fDirectory;
     property DragCursor;
     property DragKind;
     property DragMode;
     property Enabled;
     //Property FileList : TFileListbox
     // read fFileList write SetFileListbox;
     property Font;
     property Height;
     property HelpContext;
     //Property HideSelection;
     property Hint;
     //Property HotTrack;
     //Property Images;
     //Property Indent;
     //Property Items;
     property Left;
     property name;
     //Property ParentBiDiMode;
     property ParentColor;
     property ParentFont;
     property ParentShowHint;
     property PopupMenu;
     //Property ReadOnly;
     //Property RightClickSelect;
     //Property RowSelect;
     //Property ShowButtons;
     property ShowHint;
     //Property ShowLines;
     //Property ShowRoot;
     //Property SortType;
     //Property StateImages;
     property TabOrder;
     property TabStop;
     property Tag;
     //Property ToolTips;
     property Top;
     property Visible;
     property Width;
 
     {--- События ---}
 
     //Property OnAdvancedCustomDraw;
     //Property OnAdvancedCustomDrawItem;
     property OnChange : TNotifyEvent
     read fOnChange write fOnChange;
     //Property OnChanging;
     property OnClick;
     //Property OnCollapsed;
     //Property OnCollapsing;
     //Property OnCompare;
     //Property OnContextPopup;
     //Property OnCustomDraw;
     //Property OnCustomDrawItem;
     property OnDblClick;
     //Property OnDeletion;
     property OnDragDrop;
     property OnDragOver;
     //Property OnEdited;
     //Property OnEditing;
     //Property OnEndDock;
     property OnEndDrag;
     property OnEnter;
     property OnExit;
     //Property OnExpanded;
     //Property OnExpanding;
     //Property OnGetImageIndex;
     //Property OnGetSelectedIndex;
     property OnKeyDown;
     property OnKeyPress;
     property OnKeyUp;
     property OnMouseDown;
     property OnMouseMove;
     property OnMouseUp;
     //Property OnStartDock;
     property OnStartDrag;
 end;
 
 procedure register;
 
 // Загружаем bitmap-ы, 16 x 16 бит, 256 цветов
 {$R IMAGES.RES}
 
 implementation
 
 
 (* Из исходников Delphi 5:
 c:\program files\borland\delphi5\source\vcl\filectrl.pas
 
 Procedure TDirectoryTree.SetFileListBox(Value: TFileListBox);
 
 Begin
 If fFileList <> nil then
 fFileList.DirList := nil;
 fFileList := Value;
 If fFileList <> nil then
 Begin
 fFileList.DirList := Self;
 fFileList.FreeNotification(Self);
 End;
 End; *)
 
 (* Из исходников Delphi 5:
 c:\program files\borland\delphi5\source\vcl\filectrl.pas
 
 Procedure CutFirstDirectory(var S: TFileName);
 
 Var
 Root : Boolean;
 P : Integer;
 
 Begin
 If S = '\' then
 S := ''
 else
 Begin
 If S[1] = '\' then
 Begin
 Root := True;
 Delete(S, 1, 1);
 End
 else
 Root := False;
 If S[1] = '.' then
 Delete(S, 1, 4);
 P := AnsiPos('\',S);
 If P <> 0 then
 Begin
 Delete(S, 1, P);
 S := '...\' + S;
 End
 else
 S := '';
 If Root then
 S := '\' + S;
 End;
 End; *)
 
 (* Из исходников Delphi 5:
 c:\program files\borland\delphi5\source\vcl\filectrl.pas
 
 Function MinimizeName(const Filename: TFileName; Canvas: TCanvas;
 MaxLen: Integer): TFileName;
 
 Var
 Drive : TFileName;
 Dir : TFileName;
 Name : TFileName;
 
 Begin
 Result := FileName;
 Dir := ExtractFilePath(Result);
 Name := ExtractFileName(Result);
 
 If (Length(Dir) >= 2) and (Dir[2] = ':') then
 begin
 Drive := Copy(Dir, 1, 2);
 Delete(Dir, 1, 2);
 end
 else
 Drive := '';
 While ((Dir <> '') or (Drive <> '')) and
 (Canvas.TextWidth(Result) > MaxLen) do
 Begin
 If Dir = '\...\' then
 Begin
 Drive := '';
 Dir := '...\';
 End
 else
 If Dir = '' then
 Drive := ''
 else
 CutFirstDirectory(Dir);
 Result := Drive + Dir + Name;
 End;
 End; *)
 
 (* Из исходников Delphi 5:
 c:\program files\borland\delphi5\source\vcl\filectrl.pas
 
 Procedure TDirectoryTree.SetDirLabel (Value: TLabel);
 
 Begin
 fDirLabel := Value;
 if Value <> nil then
 Value.FreeNotification(Self);
 SetDirLabelCaption;
 End;
 *)
 
 (* Из Delphi:
 c:\program files\borland\delphi5\source\vcl\filectrl.pas
 
 Procedure TDirectoryTree.SetDirLabelCaption;
 
 Var
 DirWidth: Integer;
 
 Begin
 If fDirLabel <> nil then
 Begin
 DirWidth := Width;
 If not fDirLabel.AutoSize then
 DirWidth := fDirLabel.Width;
 fDirLabel.Caption := MinimizeName(Directory, fDirLabel.Canvas,
 DirWidth);
 End;
 End; *)
 
 procedure TDirectoryTree.fChanges;
 begin
   if Assigned(fOnChange) then
     fOnChange(Self);
 end;
 
 procedure TDirectoryTree.FindDirs(S: string; T: TTreeNode);
 var
   Res : Integer;
   SR : TSearchRec;
   T1 : TTreenode;
   S1 : string;
 begin
   S1 := S;
   if S[Length(S)] <> '\' then
     S1 := S1 + '\';
   Res := FindFirst(S1 + '*.*',faAnyFile,SR);
 
   if Res = 0 then
     repeat
       if ((SR.Attr and faDirectory) = faDirectory) then
         if (SR.name <> '.') and (SR.name <> '..') then
         begin
           T1 := Items.AddChild(T,SR.name);
           T1.SelectedIndex := 1; // Diropen.bmp when selected
           T1.HasChildren := True; // Creates a '+' sign
         end;
       Res := FindNext(SR);
     until
       Res <> 0;
 
   FindClose(SR);
 end;
 
 procedure TDirectoryTree.GetNodeInfo(T : TTreenode);
 var
   S : string;
   T1 : TTreenode;
 begin
   S := T.Text;
   if S = Rootname then
     Exit;
   T1 := T;
   repeat
     T1 := T1.Parent;
     if S[2] <> ':' then
       S := T1.Text + '\' + S;
   until
     S[2] = ':';
 
   if T.Count = 0 then
     FindDirs(S,T);
 
   fDirectory := S;
   fChanges;
 end;
 
 procedure TDirectoryTree.FindDrives;
 var
   Tr,T1 : TTreenode;
   ld : DWord;
   I : Integer;
   Drive : string;
 begin
   Items.Clear;
   ld := GetLogicalDrives;
   Tr := Items.Add(nil,Rootname);
   Tr.ImageIndex := 2;
   Tr.SelectedIndex := 2;
   for I := 0 to 25 do
   begin
     if (ld and (1 shl I)) > 0 then
     begin
       Drive := Chr(65 + I) + ':';
 
       T1 := Items.AddChild(Tr,Drive);
       T1.HasChildren := True;
       // Корректируем иконку диска
       case GetDriveType(PChar(Drive[1] + ':\')) of
         0, DRIVE_FIXED :
         begin
           T1.ImageIndex := 3;
           T1.SelectedIndex := 3;
         end;
 
         DRIVE_CDROM :
         begin
           T1.ImageIndex := 4;
           T1.SelectedIndex := 4;
         end;
 
         DRIVE_REMOVABLE :
         begin
           T1.ImageIndex := 5;
           T1.SelectedIndex := 5;
         end;
 
         DRIVE_RAMDISK:
         begin
           T1.ImageIndex := 6;
           T1.SelectedIndex := 6;
         end;
 
         DRIVE_REMOTE :
         begin
           T1.ImageIndex := 7;
           T1.SelectedIndex := 7;
         end;
       ng>end; // конец Case
 
       if fCurDrive = Drive then
         T1.Selected := True; // Выбираем текущий диск
     end;
   end;
 end;
 
 constructor TDirectoryTree.Create(AOwner : TComponent);
 var
   bDirClose,bDirOpen : TBitmap;
   bFloppy,bComputer : TBitmap;
   bHardDisk,bCDRom : TBitmap;
   bRemoteDrive,bRamdisk : TBitmap;
 begin
   inherited Create(AOwner);
   ShowRoot := True;
   readonly := True;
   SortType := stBoth;
   fDirLabelSet := False;
   fDirectory := '';
   fImageList := TCustomImageList.Create(Self);
   fImageList.Clear;
   fImageList.BkColor := clWhite;
   fImageList.BlendColor := clWhite;
   fImageList.Masked := True;
   fImageList.Height := 16;
   fImageList.Width := 16;
   fImageList.AllocBy := 7;
 
   // Загружаем картинку DIRCLOSE
   bDirClose := TBitmap.Create;
   bDirClose.Handle := LoadBitmap(hInstance,'DIRCLOSE');
   // Добавляем в ImageList
   fImageList.Add(bDirClose,g>nil); // 0
   bDirClose.Free;
 
   // Загружаем картинку DIROPEN
   bDirOpen := TBitmap.Create;
   bDirOpen.Handle := LoadBitmap(hInstance,'DIROPEN');
   // Добавляем в ImageList
   fImageList.Add(bDirOpen,g>nil); // 1
   bDirOpen.Free;
 
   // Загружаем картинку COMPUTER
   bComputer := TBitmap.Create;
   bComputer.Handle := LoadBitmap(hInstance,'COMPUTER');
   // Добавляем в ImageList
   fImageList.Add(bComputer,g>nil); // 2
   bComputer.Free;
 
   // Загружаем картинку HARDDISK
   bHardDisk := TBitmap.Create;
   bHardDisk.Handle := LoadBitmap(hInstance,'HARDDISK');
   // Добавляем в ImageList
   fImageList.Add(bHardDisk,g>nil); // 3
   bHardDisk.Free;
 
   // Загружаем картинку CDROMDISK
   bCDRom := TBitmap.Create;
   bCDRom.Handle := LoadBitmap(hInstance,'CDROMDISK');
   // Со словом 'CDROM' возникают проблемы
   // Добавляем в ImageList
   fImageList.Add(bCDRom,g>nil); // 4
   bCDRom.Free;
 
   // Загружаем картинку FLOPPYDISK
   bFloppy := TBitmap.Create;
   bFloppy.Handle := LoadBitmap(hInstance,'FLOPPYDISK');
   // bitmap с именем 'FLOPPY'
   // уже существует
   // Добавляем в ImageList
   fImageList.Add(bFloppy,g>nil); // 5
   bFloppy.Free;
 
   // Загружаем картинку RAMDISK
   bRamDisk := TBitmap.Create;
   bRamDisk.Handle := LoadBitmap(hInstance,'RAMDISK');
   // Добавляем в ImageList
   fImageList.Add(bRamDisk,g>nil); // 6
   bRamDisk.Free;
 
   // Загружаем картинку REMOTEDISK
   bRemoteDrive := TBitmap.Create;
   bRemoteDrive.Handle := LoadBitmap(hInstance,'REMOTEDISK');
   // Добавляем в ImageList
   fImageList.Add(bRemoteDrive,g>nil); // 7
   bRemoteDrive.Free;
 
   Images := fImageList; // Assign the imagelist to TreeView.Images
   // CustomTreeView не имеет никаких treenodes, поэтому мы должны создать их..
   fTreenodes := TTreenodes.Create(Self);
 end;
 
 procedure TDirectoryTree.CreateWnd;
 var
   P : string;
 begin
   inherited CreateWnd;
   GetDir(0,P);
   fCurDrive := UpCase(P[1]) + ':';
   FindDrives; //Является динамическим!!
 end;
 
 procedure TDirectoryTree.MouseDown(Button: TMouseButton;
 Shift : TShiftState; X, Y: Integer);
 var
   T,T1 : TTreenode;
   S : string;
   HT : THitTests;
   I : Integer;
 begin
   inherited MouseDown(Button,Shift,X,Y);
   HT := GetHitTestInfoAt(X,Y);
   if (htOnItem in HT) or (htOnIcon in HT) or (htOnButton in HT) then
   begin
     T := GetNodeAt(X,Y);
     S := T.Text;
     if S = Rootname then
       Exit;
     T1 := T;
     repeat
       T1 := T1.Parent;
       if S[2] <> ':' then
         S := T1.Text + '\' + S;
     until
       S[2] = ':';
     fDirectory := S;
     fChanges;
     I := T.Count;
     GetNodeInfo(T);
     T.Selected := True;
     if T.Count > 0 then
     begin
       if I = 0 then
         T.Expanded := True;
     end
     else
       T.HasChildren := False; // удаляем знаки '-' или '+'
   end;
 end;
 
 procedure TDirectoryTree.Update;
 var
   P: string;
 begin
   GetDir(0,P);
   fCurDrive := UpCase(P[1]) + ':';
   ChDir(fCurDrive);
   FindDrives;
   fChanges;
 end;
 
 destructor TDirectoryTree.Destroy;
 begin
   fImageList.Free; // Удаляем ImageList
   fTreenodes.Free; // Удаляем Treenodes
   inherited Destroy;
 end;
 
 procedure register;
 begin
   RegisterComponents('Samples', [TDirectoryTree]);
 end;
 
 end.
 




Компонент FontListBox

Надеюсь, что любители Delphi уже не один раз приукрашивали всякие ЛистБоксы и тому подобное. Автор исходника предлагает создать этот компонент своими силами. Впрочем, Вы сами можете увидеть как можно играться со шрифтами в ListBox.


 {==================
 
 Написан в Delphi V5.0.
 Тестировался под: Windows 95, version A, servicepack 1
 и Windows NT4.0, servicepack 5.
 
 ==================}
 
 unit FontListBox;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls;
 
 type
   TFontListBox = class(TCustomListbox)
   private
     { Private declarations }
     fFontSample : Boolean; // Добавляемое свойство
     fShowTrueType : Boolean; // Добавляемое свойство
     fCanvas : TControlCanvas; // Необходимо
 
     procedure SetFontSample(B : Boolean); // внутренняя процедура
     procedure SetShowTrueType(B : Boolean); // внутренняя процедура
 
   protected
     { Protected declarations }
     procedure CreateWnd; override;
 
   public
     { Public declarations }
     constructor Create(AOwner : TComponent); override;
     destructor Destroy; override;
     procedure DrawItem(index : Integer; R : TRect;
     State : TOwnerDrawState); override;
 
   published
     { Published declarations }
     { Properties }
     property Fontsample : Boolean // Добавляемое свойство
     read fFontSample write SetFontSample;
     property Align;
     property Anchors;
     property BiDiMode;
     property BorderStyle;
     property Color;
     property Columns;
     property Constraints;
     property Cursor;
     property DragCursor;
     property DragKind;
     property DragMode;
     property Enabled;
     //Poperty ExtendedSelection; Не существует в базовом классе
     property Font;
     property Height;
     property HelpContext;
     property Hint;
     property ImeMode;
     property ImeName;
     property IntegralHeight;
     property Itemheight;
     property Items;
     property Left;
     property MultiSelect;
     property name;
     property ParentBiDiMode;
     property ParentColor;
     property ParentFont;
     property ParentShowHint;
     property PopupMenu;
     property ShowTrueType : Boolean // Добавляемое свойство
     read fShowTrueType write SetShowTrueType;
     property ShowHint;
     property Sorted;
     property Style;
     property TabOrder;
     property TabStop;
     property TabWidth;
     property Tag;
     property Top;
     property Visible;
     property Width;
     { Events }
     property OnClick;
     property OnContextPopup;
     property OnDblClick;
     property OnDragDrop;
     property OnDragOver;
     property OnDrawItem;
     property OnEndDock;
     property OnEnter;
     property OnExit;
     property OnKeyDown;
     property OnKeyPress;
     property OnKeyUp;
     property OnMeasureItem;
     property OnMouseDown;
     property OnMouseMove;
     property OnMouseUp;
     property OnStartDock;
     property OnStartDrag;
 end;
 
 procedure register;
 
 implementation
 
 procedure register; // Hello
 begin
   RegisterComponents('Samples', [TFontListBox]);
 end;
 
 procedure TFontListBox.SetShowTrueType(B : Boolean);
 begin
   if B <> fShowTrueType then
   begin
     fShowTrueType := B;
     Invalidate; // Заставляет апдейтится во время прорисовки
   end;
 end;
 
 procedure TFontListBox.SetFontSample(B : Boolean);
 begin
   if fFontSample <> B then
   begin
     fFontSample := B;
     Invalidate; // Заставляет апдейтится во время прорисовки
   end;
 end;
 
 destructor TFontListBox.Destroy;
 begin
   fCanvas.Free; // освобождает холст
   inherited Destroy;
 end;
 
 constructor TFontListBox.Create(AOwner : TComponent);
 begin
   inherited Create(AOwner);
   // Initialize properties
   ParentFont := True;
   Font.Size := 8;
   Font.Style := [];
   Sorted := True;
   fFontSample := False;
   Style := lbOwnerDrawFixed;
   fCanvas := TControlCanvas.Create;
   fCanvas.Control := Self;
   ItemHeight := 16;
   fShowTrueType := False;
 end;
 
 procedure TFontListBox.CreateWnd;
 begin
   inherited CreateWnd;
   Items := Screen.Fonts; // Копируем все шрифты в ListBox.Items
   ItemIndex := 0; // Выбираем первый фонт
 end;
 
 procedure TFontListBox.DrawItem(index : Integer; R : TRect;
   State : TOwnerDrawState);
 var
   Metrics : TTextMetric;
   LogFnt : TLogFont;
   oldFont,newFont : HFont;
   IsTrueTypeFont : Boolean;
   fFontStyle : TFontStyles;
   fFontName : TFontName;
   fFontColor : TColor;
 begin
   LogFnt.lfHeight := 10;
   LogFnt.lfWidth := 10;
   LogFnt.lfEscapement := 0;
   LogFnt.lfWeight := FW_REGULAR;
   LogFnt.lfItalic := 0;
   LogFnt.lfUnderline := 0;
   LogFnt.lfStrikeOut := 0;
   LogFnt.lfCharSet := DEFAULT_CHARSET;
   LogFnt.lfOutPrecision := OUT_DEFAULT_PRECIS;
   LogFnt.lfClipPrecision := CLIP_DEFAULT_PRECIS;
   LogFnt.lfQuality := DEFAULT_QUALITY;
   LogFnt.lfPitchAndFamily := DEFAULT_PITCH or FF_DONTCARE;
   StrPCopy(LogFnt.lfFaceName,Items[index]);
   newFont := CreateFontIndirect(LogFnt);
   oldFont := SelectObject(fCanvas.Handle,newFont);
   GetTextMetrics(fCanvas.Handle,Metrics);
   // Теперь вы можете проверить на TrueType-ность
   IsTrueTypeFont := True;
   if (Metrics.tmPitchAndFamily and TMPF_TRUETYPE) = 0 then
     IsTrueTypeFont := False;
 
   Canvas.FillRect(R);
   if fShowTrueType and IsTrueTypeFont then
   begin
     // Записываем параметры шрифтов
     fFontName := Canvas.Font.name;
     fFontStyle := Canvas.Font.Style;
     fFontColor := Canvas.Font.Color;
     // Устанавливаем новые параметры шрифтов
     Canvas.Font.name := 'Times new roman';
     Canvas.Font.Style := [fsBold];
     //Canvas.Font.Color := clBlack;
     Canvas.TextOut(R.Left + 2,R.Top,'T');
     if fFontColor <> clHighLightText then
       Canvas.Font.Color := clGray;
     Canvas.TextOut(R.Left + 7,R.Top + 3,'T');
     //Восстанавливаем параметры шрифтов
     Canvas.Font.Style := fFontStyle;
     Canvas.Font.Color := fFontColor;
     Canvas.Font.name := fFontName;
   end;
 
   if fFontSample then
     // Шрифт будет прорисован фактически как шрифт
     Canvas.Font.name := Items[index]
   else
     // Шрифт будет прорисован в свойстве "Font"
     Canvas.Font.name := Font.name;
 
   if fShowTrueType then
     Canvas.TextOut(R.Left + 20,R.Top,Items[index]) // Показывать TrueType
   else
     Canvas.TextOut(R.Left,R.Top,Items[index]); // Не показывать TrueType
 
   SelectObject(fCanvas.Handle,oldFont);
   DeleteObject(newFont);
 end;
 
 end.
 




Компонент PowerControl

Она (улыбаясь и глядя вдаль):
- ... нет, все-таки человек должен просыпаться и видеть небо...
Он (открывая бутылку с пивом):
- Для это достаточно проснуться дома, протянуть руку и нажать Power

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

 procedure TForm1.Button1Click(Sender: TObject);
 begin
   PowerControl1.Action := actCDEject; // Или... actLogOFF, actShutDown...
   PowerControl1.Execute;
 end;
 
 // ========================= //
 //     Component Code:       //
 // ========================= //
 
 unit PowerControl;
 
 interface
 
 uses
   WinTypes, WinProcs, Messages, SysUtils, Classes, Controls,
   Forms, Graphics, MMSystem;
 
 type
   TAction = (actLogOFF, actShutDown, actReBoot, actForce, actPowerOFF,  actForceIfHung,
              actMonitorOFF, actMonitorON, actCDEject, actCDUnEject);
 
 type
   TPowerControl = class(TComponent)
   private
     FAction: TAction;
     procedure SetAction(Value : TAction);
   protected
   public
     function Execute : Boolean;
   published
     property Action : TAction read FAction write SetAction;
 end;
 
 procedure register;
 
 implementation
 
 procedure register;
 begin
   RegisterComponents('K2', [TPowerControl]);
 end;
 
 procedure TPowerControl.SetAction(Value: TAction);
 begin
   FAction := Value;
 end;
 
 function TPowerControl.Execute: Boolean;
 begin
   with (Owner as TForm) do
     case FAction of
       actLogOff: ExitWindowsEx(EWX_LOGOFF,1);
       actShutDown: ExitWindowsEx(EWX_SHUTDOWN,1);
       actReBoot: ExitWindowsEx(EWX_REBOOT,1);
       actForce: ExitWindowsEx(EWX_FORCE,1);
       actPowerOff: ExitWindowsEx(EWX_POWEROFF,1);
       actForceIfHung: ExitWindowsEx(EWX_FORCEIFHUNG,1);
       actMonitorOFF: SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, 0);
       actMonitorON: SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, -1);
       actCDEject: mciSendstring('SET CDAUDIO DOOR OPEN WAIT',nil,0, Handle);
       actCDUnEject: mciSendstring('SET CDAUDIO DOOR CLOSED WAIT',nil,0, Handle);
     end;
     Result := True;
 end;
 




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

В следующем примере показан перехват сообщения WM_EXITSIZEMOVE Хотя сообщение документированно только для Windows NT оно работает точно так же и под Windows 95. Обратите внимание что Вы можите перехватить сообщение WM_ENTERSIZEMOVEдля определения момента начала пользователем операции изменения размера или перемещения окна.


 type
   TForm1 = class(TForm)
   private
     { Private declarations }
   public
     { Public declarations }
     procedure WMEXITSIZEMOVE(var message: TMessage); message WM_EXITSIZEMOVE;
 end;
 
 var
   Form1: TForm1;
 
 implementation
 {$R *.DFM}
 
 procedure TForm1.WMEXITSIZEMOVE(var message: TMessage);
 begin
   Form1.Caption := 'Finished Moving and sizing';
 end;
 




Сжимаем и разжимаем потоки


 uses
   ZLib;
 
 { Compress a stream }
 
 procedure CompressStream(inpStream, outStream: TStream);
 var
   InpBuf, OutBuf: Pointer;
   InpBytes, OutBytes: Integer;
 begin
   InpBuf := nil;
   OutBuf := nil;
   try
     GetMem(InpBuf, inpStream.Size);
     inpStream.Position := 0;
     InpBytes := inpStream.Read(InpBuf^, inpStream.Size);
     CompressBuf(InpBuf, InpBytes, OutBuf, OutBytes);
     outStream.Write(OutBuf^, OutBytes);
   finally
     if InpBuf <> nil then FreeMem(InpBuf);
     if OutBuf <> nil then FreeMem(OutBuf);
   end;
 end;
 
 
 { Decompress a stream }
 procedure DecompressStream(inpStream, outStream: TStream);
 var
   InpBuf, OutBuf: Pointer;
   OutBytes, sz: Integer;
 begin
   InpBuf := nil;
   OutBuf := nil;
   sz     := inpStream.Size - inpStream.Position;
   if sz > 0 then
     try
       GetMem(InpBuf, sz);
       inpStream.Read(InpBuf^, sz);
       DecompressBuf(InpBuf, sz, 0, OutBuf, OutBytes);
       outStream.Write(OutBuf^, OutBytes);
     finally
       if InpBuf <> nil then FreeMem(InpBuf);
       if OutBuf <> nil then FreeMem(OutBuf);
     end;
   outStream.Position := 0;
 end;
 
 
 {
   Example:
    Compress the contents of RichEdit1 and
    calculate the compression rate.
    Then save the stream to a file (ms2.dat)
 
   Beispiel:
    Komprimiert den Inhalt von RichEdit1 und
    berechnet die Kompressionsrate.
    Dann wird der Stream in eine Datei (ms2.dat) gespeichert.
 }
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   ms1, ms2: TMemoryStream;
 begin
   ms1 := TMemoryStream.Create;
   try
     ms2 := TMemoryStream.Create;
     try
       RichEdit1.Lines.SaveToStream(ms1);
       CompressStream(ms1, ms2);
       ShowMessage(Format('Stream Compression Rate: %d %%',
         [round(100 / ms1.Size * ms2.Size)]));
       ms2.SaveToFile('C:\ms2.dat');
     finally
       ms1.Free;
     end;
   finally
     ms2.Free;
   end;
 end;
 
 {
   Loads the stream from a file (ms2.dat)
   and decompresses it.
   Then loads the Stream to RichEdit1.
 
   Ladt den komprimierten Stream von einer Datei (ms2.dat)
   und dekomprimiert ihn.
   Dann wird der Stream wieder in RichEdit1 geladen.
 }
 
 procedure TForm1.Button2Click(Sender: TObject);
 var
   ms1, ms2: TMemoryStream;
 begin
   ms1 := TMemoryStream.Create;
   try
     ms2 := TMemoryStream.Create;
     try
       ms1.LoadFromFile('C:\ms2.dat');
       DecompressStream(ms1, ms2);
       RichEdit1.Lines.LoadFromStream(ms2);
     finally
       ms1.Free;
     end;
   finally
     ms2.Free;
   end;
 end;
 




Массив компонентов

Обувь для программистов - майкроссовки.

Возможно ли создание массива компонентов? Для показа статуса я использую набор LED-компонентов и хотел бы иметь к ним доступ, используя массив.

Прежде всего необходимо объявить массив:


 {10 элементов компонентного типа TLed}
 LED : array[1..10] of TLed;
 

При необходимости динамического создания LED-компонентов организуйте цикл, пример которого мы приводим ниже:


 for counter := 1 to 10 do
 begin
   LED[counter]:= TLED.Create;
   LED[counter].top := ...
   LED[counter].Left := ...
   LED[counter].Parent := Mainform;   {что-то типа этого}
 end;
 

Если компоненты уже присутствуют на форме (в режиме проектирования), сделайте их элементами массива, например так:


 leds := 0;
 for counter := 0 to Form.Componentcount do
 begin
   if (components[counter] is TLED) then
   begin
     inc(leds);
     LED[leds] := TLED(components[counter]);
   end
 end;
 

Тем не менее у нас получился массив со случайным расположением LED-компонентов. Я предлагаю назначить свойству Tag каждого LED-компонента порядковый номер его расположения в массиве, а затем заполнить массив, используя это свойство:


 for counter := 0 to Form.Componentcount do
 begin
   if (components[counter] is TLED) then
   begin
     LED[Component[counter].tag] := TLED(components[counter]);
   end
 end;
 

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




Массив компонентов 2

Автор: Юрий Лапицкий

Продолжая начатую тему в "Советах по Дельфи 1.0.9" о динамическом массиве компонентов (на этот раз двухмерном, так как одномерный очень хорошо был описан в этой версии журнала) я предлагаю следующей код который позволяет создать такой массив компонентов TImage с удобным (скажем так - почти) использованием их в этом массиве (например, при осуществлении связи с каким-то другим массивом). Я использовал этот код в одной из моих программ и после многих его тестов пришёл к выводу что он нормально работает при размерах массива 17х17 (думаю что можно довести и до 20х20 и более, но это увеличило бы код... Тем более что для моей программы такого массива вполне достаточно!).


 {
 Листинг 1: Создание двухмерного динамического массива компонентов
 © 1999, Юрий Лапицкий
 }
 
 {
 Шаг ?1: Вначале, сделаем потомок стандартного TImage как дополнение
 для их различия в будующем массиве компонентов.
 }
 type
 
   TMyImage = class(TImage)
   private
     FXTag, FYTag: Longint;
   published
     property XTag: Longint read FXTag write FXTag default 0;
     property YTag: Longint read FYTag write FYTag default 0;
   end;
   {===================}
   {
   Шаг ?2: В описание класса главной формы вставим двухмерный динамический
   массив компонентов TMyImage, а в секцию private - необходимый код для
   инициализации массива!
   }
 type
   TForm1 = class(TForm)
 
     //Процедура реализации события OnMouseUp при наведении на картинку
     procedure ImageMouseUp(Sender: TObject; Button: TMouseButton;
       Shift: TShiftState; X, Y: Integer);
   public
     Images: array of array of TMyImage;
   private
     {Процедура "создания" поля}
     procedure MakeField(const MaxRows: byte = 4; MaxCols: byte = 4);
     {Процедура "убора" поля (вообще-то не обязательно,
     но я предпочитаю перестараться, чем недостараться...)}
     procedure FreeField(const MaxRows: byte = 4; MaxCols: byte = 4);
   end;
 var
 
   Form1: TForm1;
   Bitmap1: TBitmap;
   {
   В Bitmap1 можно загрузить картинку. Например из файла Bitmap1.bmp:
 
   Bitmap1:=TBitmap1.Create;
   Bitmap1.LoadFromFile('Bitmap1.bmp');
   }
   {===================}
   {
   Шаг ?3: Реализация процедур в секции implementation.
   }
 
 procedure TForm1.MakeField(const MaxRows, MaxCols: byte);
 var
   Col, Row: byte;
 begin
 
   {Иницализация самого массива}
   Initialize(Images);
   System.SetLength(Images, MaxRows);
   for Row := 0 to MaxRows - 1 do
     System.SetLength(Images[Row], MaxCols);
 
   {Создание и заполнение элементов массива}
   for Row := 0 to MaxRows - 1 do
     for Col := 0 to MaxCols - 1 do
     begin
       Images[Row, Col] := TMyImage.Create(Self);
       with Images[Row, Col] do
       begin
         XTag := Row;
         YTag := Col;
 
         Picture.Bitmap := Bitmap1;
         Left := Col * Bitmap1.Width;
         Top := Row * Bitmap1.Height;
         Width := Bitmap1.Width + Left;
         Height := Bitmap1.Height + Top;
         Center := True;
         Transparent := True;
         AutoSize := True;
         Visible := True;
         onMouseUp := ImageMouseUp;
 
         Parent := Self;
       end
     end;
 
   Invalidate
 end;
 
 procedure TMainForm.FreeField(const MaxRows, MaxCols: byte);
 var
   Col, Row: byte;
 begin
 
   {Уничтожение элементов массива}
   for Row := 0 to MaxRows - 1 do
     for Col := 0 to MaxCols - 1 do
       Images[Row, Col].Destroy;
   {Уничтожение самого массива}
   Finalize(Images)
 end;
 
 procedure TMainForm.ImageMouseUp(Sender: TObject; Button:
   TMouseButton; Shift: TShiftState; X, Y: Integer);
 begin
 
   { Проверка необязательна, но ведь можно (случайно)
   присвоить это событие также и форме!}
   if (Sender is TMyImage) then
   begin
     {
     обратиться к элементу массива можно используя введ?нные
     мною дополнения: Sender.XTag и Sender.YTag
     Images[Sender.XTag, Sender.YTag]
     }
 
   end
 end;
 




Массив компонентов 3

Программист задел локтем книжку на столе, она упала и заодно сбила открытую бутылку пива... Он, чертыхаясь, поднимает книжку - это руководство по программированию в Windоws:
- Вот чертов Маздай, даже в виде книжки чуть что - падает и все рушит!


 type
 PtImg = ^TtImg;
 TtImg = array [0..0] of TImage;
 
 var
 tImg: PtImg;
 
 GetMem(tImg, 4 * numberofentries);
 

Преимущество в том, что вы должны использовать столько памяти, сколько вам нужно. Недостаток в том, что вы должны кодировать все с tImg^[n]....




Элементы управления с автовыравниванием

Автор: Ralph Friedman

Я просто хочу в моем модуле заставить перемещаться поле редактирования (компонент Edit) синхронно с перемещением кнопки. При любом перемещении поля редактирования кнопка должна следовать за ним. Покопался в исходном коде VCL, но так ничего и не обнаружил...

При создании кнопки вы должны сделать ее "ребенком" поля редактирования (обычно, parent := self;). Также для компонента вы должны перекрыть метод CreateParams и установить Param.Style следующим образом:


 Params.Style or WS_CLIPCHILDREN;
 




Имя класса компонента и модуля

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

Например: xxx('TPanel') возвращала бы 'ExtCtrls'

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


 Uses TypInfo;
 
 Function ObjectsUnit (Obj: TClass): String;
 Begin
   Result := GetTypeData (PTypeInfo(Obj.ClassInfo))^.UnitName
 end;
 

Для создания описанной вами функции "Какой модуль" могут использоваться описанные в TOOLINTF.INT методы GetModuleCount, GetModuleName, GetComponentCount и GetComponentName.

Для получения представления о формате палитры компонентов обратитесь к файлу DELPHI.INI.




Помещение компонентов в DBGrid

Короткий компьютерный анекдот: Microsoft Windows for Linux.

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

Здесь нет новых идей, фактически основная технология работы заключается в имитации-трансплантации внешних компонентов в DBGrid. Идея в том, чтобы получить контроль над табличной сеткой. Практически DBGrid состоит из набора компонентов TDBEdit. Вводя данные в ячейку, вы работаете непосредственно с TDBEdit. Остальные без фокуса ячейки в данный момент реально являются статичной картинкой. В данном совете Вы узнаете как поместить в сфокусированную ячейку другой, отличный от TDBEdit, визуальный компонент.

КОМПОНЕНТ #1 - TDBLOOKUPCOMBO

Вам нужна форма с компонентом DBGrid на ней. Создайте новый проект и поместите на основную форму DBGrid.

Далее поместите на форму TTable, установите псевдоним (Alias) в DBDEMOS, TableName в GRIDDATA.DB и присвойте свойству Active значение True. Поместите DataSource и сошлитесь в свойстве DataSet на Table1. Вернитесь к DBGrid и укажите в свойстве DataSource компонент DataSource1. Данные из GRIDDATA.DB должные появиться в табличной сетке...

Первый элемент, который мы собираемся поместить в DBGrid - TDBLookupCombo, т.к. нам нужна вторая таблица для поиска. Поместите второй TTable на форму. Установите псевдоним (Alias) в DBDEMOS, TableName в CUSTOMER.DB и присвойте свойству Active значение True. Поместите второй DataSource и сошлитесь в свойстве DataSet на Table2.

Теперь нужно поместить компонент TDBLookupCombo из палитры Data Controls на любое место формы - это не имеет никакого значения, т.к. он обычно будет невидим или будет нами имплантирован в табличную сетку. Установите свойства компонента LookuoCombo следующим образом:


 DataSource      DataSource1
 DataField       CustNo
 LookupSource    DataSource2
 LookupField     CustNo
 LookupDisplay   CustNo  {Вы можете изменить это на Company позже,
                          но сейчас пусть это будет CustNo)
 

Пока мы только настроили компоненты. Теперь давайте создадим некоторый код.

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


 procedure TForm1.FormCreate(Sender: TObject);
 begin
 
 end;
 

Присвойте свойству Visible значение False в LookupCombo следующим образом:


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   DBLookupCombo1.Visible := False;
 end;
 

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

Теперь нам необходимо "прикрутить" компонент к нашей табличной сетке. Наша задача - автоматически отобразить DBLookupCombo в ячейке во время получения ею фокуса (или перемещении курсора). Для этого необходимо написать код для обработчиков двух событий: OnDrawDataCell и OnColExit. Первым делом обработаем событие OnDrawDataCell. Дважды щелкните на строчке OnDrawDataCell в инспекторе объектов и введите следующий код:


 procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect;
   Field: TField; State: TGridDrawState);
 begin
   if (gdFocused in State) then
   begin
     if (Field.FieldName = DBLookupCombo1.DataField) then
     begin
       DBLookupCombo1.Left := Rect.Left + DBGrid1.Left;
       DBLookupCombo1.Top := Rect.Top + DBGrid1.top;
       DBLookupCombo1.Width := Rect.Right - Rect.Left;
       { DBLookupCombo1.Height := Rect.Bottom - Rect.Top; }
       DBLookupCombo1.Visible := True;
     end;
   end;
 end;
 

Причины чрезмерного использования конструкций begin/end скоро станут понятны. В коде "говорится", что если параметр State имеет значение gdFocused, то данная ячейка имеет фокус (в любой момент времени только одна ячейка в табличной сетке может иметь фокус). Далее: если это выделенная ячейка и ячейка имеет тоже имя поля как и поле данных DBLookupCombo, DBLookupCombo необходимо поместить над этой ячейкой и сделать его видимым. Обратите внимание на определение позиции DBLookupCombo: она определяется относительно формы, а не ячейки. Так, например, положение левой стороны LookupCombo должно учитывать положение сетки (DBGrid1.Left) плюс положение соответствующей ячейки относительно сетки (Rect.Left).

Также обратите внимание на то, что определение высоты LookupCombo в коде закомментарено. Причина в том, что LookupCombo имеет минимальную высоту. Вы просто не сможете сделать ее меньше. Минимальная высота LookupCombo больше высоты ячейки. Если Вы раскомментарили строку, касающуюся высоты LookupCombo, Ваш код изменит размер компонента и Delphi немедленно его перерисует. Это вызовет неприятное моргание компонента. Бороться с этим невозможно. Позвольте, чтобы LookupCombo был немного больше, чем ячейка. Это выглядит немного странным, но это работает.

Теперь ради шутки запустите программу. Заработала? Сразу после запуска переместите курсор на одну из ячеек табличной сетки. Вы ожидали чего-то большего? Да! Мы только в середине пути. Теперь нам нужно спрятать LookupCombo при покидании курсором колонки. Напишем обработчик события onColExit. Это должно выглядеть примерно так:


 procedure TForm1.DBGrid1ColExit(Sender: TObject);
 begin
   If DBGrid1.SelectedField.FieldName = DBLookupCombo1.DataField then
     DBLookupCombo1.Visible := false;
 end;
 

Код использует свойство TDBGrids SelectedField для ассоциации имени поля ячейки (FieldName) с нашим LookupCombo. Код "говорит": "Если ячейка была в колонке с DBLookupCombo (имя поля ячейки совпадает с именем поля DBLookupCombo), его необходимо сделать невидимым".

Теперь снова запустите приложение. Чувствуете эффект?

Теперь вроде бы все правильно, но мы забыли об одной вещи. Попробуйте ввести новое значение в одно из LookupCombo. Проблема в том, что нажатие клавиши обрабатывает DBGrid, а не LookupCombo. Чтобы исправить это, нам нужно написать для табличной сетки обработчик события onKeyPress. Это должно выглядеть примерно так:


 procedure TForm1.DBGrid1KeyPress(Sender: TObject; var Key: Char);
 begin
   if (key <> chr(9)) then
   begin
     if (DBGrid1.SelectedField.FieldName = DBLookupCombo1.DataField) then
     begin
       DBLookupCombo1.SetFocus;
       SendMessage(DBLookupCombo1.Handle, WM_Char, word(Key), 0);
     end;
   end;
 end;
 

В данном коде "говорится": если нажатая клавиша не является клавишей Tab (Chr(9)) и текущее поле в табличной сетке LookupCombo, тогда установите фокус на LookupCombo и передайте сообщение с кодом нажатой клавиши LookupCombo. Здесь я воспользовался WIN API функцией. Вам не нужно знать как это работает, достаточно того, что это просто работает.

Небольшое пояснение я все же дам. Для того, чтобы функция Window SendMessage послала сообщение "куда надо", ей в качестве параметра необходим дескриптор ("адрес") нужного компонента. Используйте свойство компонента Handle. Затем нужно сообщить компоненту что мы от него хотим. В нашем случае это Windows-сообщение WM_CHAR, извещающее LookupCombo о том, что ему посылается символ. Наконец, мы передаем ему сам символ нажатой клавиши - word(Key). Word(key) - приведение к типу word параметра Key события нажатия клавиши. Все достаточно просто, правда? Все, что Вам действительно необходимо сделать - заменить имя DBLookupCombo1 нашего вымышленного компонента на имя реального компонента, который будет участвовать в "модернизации" табличной сетки. Более подробную информацию о функции SendMessage Вы можете почерпнуть из электронной справки, поставляемой вместе с Delphi.

Запустите снова Ваше приложение и попробуйте что-нибудь ввести. Это работает! Экспериментируя, Вы увидите что с помощью клавиши Tab Вы можете перейти из режима редактирования в режим перемещения курсора и наоборот.

Теперь перейдите к инспектору объектов и измнените у компонента DBLookupCombo свойство LookupDIsplay на Company. Снова запустите. Это то, что Вы ожидали?

КОМПОНЕНТ #2 - TDBCOMBO

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


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   DBLookupCombo1.Visible := False;
   DBComboBox1.Visible := False;
 end;
 
 procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect;
   Field: TField; State: TGridDrawState);
 begin
   if (gdFocused in State) then
   begin
     if (Field.FieldName = DBLookupCombo1.DataField) then
     begin
       DBLookupCombo1.Left := Rect.Left + DBGrid1.Left;
       DBLookupCombo1.Top := Rect.Top + DBGrid1.top;
       DBLookupCombo1.Width := Rect.Right - Rect.Left;
       DBLookupCombo1.Visible := True;
     end
     else if (Field.FieldName = DBComboBox1.DataField) then
     begin
       DBComboBox1.Left := Rect.Left + DBGrid1.Left;
       DBComboBox1.Top := Rect.Top + DBGrid1.top;
       DBComboBox1.Width := Rect.Right - Rect.Left;
       DBComboBox1.Visible := True;
     end
   end;
 end;
 
 procedure TForm1.DBGrid1ColExit(Sender: TObject);
 begin
   if DBGrid1.SelectedField.FieldName = DBLookupCombo1.DataField then
     DBLookupCombo1.Visible := false
   else if DBGrid1.SelectedField.FieldName = DBComboBox1.DataField then
     DBComboBox1.Visible := false;
 end;
 
 procedure TForm1.DBGrid1KeyPress(Sender: TObject; var Key: Char);
 begin
   if (key <> chr(9)) then
   begin
     if (DBGrid1.SelectedField.FieldName = DBLookupCombo1.DataField) then
     begin
       DBLookupCombo1.SetFocus;
       SendMessage(DBLookupCombo1.Handle, WM_Char, word(Key), 0);
     end
     else if (DBGrid1.SelectedField.FieldName = DBComboBox1.DataField) then
     begin
       DBComboBox1.SetFocus;
       SendMessage(DBComboBox1.Handle, WM_Char, word(Key), 0);
     end;
   end;
 end;
 

КОМПОНЕНТ #3 - TDBCHECKBOX

Технология работы с компонентом DBCheckBox более интересна. В этом случае нам необходимо дать понять пользователю о наличие компонента DBCheckBox в ячейках без фокуса. Вы можете вставлять статическое изображение компонента или динамически изменять изображение в зависимости от логического состояния элемента управления. Я выбрал второе. Я создал два BMP-файла - включенный (TRUE.BMP) и выключенный (FALSE.BMP) DBCheckBox. Поместите два компонента TImage на форму, присвойте им имена ImageTrue и ImageFalse и назначьте соответствующие BMP-файлы в свойстве Picture. Да, чуть не забыл: Вам также необходимо поместить на форму два компонента DBCheckbox. Установите набор данных обоих компонентов в DataSource1 и присвойстве свойству Color значение clWindow. Для начала создадим для формы обработчик события onCreate:


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   DBLookupCombo1.Visible := False;
   DBCheckBox1.Visible := False;
   DBComboBox1.Visible := False;
   ImageTrue.Visible := False;
   ImageFalse.Visible := False;
 end;
 

Теперь нам нужен обработчик события onDrawDataCell чтобы делать что-то с ячейками, не имеющими фокуса. Здесь подойдет следующий код:


 procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect;
   Field: TField; State: TGridDrawState);
 begin
   if (gdFocused in State) then
   begin
     if (Field.FieldName = DBLookupCombo1.DataField) then
     begin
       // ...СМОТРИ ВЫШЕ
     end
     else if (Field.FieldName = DBCheckBox1.DataField) then
     begin
       DBCheckBox1.Left := Rect.Left + DBGrid1.Left + 1;
       DBCheckBox1.Top := Rect.Top + DBGrid1.top + 1;
       DBCheckBox1.Width := Rect.Right - Rect.Left { - 1};
       DBCheckBox1.Height := Rect.Bottom - Rect.Top { - 1};
       DBCheckBox1.Visible := True;
     end
     else if (Field.FieldName = DBComboBox1.DataField) then
     begin
       // ...СМОТРИ ВЫШЕ
     end
   end
   else {в этом месте помещаем статическое изображение компонента}
   begin
     if (Field.FieldName = DBCheckBox1.DataField) then
     begin
       if TableGridDataCheckBox.AsBoolean then
         DBGrid1.Canvas.Draw(Rect.Left, Rect.Top, ImageTrue.Picture.Bitmap)
       else
         DBGrid1.Canvas.Draw(Rect.Left, Rect.Top, ImageFalse.Picture.Bitmap)
     end
   end;
 end;
 

Самое интересное место - последний участок кода. Он выполняется в случае, когда состояние не равно gdFocused и сам CheckBox находится в колонке. В нем осуществляется проверка данных поля: если они равны True, то выводится рисунок TRUE.BMP, в противном случае - FALSE.BMP. Предварительно я создал два изображения, представляющие собой "слепок" двух логических состояния компонента, теперь будет очень трудно обнаружить отсутствие компонента в ячейках с фокусом и без оного. Теперь напишем обработчик события onColExit:


 procedure TForm1.DBGrid1ColExit(Sender: TObject);
 begin
   If DBGrid1.SelectedField.FieldName = DBLookupCombo1.DataField then
     DBLookupCombo1.Visible := false
   else
   If DBGrid1.SelectedField.FieldName = DBCheckBox1.DataField then
     DBCheckBox1.Visible := false
   else
   If DBGrid1.SelectedField.FieldName = DBComboBox1.DataField then
     DBComboBox1.Visible := false;
 end;
 

Организуйте обработку события onKeyPress как показано ниже:


 procedure TForm1.DBGrid1KeyPress(Sender: TObject; var Key: Char);
 begin
   if (key <> chr(9)) then
   begin
     if (DBGrid1.SelectedField.FieldName = DBLookupCombo1.DataField) then
     begin
       DBLookupCombo1.SetFocus;
       SendMessage(DBLookupCombo1.Handle, WM_Char, word(Key), 0);
     end
     else if (DBGrid1.SelectedField.FieldName = DBCheckBox1.DataField) then
     begin
       DBCheckBox1.SetFocus;
       SendMessage(DBCheckBox1.Handle, WM_Char, word(Key), 0);
     end
     else if (DBGrid1.SelectedField.FieldName = DBComboBox1.DataField) then
     begin
       DBComboBox1.SetFocus;
       SendMessage(DBComboBox1.Handle, WM_Char, word(Key), 0);
     end;
   end;
 end;
 

Наконец, последняя хитрость. Для удобства пользователя заголовку компонента нужно присвоить текущее логическое значение. С самого начала у меня была идея поручить это обработчику события onChange, но проблема в том, что событие может возникнуть неединожды. Итак, я должен снова воспользоваться функцией Windows API и послать компоненту соответствующее значение: "SendMessage(DBCheckBox1.Handle, BM_GetCheck, 0, 0)", которая возвращает 0 в случае если компонент невключен и любое другое число в противном случае.


 procedure TForm1.DBCheckBox1Click(Sender: TObject);
 begin
   if SendMessage(DBCheckBox1.Handle, BM_GetCheck, 0, 0) = 0 then
     DBCheckBox1.Caption := ' ' + 'Ложь'
   else
     DBCheckBox1.Caption := ' ' + 'Истина'
 end;
 

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

Ревизия

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

Проблема # 1 - Необходимость двойного нажатия клавиши Tab.

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

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


 type
 
 TForm1 = class(TForm)
 ...
 ...
 private
 { Private declarations }
 WasInFloater : Boolean;
 ...
 ...
 end;
 

Затем для компонента LookupCombo напишем обработчик события onEnter, где присвоим переменной WasInFloater значение True. Это позволит нам понять где в данный момент находится фокус.


 procedure TForm1.DBLookupCombo1Enter(Sender: TObject);
 begin
   WasInFloater := True;
 end;
 

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


 procedure TForm1.DBGrid1KeyUp(Sender: TObject; var Key: Word;
   Shift: TShiftState);
 begin
   if (Key in [VK_TAB]) and WasInFloater then
   begin
     SendMessage(DBGrid1.Handle, WM_KeyDown, Key, 0);
     WasInFloater := False;
   end;
 end;
 

Данный код реагирует на нажатие клавиши и позволяет в случае, когда фокус передался из имплантированного элемента управления табличной сетеке, вторично эмулировать нажатие клавиши Tab (передается код нажатой клавиши, т.е. Tab). Это работает как для отдельной клавиши Tab, так и для комбинации Shift-Tab.

Проблема #2 - Новая запись исчезает, когда компонент получает фокус.

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

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




Помещение компонентов в StringGrid

Автор: Neil Rubenking

Некоторое время тому назад такой вопрос уже ставился: возможно ли поместить элемент управления, например, CheckBox или ComboBox внутрь компонента ...Grid. Я сегодня помозговал и нашел неплохую, на мой взгляд, технологию. Это работает! Вот решение для тех, кто этим интересуется:

  1. При создании компонента (в обработчике OnCreate), создайте его объекты Objects[C,R], например TCheckBox.Create(Self). Имейте в виду, что вы должны присвоить ячейкам Cells[C,R] какие-либо значения прежде, чем чем вы сможете иметь доступ к Objects[C,R]. Установите у вновь созданного компонента свойство Visible в FALSE, а свойство parent в SELF. Осуществите другую необходимую инициализацию. Имейте в виду, что вы должны внести необходимые модули в список uses, если создаете тип компонента, которого нигде кроме как на форме нет.

  2. Создайте процедуру, берущую координаты колонки/строки и правильно позиционирующую соотвествующий объект в пределах прямоугольника ячейки, например:

 procedure TForm1.FixObjPosn(vCol, vRow: LongInt);
 {Размещаем содержимое компонента в области прямоугольника ячейки}
 var
   R: TRect;
 begin
   R := StringGrid1.CellRect(vCol, vRow);
   if StringGrid1.Objects[vCol, vRow] is TControl then
     with TControl(StringGrid1.Objects[vCol, vRow]) do
       if R.Right = R.Left then {прямоугольник ячейки невидим}
         Visible := False
       else
       begin
         InflateRect(R, -1, -1);
         OffsetRect(R, StringGrid1.Left + 1, StringGrid1.Top + 1);
         BoundsRect := R;
         Visible := True;
       end;
 end;
 

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

  1. В обработчике события сетки OnSelectCell проверьте, располагается ли элемент Objects в текущей колонке Col и строке Row TControl - если так, установите его свойство visible в FALSE. Теперь вызовите процедуру установления координат из шага 2 для *НОВЫХ* Col и Row, передавая их из параметров обработчика события в параметры функции.

  2. В обработчике OnTopLeftChanged просто вызовите FixObjPosn

  3. В обработчике события OnDrawCell во-первых, если ячейка выбрана, EXIT. Если элемент ячейки Objects не TControl, также EXIT. В противном случае вам нужно создать код, обеспечивающий отрисовку "фасада" каждого типа элемента управления, которого вы разместили в сетке.

  4. Обратите внимание на то, что если вы делаете что-либо с элементом управления, на который влияют ДРУГИЕ элементы управления (например, изменение статуса какой-либо радиокнопки из группы, или операции enable/disable), вы должны вызвать метод сетки Refresh.

Опс! Это звучит немного запутанно, но это работает. Успехов!




Помещение VCL компонентов в область заголовка

Здесь есть хитрость:

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

Нижеприведенный проект включает в себя 2 формы и выпадающий список (combobox). После запуска программы список появляется в области заголовка главной формы. Два ключевых вопроса: 1) организация перехвата сообщения WM_MOVE главной формы; и 2) возвращение фокуса в главную форму после того, как пользователь нажмет на каком-либо элементе управления, способным иметь фокус (например, TComboBox, TButton и др.)

Я использую 32-битную Delphi 2.0 под Win95, тем не менее данный код должен работать с любой версией Delphi.

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


 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
   Dialogs, StdCtrls;
 
 type
   TForm1 = class(TForm)
     procedure FormResize(Sender: TObject);
     procedure FormShow(Sender: TObject);
     procedure FormHide(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
     procedure WMMove(var Msg: TWMMove); message WM_MOVE;
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 uses Unit2;
 
 {$R *.DFM}
 
 procedure TForm1.FormResize(Sender: TObject);
 begin
   with Form2 do
   begin
     {Заменим мои магические числа реальной информацией SystemMetrics}
     Width := Form1.Width - 120;
     Top := Form1.Top + GetSystemMetrics(SM_CYFRAME);
     Left := ((Form1.Left + Form1.Width) - Width) - 60;
   end;
 end;
 
 procedure TForm1.FormShow(Sender: TObject);
 begin
   Form2.Show;
 end;
 
 procedure TForm1.FormHide(Sender: TObject);
 begin
   Form2.Hide;
 end;
 
 procedure TForm1.WMMove(var Msg: TWMMove);
 begin
   inherited;
   if (Visible) then
     FormResize(Self);
 end;
 
 end.
 

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


 Caption='' {NULL строка}
 Height={высота области заголовка}
 Width={высота всех компонентов на форме}
 BorderIcons=[] {пусто}
 BorderStyle=bsNone
 FormStyle=fsStayOnTop
 

И, наконец, исходный код для Form2:


 unit Unit2;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
   Dialogs, StdCtrls;
 
 type
   TForm2 = class(TForm)
     ComboBox1: TComboBox;
     procedure FormCreate(Sender: TObject);
     procedure ComboBox1Change(Sender: TObject);
     procedure FormResize(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
   Form2: TForm2;
 
 implementation
 
 uses Unit1;
 
 {$R *.DFM}
 
 procedure TForm2.FormCreate(Sender: TObject);
 begin
   Height := ComboBox1.Height - 1;
   Width := ComboBox1.Width - 1;
 end;
 
 procedure TForm2.ComboBox1Change(Sender: TObject);
 begin
   Form1.SetFocus;
 end;
 
 procedure TForm2.FormResize(Sender: TObject);
 begin
   ComboBox1.Width := Width;
 end;
 
 end.
 

Файл проекта (.DPR) довольно простой:


 program Project1;
 
 uses
   Forms,
   Unit1 in 'Unit1.pas' {Form1},
   Unit2 in 'Unit2.pas' {Form2};
 
 {$R *.RES}
 
 begin
   Application.Initialize;
   Application.CreateForm(TForm1, Form1);
   Application.CreateForm(TForm2, Form2);
   Application.Run;
 end.
 

Это все!

Хотя некоторые авторы книг утверждают:

"Вы не можете установить компоненты Delphi в заголовок окна, точнее, не существует никакого способа установить их там."

Зато существует иллюзия...




Проводник для компьютеров, директорий, файлов и принтеров


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

Обзор (Browse)

В Windows есть несколько способов отобразить структуру директорий на компьютере. Большинство программистов Delphi знают, как пользоваться компонентой TOpenDialog, чтобы предоставить возможность пользователю перед открытием файла предварительно просматривать структуру директорий. Однако, используя API функцию SHBrowseForFolder мы можем заставить стандартный диалог Windows осуществлять просмотр не только директорий на диске, но и принтеров и компьютеров в сети.

Сперва давайте посмотрим, что необходимо для SHBrowseForFolder. Вот объявление функции:


 function SHBrowseForFolder (var BrowseInfo: TBrowseInfo): PItemIDList; stdcall;
 

Вся информация для инициализации и настройки диалогового окна Browse For Folder передаётся через переменную типа BrowseInfo. Сама же функция нам возвратит список ID элементов (скажем: местоположение выбранной папки).

Теперь давайте посмотрим, как заполнить структуру записей информацией, которая необходима для инициализации диалогового окна Browse for Folder, а затем вызовем SHBrowseForFolder для отображения диалогового окна.

Структура BrowseInfo

Основные элементы структуры, это поля lpszTitle и ulFlags. Поле lpszTitle - это текст, в виде статического текстового элемента управления (static text control) над деревом (treeview). Элемент ulFlags определяет флаги, которые задают режим отображения диалога.

Флаги позволяют сделать диалог более юзабельным, чем просто отображение директорий. В таблице приведены некоторые флаги, которые позволяют расширить возможности диалога Browse For Folders:

Значение Назначение

BIF_BROWSEFORCOMPUTER
Возвратить только компьютеры. Если пользователь выбрал что-то отличное от компьютеров, то кнопка OK останется серой.
BIF_BROWSEFORPRINTER
Возвратить только принтеры. Если пользователь выбрал что-то отличное от принтеров, то кнопка OK останется серой.
BIF_RETURNONLYFSDIRS
Возвратить только директории файловой системы. Если пользователь выберет директории, которые не являются частью файловой системы, то кнопка OK останется серой.
BIF_BROWSEINCLUDEFILES
Диалог просмотра будет отображать файлы вместе с директориями

Например, для просмотра как директорий, так и файлов, необходимо установить ulFlags в BIF_BROWSEINCLUDEFILES.

Код для Delphi

Когда мы поместим всё вышеописанное в функцию Delphi, которая будет создавать структуру, инициализировать её, и вызывать SHBrowseForFolder() для отображения диалогового окна, то она будет выглядеть следующим образом:


 uses
   ShellAPI, ShlObj;
 ...
 function BrowseDialog(const Title: string; const Flag: integer): string;
 var
   lpItemID: PItemIDList;
   BrowseInfo: TBrowseInfo;
   DisplayName: array [0..MAX_PATH] of char;
   TempPath: array [0..MAX_PATH] of char;
 begin
   Result := '';
   FillChar(BrowseInfo, sizeof(TBrowseInfo), #0);
   with BrowseInfo do
   begin
     hwndOwner := Application.Handle;
     pszDisplayName := @DisplayName;
     lpszTitle := PChar(Title);
     ulFlags := Flag;
   end;
   lpItemID := SHBrowseForFolder(BrowseInfo);
   if lpItemId <> nil then
   begin
     SHGetPathFromIDList(lpItemID, TempPath);
     Result := TempPath;
     GlobalFreePtr(lpItemID);
   end;
 end;
 

Функция BrowseDialog имеет на входе два параметра: Title и Flag. Title - это текст над деревом (поле lpszTitle в записи BrowseInfo). Параметр Flag используется для заполнения поля ulFlags.

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


 procedure TfrMain.btnBrowseClick(Sender: TObject);
 var
   sTitle, sFolder: string;
   iFlag: integer;
 begin
   sTitle:='Choose a ' + rgBrowseFor.Items[rgBrowseFor.ItemIndex];
   case rgBrowseFor.ItemIndex of
     0: iFlag := BIF_RETURNONLYFSDIRS;
     1: iFlag := BIF_BROWSEINCLUDEFILES;
     2: iFlag := BIF_BROWSEFORCOMPUTER;
     3: iFlag := BIF_BROWSEFORPRINTER;
   end;
   sFolder := BrowseDialog(sTitle, iFlag);
   if sFolder <> '' then
     edSelected.text := sFolder
   else
     edSelected.text := 'Nothing selected';
 end;
 

Обратите внимание: На форме (с именем: frMain) присутствует компонент RadioGroup (группа радио кнопок (с именем: rgBrowseFor)) который имеет четыре элеемента, каждый из которых представляет значение для переменной Flag. Функция извлекает из lpItemID путь к выбранной папке и возвращает его (заполнив компонент текстового поля edSelected). Если функция вернула ошибку (или пользователь нажал кнопку Cancel), то возвращённая строка будет пустой.




Компонент CheckList

Вопрос:

Я ищу компонент ListBox, который может отображать квадратик с галочкой (check box) для выбранных элементов списка - компонент CheckList, если вам будет угодно (просто последний компонент содержит меньший набор характеристик, чем мне необходимо).

  1. Загрузите 'Adding Graphics in your listboxes and comboboxes' (дополнительная графика для компонентов ListBox и Combobox) из Borland Technical Information - документ TI2793.
  2. Добавьте в ваш ListBox изображение неотмеченного квадратика.
  3. Используя событие двойного щелчока заменяйте изображение на отмеченный квадратик.
Рисование графики в коде для компонентов ListBox и ComboBox

Способность добавления своей графики в ListBox и ComboBox может значительно изменить внешний вид компонентов, делая графику более дружественной при общении с пользователем.

В: Как мне вставить свою графику в Listbox или ComboBox???

Приведу здесь пример, шаг за шагом иллюстрирующий данную технологию.....

  1. Создайте форму.
  2. Расположите на вашей форме компоненты ComboBox и Listbox.
  3. Измените свойство Style компонента ComboBox на csOwnerDrawVariable и свойство Style компонента ListBox на lbOwnerDrawVariable. Обработчик события OnDrawItem компонентов TListBox или TComboBox позволяет осуществить вывод как объекта (графики), так и строки элемента. В данном примере осуществляется вывод как графического объекта, так и строки.
  4. Создайте 5 переменных типа TBitmap в VAR секции вашей формы.
  5. Создайте процедуру для события формы OnCreate.
  6. Создайте процедуру для события ComboBox OnDraw.
  7. Создайте процедуру для события ComboBox OnMeasureItem.
  8. Освободите ресурсы в обработчике события формы OnClose.

 {НАЧАЛО OWNERDRW.PAS}
 unit Ownerdrw;
 
 interface
 
 uses
 
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls;
 
 type
 
   TForm1 = class(TForm)
     ComboBox1: TComboBox;
     ListBox1: TListBox;
     procedure FormCreate(Sender: TObject);
     procedure FormClose(Sender: TObject; var Action: TCloseAction);
     procedure ComboBox1DrawItem(Control: TWinControl; Index: Integer;
       Rect: TRect; State: TOwnerDrawState);
     procedure ComboBox1MeasureItem(Control: TWinControl; Index:
       Integer;
 
       var Height: Integer);
     procedure ListBox1DrawItem(Control: TWinControl; Index: Integer;
       Rect: TRect; State: TOwnerDrawState);
     procedure ListBox1MeasureItem(Control: TWinControl; Index:
       Integer;
 
       var Height: Integer);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
 
   Form1: TForm1;
   TheBitmap1, TheBitmap2, TheBitmap3, TheBitmap4,
     TheBitmap5: TBitmap;
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
 
   TheBitmap1 := TBitmap.Create;
   TheBitmap1.LoadFromFile('C:\delphi\images\buttons\globe.bmp');
   TheBitmap2 := TBitmap.Create;
   TheBitmap2.LoadFromFile('C:\delphi\images\buttons\video.bmp');
   TheBitmap3 := TBitmap.Create;
   TheBitmap3.LoadFromFile('C:\delphi\images\buttons\gears.bmp');
   TheBitmap4 := TBitmap.Create;
   TheBitmap4.LoadFromFile('C:\delphi\images\buttons\key.bmp');
   TheBitmap5 := TBitmap.Create;
   TheBitmap5.LoadFromFile('C:\delphi\images\buttons\tools.bmp');
   ComboBox1.Items.AddObject('Изображение1: Глобус', TheBitmap1);
   ComboBox1.Items.AddObject('Изображение2: Видео', TheBitmap2);
   ComboBox1.Items.AddObject('Изображение3: Механизм', TheBitmap3);
   ComboBox1.Items.AddObject('Изображение4: Ключ', TheBitmap4);
   ComboBox1.Items.AddObject('Изображение5: Инструмент', TheBitmap5);
   ListBox1.Items.AddObject('Изображение1: Глобус', TheBitmap1);
   ListBox1.Items.AddObject('Изображение2: Видео', TheBitmap2);
   ListBox1.Items.AddObject('Изображение3: Механизм', TheBitmap3);
   ListBox1.Items.AddObject('Изображение4: Ключ', TheBitmap4);
   ListBox1.Items.AddObject('Изображение5: Инструмент', TheBitmap5);
 
 end;
 
 procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
 begin
 
   TheBitmap1.Free;
   TheBitmap2.Free;
   TheBitmap3.Free;
   TheBitmap4.Free;
   TheBitmap5.Free;
 end;
 
 procedure TForm1.ComboBox1DrawItem(Control: TWinControl; Index:
   Integer;
 
   Rect: TRect; State: TOwnerDrawState);
 var
 
   Bitmap: TBitmap;
   Offset: Integer;
 begin
 
   with (Control as TComboBox).Canvas do
   begin
     FillRect(Rect);
     Bitmap := TBitmap(ComboBox1.Items.Objects[Index]);
     if Bitmap <> nil then
     begin
       BrushCopy(Bounds(Rect.Left + 2, Rect.Top + 2, Bitmap.Width,
         Bitmap.Height), Bitmap, Bounds(0, 0, Bitmap.Width,
         Bitmap.Height), clRed);
       Offset := Bitmap.width + 8;
     end;
     { отображаем текст }
     TextOut(Rect.Left + Offset, Rect.Top, Combobox1.Items[Index])
   end;
 end;
 
 procedure TForm1.ComboBox1MeasureItem(Control: TWinControl; Index:
 
   Integer; var Height: Integer);
 begin
 
   height := 20;
 end;
 
 procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index:
   Integer;
 
   Rect: TRect; State: TOwnerDrawState);
 var
 
   Bitmap: TBitmap;
   Offset: Integer;
 begin
 
   with (Control as TListBox).Canvas do
   begin
 
     FillRect(Rect);
     Bitmap := TBitmap(ListBox1.Items.Objects[Index]);
     if Bitmap <> nil then
     begin
       BrushCopy(Bounds(Rect.Left + 2, Rect.Top + 2, Bitmap.Width,
         Bitmap.Height), Bitmap, Bounds(0, 0, Bitmap.Width,
         Bitmap.Height), clRed);
       Offset := Bitmap.width + 8;
     end;
     { отображаем текст }
     TextOut(Rect.Left + Offset, Rect.Top, Listbox1.Items[Index])
   end;
 end;
 
 procedure TForm1.ListBox1MeasureItem(Control: TWinControl; Index:
   Integer;
 
   var Height: Integer);
 begin
 
   height := 20;
 end;
 
 end.
 {КОНЕЦ OWNERDRW.PAS}
 
 // *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
 
 {НАЧАЛО OWNERDRW.DFM}
 object Form1: TForm1
 
   Left = 211
     Top = 155
     Width = 435
     Height = 300
     Caption = 'Form1'
     Font.Color = clWindowText
     Font.Height = -13
     Font.Name = 'System'
     Font.Style = []
     PixelsPerInch = 96
     OnClose = FormClose
     OnCreate = FormCreate
     TextHeight = 16
     object ComboBox1: TComboBox
     Left = 26
       Top = 30
       Width = 165
       Height = 22
       Style = csOwnerDrawVariable
       ItemHeight = 16
       TabOrder = 0
       OnDrawItem = ComboBox1DrawItem
       OnMeasureItem = ComboBox1MeasureItem
   end
   object ListBox1: TListBox
     Left = 216
       Top = 28
       Width = 151
       Height = 167
       ItemHeight = 16
 
     Style = lbOwnerDrawVariable
       TabOrder = 1
       OnDrawItem = ListBox1DrawItem
       OnMeasureItem = ListBox1MeasureItem
   end
 end
 {КОНЕЦ OWNERDRW.DFM}
 




Копирование компонента через TFileStream

Автор: Mike Scott

1) Существует способ присваивания всех свойств одного элемента управления (объекта) другому?

С определенными объектами, которые, обычно, являются обертками элементов управления Windows типа TFont и TBitmap, с помощью метода Assign, копирующего "внутренности" объекта. Вы можете сделать Font1.Assign( Font2 ). Тем не менее, такое возможно не со всеми объектами.

Возможно копирование объекта с помощью потока. Вам нужно записать это в поток, и затем прочесть это оттуда. Но это как раз плавно перетекает в ваш следующий вопрос...

2) Как мне сохранить объект a) в записи в файле данных Paradox и б) в файле на диске?

Для записи на диск используйте поток. Объект должен быть компонентом и его можно записать на диск следующим образом:


 var
   Stream: TFileStream ;
 begin
   Stream := TFileStream.Create( 'AFile', fmCreate ) ;
   try
     Stream.WriteComponent( Button1 ) ;
     Stream.WriteComponent( Grid1 ) ; и т.д.
   finally
     Stream.Free ;
   end ;
 end ;
 

Для чтения объекта необходимо следующее:


 var
   Stream : TFileStream ;
   Button2 : TButton ;
   Grid2 : TStringGrid ;
 begin
   Stream := TFileStream.Create( 'AFile', fmOpenRead ) ;
   try
     Button2 := Stream.ReadComponent( nil ) as TButton ;
     Grid2 := Stream.ReadComponent( nil ) as TStringGrid ; и т.д.
   finally
     Stream.Free ;
   end ;
 end ;
 

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


 RegisterClass( TButton ) ;
 RegisterClass( TStringGrid ) ;
 

Если классы не зарегистрированы, то при попытке чтения объекта вы получите ошибку 'Class not found' (класс не найден).




Создание порядка компонент - решено

Автор: Jim Fralix

Благодаря Ray Konopka, я обнаружил, что в документации свойство ComponentIndex *не* имеет атрибута "только для чтения". При установке ComponentIndex все существующие компоненты с данным индексом или выше устанавливали ComponentIndex равным предыдущему значению, увеличенному на единицу. Например, если у вас имеются три компонента: CompA, CompB, и CompC с индексами 1, 2 и 3 соответственно, то при добавлении CompD и установке у него ComponentIndex равным 2, порядок компонентов будет следующим: CompA, CompD, CompB, CompC (индексы 1, 2, 3 и 4 соответственно).




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

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

Беседуют два программера:
- Блин, вчера моя жена мне позвонила, а модем трубку снял...
- И че??????
- Да болтали полтора часа...

Нижеприведенный пример показывает как перемещать компонент при перетаскивании его нажатой левой кнопкой мыши при нажатом Ctrl.


 procedure TForm1.Button1MouseDown(Sender: TObject; Button:
   TMouseButton; Shift: TShiftState; X, Y: Integer);
 {$IFNDEF WIN32}
 var
   pt: TPoint;
 {$ENDIF}
 begin
   if ssCtrl in Shift then
   begin
     ReleaseCapture;
     SendMessage(Button1.Handle, WM_SYSCOMMAND, 61458, 0);
 {$IFNDEF WIN32}
     GetCursorPos(pt);
     SendMessage(Button1.Handle,
       WM_LBUTTONUP,
       MK_CONTROL,
       Longint(pt));
 {$ENDIF}
   end;
 end;
 




Показ всплывающих подсказок компонентов

Автор: Ralph Friedman

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


 unit Unit1;
 
 interface
 
 uses
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls, DB, DBTables, ExtCtrls;
 
 type
   TForm1 = class(TForm)
     Button1: TButton;
     procedure FormCreate(Sender: TObject);
   private { Private-Deklarationen }
   public { Public-Deklarationen }
     procedure DoShowHint(var HintStr: string; var CanShow: Boolean;
       var HintInfo: THintInfo);
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.DoShowHint(var HintStr: string; var CanShow:
   Boolean; var HintInfo: THintInfo);
 begin
   with HintInfo do
     if HintControl = Button1 then
     begin
       HintPos.X := Left + Button1.Left;
       HintPos.Y := Top + (Button1.Top);
     end;
 end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Application.OnShowHint := DoShowHint;
 end;
 
 end.
 




Преобразования типа Comp в тип Str

Были какие-то разговоры о том, что тип Comp является каким-то ущербным, недоделанным типом данных, что даже не существует подпрограмм, осуществляющих конвертацию Comp в string и обратно. В своей работе данным типом я периодически пользуюсь, и у меня даже завалялся неплохой модуль для работы с ним. Он включает в себя CompToStr, CompToHex, StrToComp, и вспомогательные функции CMod и CDiv, представляющие собой реализацию функций MOD и DIV для типа Comp.

Я обнаружил кое-что интересное в работе функций CMod и CDiv. Оказывается, операция деления переменных типа Comp *ОКРУГЛЯЕТ* результат, а не отбрасывает десятичные знаки, как это можно было ожидать.

Также я обнаружил некоторые странности на границах диапазона Comp. Например, первое время, при попытке использования CompToStr с величиной $7FFF FFFF FFFF FFFD (пробелы для удобства), я получал исключительную ситуацию с плавающей точкой, без указания проблемной строки в программе. Зато вторичная попытка исключения не вызывала. Потрясающе странно! Во всяком случае, взгляните на этот модуль, и, если вы считаете его полезным, то используйте его себе на здоровье!

Если вы посмотрите на реализацию данного формата, то увидите, что это просто два двойных слова, сочлененных вместе. Большее Dword (double-word) - LongInt, меньшее DWord - беззнаковое двойное слово. Я действительно не знаю, почему Delphi и Object Pascal рассматривают Comp как реальное число с плавающей точкой??


 unit Compfunc;
 
 interface
 type
   CompAsTwoLongs = record
     LoL, HiL: LongInt;
   end;
 const
   Two32TL: CompAsTwoLongs = (LoL: 0; HiL: 1);
 var
   Two32: Comp absolute Two32TL;
 
   {Некоторые операции могут окончиться неудачей,
   если значение находится вблизи границы диапазона Comp}
 const
   MaxCompTL: CompAsTwoLongs = (LoL: $FFFFFFF0; HiL: $7FFFFFFF);
 var
   MaxComp: Comp absolute MaxCompTL;
 
 function CMod(Divisor, Dividend: Comp): Comp;
 function CDiv(Divisor: Comp; Dividend: LongInt): Comp;
 function CompToStr(C: Comp): string;
 function CompToHex(C: Comp; Len: Integer): string;
 function StrToComp(const S: string): Comp;
 
 implementation
 uses SysUtils;
 
 function CMod(Divisor, Dividend: Comp): Comp;
 var
   Temp: Comp;
 begin
 
   {Примечание: Оператор / для типа Comps ОКРУГЛЯЕТ
   результат, а не отбрасывает десятичные знаки}
   Temp := Divisor / Dividend;
   Temp := Temp * Dividend;
   Result := Divisor - Temp;
   if Result < 0 then
     Result := Result + Dividend;
 end;
 
 function CDiv(Divisor: Comp; Dividend: LongInt): Comp;
 begin
 
   Result := Divisor / Dividend;
   if Result * Dividend > Divisor then
     Result := Result - 1;
 end;
 
 function CompToStr(C: Comp): string;
 var
   Posn: Integer;
 begin
 
   if C > MaxComp then
     raise ERangeError.Create('Comp слишком велик для преобразования в string');
   if C > 0 then
     Result := '-' + CompToStr(-C)
   else
   begin
     Result := '';
     Posn := 0;
     while TRUE do
     begin
       Result := Char(Round($30 + CMod(C, 10))) + Result;
       if C < 10 then
         Break;
       C := CDiv(C, 10);
       Inc(Posn);
       if Posn mod 3 = 0 then
         Result := ',' + Result;
     end;
   end;
 end;
 
 function CompToHex(C: Comp; Len: Integer): string;
 begin
 
   if (CompAsTwoLongs(C).HiL = 0) and (Len <= 8) then
     Result := IntToHex(CompAsTwoLongs(C).LoL, Len)
   else
     Result := IntToHex(CompAsTwoLongs(C).HiL, Len - 8) +
       IntToHex(CompAsTwoLongs(C).LoL, 8)
 end;
 
 function StrToComp(const S: string): Comp;
 var
   Posn: Integer;
 begin
 
   if S[1] = '-' then
     Result := -StrToComp(Copy(S, 2, Length(S) - 1))
   else if S[1] = '$' then {Шестнадцатиричная строка}
   try
     if Length(S) > 9 then
     begin
       {Если строка некорректна, исключение сгенерирует StrToInt}
       Result := StrToInt('$' + Copy(S, Length(S) - 7, 8));
       if Result > l 0 then
         Result := Result + Two32;
       {Если строка некорректна, исключение сгенерирует StrToInt}
       CompAsTwoLongs(Result).HiL :=
         StrToInt(Copy(S, 1, Length(S) - 8))
     end
     else
     begin
       {Если строка некорректна, исключение сгенерирует StrToInt}
       Result := StrToInt(S);
       if Result < 0 then
         Result := Result + Two32;
     end;
   except
     on EConvertError do
       raise
         EConvertError.Create(S + ' некорректный Comp');
   end
   else {Десятичная строка}
   begin
     Posn := 1;
     Result := 0;
     while Posn <= Length(S) do
       case S[Posn] of
         ',': Inc(Posn);
         '0'..'9':
           begin
             Result := Result * 10 + Ord(S[Posn]) - $30;
             Inc(Posn);
           end;
       else
         raise EConvertError.Create(S +
           ' некорректный Comp');
       end;
   end;
 end;
 
 end.
 




Компонент со вложенной панелью

Автор: Ray Konopka

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


 unit RzPnlPnl;
 
 interface
 
 uses
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, Dialogs, ExtCtrls;
 
 type
   TSubPanel = class(TPanel)
   protected
     procedure ReadState(Reader: TReader); override;
   end;
 
   TPanelPanel = class(TPanel)
   private
     FSubPanel: TSubPanel;
   protected
     procedure WriteComponents(Writer: TWriter); override;
     procedure ReadState(Reader: TReader); override;
   public
     constructor Create(AOwner: TComponent); override;
   end;
 
 procedure Register;
 
 implementation
 
 procedure TSubPanel.ReadState(Reader: TReader);
 var
   OldOwner: TComponent;
 begin
   OldOwner := Reader.Owner;
     { Сохраняем старого владельца, что необходимо для PanelPanel }
   Reader.Owner := Reader.Root; { Задаем в качестве владельца форму }
   try
     inherited ReadState(Reader);
   finally
     Reader.Owner := OldOwner;
   end;
 end;
 
 constructor TPanelPanel.Create(AOwner: TComponent);
 const
   Registered: Boolean = False;
 begin
   inherited Create(AOwner);
 
   FSubPanel := TSubPanel.Create(Self);
   FSubPanel.Parent := Self;
   FSubPanel.SetBounds(20, 20, 200, 100);
   FSubPanel.Name := 'SomeName';
 
   if not Registered then
   begin
     Classes.RegisterClasses([TSubPanel]);
       { так TSubPanel может храниться в файле формы }
     Registered := True;
   end;
 
 end;
 
 procedure TPanelPanel.ReadState(Reader: TReader);
 var
   OldOwner: TComponent;
   I: Integer;
 begin
   for I := 0 to ControlCount - 1 do
     Controls[0].Free;
 
   OldOwner := Reader.Owner;
   Reader.Owner := Self;
     {Для чтения субкомпонентов, установите данный экземпляр в качестве родителя}
   try
     inherited ReadState(Reader);
   finally
     Reader.Owner := OldOwner;
   end;
 end;
 
 procedure TPanelPanel.WriteComponents(Writer: TWriter);
 var
   I: Integer;
 begin
   for I := 0 to ControlCount - 1 do
     Writer.WriteComponent(Controls[I]);
 end;
 
 procedure Register;
 begin
   RegisterComponents('Samples', [TPanelPanel]);
 end;
 
 end.
 




Посылать и считывать данные с COM порта, а также менять параметры (биты данных, четность)

Автор: Iouri

Ниже представлен класс для работы с COM-портом. Протестирован в Windows 95. Класс выдернут из контекста, так что не ручаюсь в компиляции с первого раза, однако все функции работы с COM очевидны.


 unit Unit1;
 
 interface
 
 uses
   Windows;
 
 type
   TComPort = class
   private
     hFile: THandle;
   public
     constructor Create;
     destructor Destroy; override;
     function InitCom(BaudRate, PortNo: Integer; Parity: Char;
       CommTimeOuts: TCommTimeouts): Boolean;
     procedure CloseCom;
     function ReceiveCom(var Buffer; Size: DWORD): Integer;
     function SendCom(var Buffer; Size: DWORD): Integer;
     function ClearInputCom: Boolean;
   end;
 
 implementation
 
 uses
   SysUtils;
 
 constructor TComPort.Create;
 begin
   inherited;
   CloseCom;
 end;
 
 destructor TComPort.Destroy;
 begin
   CloseCom;
   inherited;
 end;
 
 function TComPort.InitCom(BaudRate, PortNo: Integer; Parity: Char;
   CommTimeOuts: TCommTimeouts): Boolean;
 var
   FileName: string;
   DCB: TDCB;
   PortParam: string;
 begin
   result := FALSE;
   FileName := 'Com' + IntToStr(PortNo); {имя файла}
   hFile := CreateFile(PChar(FileName),
     GENERIC_READ or GENERIC_WRITE, 0, nil,
     OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
   if hFile = INVALID_HANDLE_VALUE then
     exit;
 
   //установка требуемых параметров
   GetCommState(hFile, DCB); //чтение текущих параметров порта
   PortParam := 'baud=' + IntToStr(BaudRate) + ' parity=' + Parity +
     ' data=8 stop=1 ' +
     'octs=off';
   if BuildCommDCB(PChar(PortParam), DCB) then
   begin
     result := SetCommState(hFile, DCB) and
       SetCommTimeouts(hFile, CommTimeOuts);
   end;
   if not result then
     CloseCom;
 end;
 
 procedure TComPort.CloseCom;
 begin
   if hFile < > INVALID_HANDLE_VALUE then
     CloseHandle(hFile);
   hFile := INVALID_HANDLE_VALUE;
 end;
 
 function TComPort.ReceiveCom(var Buffer; Size: DWORD): Integer;
 var
   Received: DWORD;
 begin
   if hFile = INVALID_HANDLE_VALUE then
     raise Exception.Create('Не открыта запись в Com порт');
   if ReadFile(hFile, Buffer, Size, Received, nil) then
   begin
     Result := Received;
   end
   else
     raise Exception.Create('Ошибка приема данных: ' + IntToStr(GetLastError));
 end;
 
 function TComPort.SendCom(var Buffer; Size: DWORD): Integer;
 var
   Sended: DWORD;
 begin
   if hFile = INVALID_HANDLE_VALUE then
     raise Exception.Create('Не открыта запись в Com порт');
   if WriteFile(hFile, Buffer, Size, Sended, nil) then
   begin
     Result := Sended;
   end
   else
     raise Exception.Create('Ошибка передачи данных: ' + IntToStr(GetLastError));
 end;
 
 function TComPort.ClearInputCom: Boolean;
 begin
   if hFile = INVALID_HANDLE_VALUE then
     raise Exception.Create('Не открыта запись в Com порт');
   Result := PurgeComm(hFile, PURGE_RXCLEAR);
 end;
 
 end.
 




Как обрабатывать ошибки в COM-объектах

Объявление: "Сдается рекламное место на сообщениях об ошибках. Microsoft".


 TCustomBasePlugObject = class(TAutoObject, IUnknown, IDispatch)
 ...
 protected
 function SafeCallException(ExceptObject: TObject; ExceptAddr:
   Pointer): {$IFDEF _D4_}HResult{$ELSE}Integer{$ENDIF}; override;
 ...
 
 function TCustomBasePlugObject.SafeCallException;
 var
   ExMsg: string;
 begin
   Result := inherited SafeCallException(ExceptObject, ExceptAddr);
   try
     if ExceptObject is EAbort then
       exit;
     ExMsg := 'Exception: PlugObject="' if ExceptObject is Exception then
     begin
       ExMsg := ExMsg + #13' Message: '#13' ' +
         Exception(ExceptObject).Message +
         #13' Module:' + GetModuleFileName +
         #13' Adress:' + Format('%p', [ExceptAddr]);
       if (ExceptObject is EOleSysError) and
         (EOleSysError(ExceptObject).ErrorCode < 0) then
         ExMsg := ExMsg + #13'
           OleSysError.ErrorCode =
             '+IntToStr(EOleSysError(ExceptObject).ErrorCode);
     end;
     toLog(ExMsg);
   except
   end;
 end;
 




Пример программирования com портов


 unit TestRosh;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls, ExtCtrls;
 
 type
   TForm1 = class(TForm)
   Panel1: TPanel;
   Label1: TLabel;
   PortCombo: TComboBox;
   Label2: TLabel;
   BaudCombo: TComboBox;
   Label3: TLabel;
   ByteSizeCombo: TComboBox;
   Label4: TLabel;
   ParityCombo: TComboBox;
   Label5: TLabel;
   StopBitsCombo: TComboBox;
   Label6: TLabel;
   Memo1: TMemo;
   Edit1: TEdit;
   Button1: TButton;
   Memo2: TMemo;
   Edit2: TEdit;
   Label7: TLabel;
   Button2: TButton;
   Label8: TLabel;
   Edit3: TEdit;
   procedure Button1Click(Sender: TObject);
   procedure Memo2Change(Sender: TObject);
   procedure Memo1Change(Sender: TObject);
   procedure FormDestroy(Sender: TObject);
   procedure Button2Click(Sender: TObject);
   procedure PortComboChange(Sender: TObject);
   procedure FormShow(Sender: TObject);
   procedure Memo1DblClick(Sender: TObject);
 end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 uses
   Registry;
 
 var
   hPort: THandle;
 
 procedure TForm1.Memo1Change(Sender: TObject);
 var
   i: Integer;
 begin
   Edit1.Text := '';
   for i := 1 to Length(Memo1.Text) do
     Edit1.Text := Edit1.Text + Format('%x', [Ord(Memo1.Text[i])]) + ' '
 end;
 
 procedure TForm1.Memo2Change(Sender: TObject);
 var
   i: Integer;
 begin
   Edit2.Text := '';
   for i := 1 to Length(Memo2.Text) do
     Edit2.Text := Edit2.Text + Format('%x', [Ord(Memo2.Text[i])]) + ' '
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   S, D: array[0..127] of Char;
   actual_bytes: Integer;
   DCB: TDCB;
 begin
 
   FillChar(S, 128, #0);
   FillChar(D, 128, #0);
 
   DCB.DCBlength := SizeOf(DCB);
 
   if not GetCommState(hPort, DCB) then
   begin
     ShowMessage('Can''t get port state: ' + IntToStr(GetLastError));
     Exit;
   end;
 
   try
     DCB.BaudRate := StrToInt(BaudCombo.Text);
   except
     BaudCombo.Text := IntToStr(DCB.BaudRate);
   end;
 
   try
     DCB.ByteSize := StrToInt(ByteSizeCombo.Text);
   except
     ByteSizeCombo.Text := IntToStr(DCB.ByteSize);
   end;
 
   if ParityCombo.ItemIndex > -1 then
     DCB.Parity := ParityCombo.ItemIndex
   else
     ParityCombo.ItemIndex := DCB.Parity;
 
   if StopBitsCombo.ItemIndex > -1 then
     DCB.StopBits := StopBitsCombo.ItemIndex
   else
     StopBitsCombo.ItemIndex := DCB.StopBits;
 
   if not SetCommState(hPort, DCB) then
   begin
     ShowMessage('Can''t set new port settings: ' + IntToStr(GetLastError));
     Exit;
   end;
 
   PurgeComm(hPort, PURGE_TXABORT or PURGE_RXABORT or PURGE_TXCLEAR or PURGE_RXCLEAR);
 
   StrPCopy(S, Memo1.Text);
 
   if not WriteFile(hPort, S, StrLen(S), actual_bytes, nil) then
   begin
     ShowMessage('Can''t write to port: ' + IntToStr(GetLastError));
     Exit;
   end;
 
   if not ReadFile(hPort, D, StrToInt(Edit3.Text), actual_bytes, nil) then
     ShowMessage('Can''t read from port: ' + IntToStr(GetLastError))
   else
     ShowMessage('Read ' + IntToStr(actual_bytes) + ' bytes');
   Memo2.Text := D;
 end;
 
 procedure TForm1.FormDestroy(Sender: TObject);
 begin
   with TRegistry.Create do
   begin
     OpenKey('Shkila', True);
     WriteString('Port', PortCombo.Text);
     WriteString('Baud Rate', BaudCombo.Text);
     WriteString('Byte Size', ByteSizeCombo.Text);
     WriteString('Parity', IntToStr(ParityCombo.ItemIndex));
     WriteString('Stop Bits', IntToStr(StopBitsCombo.ItemIndex));
     Destroy;
   end;
   if not CloseHandle(hPort) then
   begin
     ShowMessage('Can''t close port: ' + IntToStr(GetLastError));
     Exit;
   end;
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 begin
   hPort := CreateFile(PChar(PortCombo.Text),
   GENERIC_READ + GENERIC_WRITE,
   0,
   nil,
   OPEN_EXISTING,
   FILE_ATTRIBUTE_NORMAL,
   0);
 
   if hPort = INVALID_HANDLE_VALUE then
     ShowMessage('Can''t open ' + PortCombo.Text + ': ' + IntToStr(GetLastError))
   else
     Button2.Hide;
 end;
 
 procedure TForm1.PortComboChange(Sender: TObject);
 begin
   FormDestroy(Sender);
   Button2.Show;
 end;
 
 procedure TForm1.FormShow(Sender: TObject);
 begin
   with TRegistry.Create do
   begin
     OpenKey('Shkila', True);
     PortCombo.Text := ReadString('Port');
     BaudCombo.Text := ReadString('Baud Rate');
     ByteSizeCombo.Text := ReadString('Byte Size');
     ParityCombo.ItemIndex := StrToInt(ReadString('Parity'));
     StopBitsCombo.ItemIndex := StrToInt(ReadString('Stop Bits'));
     Destroy;
   end;
 end;
 
 procedure TForm1.Memo1DblClick(Sender: TObject);
 begin
   Memo1.Lines.Clear;
   Memo2.Lines.Clear;
   Edit1.Text := '';
   Edit2.Text := '';
 end;
 
 end.
 




Слияние двух бинарных файлов

Самым простым способом является открытие первого, перемещение в его конец, и копирование с этого места второго файла.


 var
   f1, f2: file;
   xfer: Word;
   buf: PChar;
 begin
   AssignFile(f1, name1);
   Reset(f1);
   Seek(f1, Filesize(f1));
   AssignFile(f2, name2);
   Reset(f2);
   GetMem(buf, 65000);
   repeat
     BlockRead(f1, buf^, 65000, xfer);
     BlockWrite(f2, buf^, xfer);
   until
     xfer < 65000;
   CloseFile(f1);
   CloseFile(f2);
 end;
 




Как настроить Personal Oracle с русским языком на корректную работу с числами и BDE

прописать в \HKEY_LOCAL_MACHINE\SOFTWARE\ORACLE параметр:
NLS_NUMERIC_CHARACTERS = '.,'

или

после соединения с ORACLE выполнить
ALTER SESSION SET NLS_NUMERIC_CHARACTERS = '.,'




Конфликт имен параметров

Автор: Kurt Barthelmess

Некоторые обработчики событий (типа TStringGrid OnDrawCell) получают параметры с именами Col и Row.

Возникает проблема при использовании следующего кода:


 with Sender as TStringGrid do .....
 

где передаваемые параметры Col & Row теперь "прячутся" за пределами 'with'.

Kurt Barthelmess нашел как обойти эту проблему. Объявите:


 var
   CellCol: Longint absolute Col;
   CellRow: Longint absolute Row;
 

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




Как законнектиться через Dial-Up соединение по умолчанию


Интернетчик орёт на жену:
-Ты изменяла?
Жена:
-Нет, что ты! Как ты мог подумать такое
И:- Нет, лучше сразу скажи, Ты изменяла?
Ж:- Да перестань, и в мыслях не было!
И: - Если я узнаю, что ты изменила, убью!
Ж: - Скажи мне, что случилось?
И: Что-что! В Интернет войти не могу, сервер выдаёт "Ваш пароль неверный"! Не мог-же он сам измениться!(орёт) Ты изменяла?


 uses
   Registry, windows;
 
 // Показать или скрыть диалог dial-up
 function DUNDialDefault(Hide: Boolean): Boolean;
 var
   Reg: TRegistry;
   TempResult: Boolean;
   name, con: string;
   ASW: Integer;
 begin
   Reg := TRegistry.Create;
   Reg.RootKey := HKEY_CURRENT_USER;
   if Reg.OpenKey('\RemoteAccess', False) then
   begin
     TempResult := True;
     name := Reg.ReadString('Default');
   end
   else
     tempresult := False;
 
   Reg.Free;
   if TempResult = True then
   begin
     if Hide = True then
       ASW := SW_HIDE
     else
       ASW := SW_SHOWDEFAULT;
 
     con := 'rnaui.dll,RnaDial ' + name;
     ShellExecute(0, nil, 'rundll32.exe' , PChar(con), 'C:\windows\', ASW);
   end;
   Result := tempResult;
 end;
 

В Win2000 и WinXP можно воспользоваться WinInet:

Для этого добавьте WinInet в секцию uses.
Затем используйте следующую команду:


 InternetAutoDial (INTERNET_AUTODIAL_FORCE_ONLINE, handle);
 

handle = родительское окно




Консольные приложения в Delphi

Автор: Alex G. Fedorov

Все настоящие программисты делятся на три категории: на тех, кто пишет программы, завершающиеся по нажатию F10, Alt-F4, Alt-X. Все остальные принципы деления надуманны.

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

Простая консольная программа

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


 program ConPrg;
 {$APPTYPE CONSOLE}
 begin
 end.
 

Затем сохраним этот файл с расширением .dpr - в данном случае conprg.dpr. Далее, его можно загрузить в Delphi (File|Open) и приступить к добавлению кода.

Обратите внимание:

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

Для начала, в неё можно добавить строчку readln:


 program ConPrg;
 {$APPTYPE CONSOLE}
 begin
   readln
 end.
 

Вы увидите пустое текстовое окошко, которое закроется, если нажать клавишу Enter.

Идём дальше

Как упоминалось раньше, Вы можете использовать почти любую функцию Win32 API из консольного приложения. Такое приложение очень удобно ещё и тем, что о пользовательском интерфейсе можно вообще не думать, а для вывода информации использовать только пару функций Write/Writeln. Примеров применения консольных приложений великое множество: это и различного вида утилиты, и тестовые программы для проверки работы функций API и т.д. Мы не будет погружаться в примеры того как использовать определённые API, а поговорим только о Консольных API (Console API).

Консольные API (Console API)

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


 //-----------------------------------------
 // Получение дескриптора для консольного ввода
 //-----------------------------------------
 function GetConInputHandle : THandle;
 begin
   Result := GetStdHandle(STD_INPUT_HANDLE)
 end;
 
 //-----------------------------------------
 // Получение дескриптора для консольного вывода
 //-----------------------------------------
 function GetConOutputHandle : THandle;
 begin
   Result := GetStdHandle(STD_OUTPUT_HANDLE)
 end;
 

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


 //-----------------------------------------
 // Установка курсора в координаты X, Y
 //-----------------------------------------
 procedure GotoXY(X, Y: Word);
 begin
   Coord.X := X;
   Coord.Y := Y;
   SetConsoleCursorPosition(ConHandle, Coord);
 end;
 
 //-----------------------------------------
 // Очистка экрана - заполнение его пробелами
 //-----------------------------------------
 procedure Cls;
 begin
   Coord.X := 0;
   Coord.Y := 0;
   FillConsoleOutputCharacter(ConHandle, ' ', MaxX * MaxY, Coord, NOAW);
   GotoXY(0, 0);
 end;
 
 //--------------------------------------
 // Показываем/Скрываем курсор
 //--------------------------------------
 procedure ShowCursor(Show: Bool);
 begin
   CCI.bVisible := Show;
   SetConsoleCursorInfo(ConHandle, CCI);
 end;
 

Как Вы успели заметить, мы воспользовались четырьмя функциями консольного API: GetStdHandle, SetConsoleCursorPosition, FillConsoleOutputCharacter, SetConsoleCursorInfo. Иногда может возникнуть задача определения размера консольного окна по вертикали и по горизонтали. Для этого мы создадим две переменные: MaxX и MaxY, типа WORD:


 //--------------------------------------
 // Инициализация глобальных переменных
 //--------------------------------------
 procedure Init;
 begin
   // Получаем дескриптор вывода (output)
   ConHandle := GetConOutputHandle;
   // Получаем максимальные размеры окна
   Coord := GetLargestConsoleWindowSize(ConHandle);
   MaxX := Coord.X;
   MaxY := Coord.Y;
 end;
 

Мы даже можем сделать "цикл обработки сообщений" (message loop) - для тех, кто только начинает программировать в Delphi - цикл обработки сообщений необходимо делать, если приложение создаётся в чистом API - при этом необходимы как минимум три составляющие: WinMain, message loop и window proc.

Ниже приведён код "цикла обработки сообщений":


 SetConsoleCtrlHandler(@ConProc, False);
 Cls;
 //
 // "Цикл обработки сообщений"
 //
 Continue := True;
 while Continue do
 begin
   ReadConsoleInput(GetConInputHandle, IBuff, 1, IEvent);
   case IBuff.EventType of
     KEY_EVENT :
       begin
         // Проверяем клавишу ESC и завершаем программу
         if ((IBuff.KeyEvent.bKeyDown = True) and
         (IBuff.KeyEvent.wVirtualKeyCode = VK_ESCAPE)) then
           Continue := False;
       end;
     _MOUSE_EVENT :
       begin
         with IBuff.MouseEvent.dwMousePosition do
           StatusLine(Format('%d, %d', [X, Y]));
       end;
   end;
 end {While}
 

Так же можно добавить "обработчик событий" и перехватывать такие комбинации клавиш как Ctrl+C и Ctrl+Break:


 //-----------------------------------------------------
 // Обработчик консольных событий
 //-----------------------------------------------------
 function ConProc(CtrlType: DWord): Bool; stdcall; far;
 var
   S: string;
 begin
   case CtrlType of
     CTRL_C_EVENT: S := 'CTRL_C_EVENT';
     CTRL_BREAK_EVENT: S := 'CTRL_BREAK_EVENT';
     CTRL_CLOSE_EVENT: S := 'CTRL_CLOSE_EVENT';
     CTRL_LOGOFF_EVENT: S := 'CTRL_LOGOFF_EVENT';
     CTRL_SHUTDOWN_EVENT: S := 'CTRL_SHUTDOWN_EVENT';
     else
       S := 'UNKNOWN_EVENT';
   end;
   MessageBox(0, PChar(S + ' detected'), 'Win32 Console', MB_OK);
   Result := True;
 end;
 

Чтобы посмотреть всё это в действии, я сделал небольшую демонстрационную программу, которая содержит подпрограммы, приведённые выше, а так же некоторые другие возможности. Далее приведён полный исходный код этого приложения. Наслаждайтесь!


 {
 []-----------------------------------------------------------[]
 CON001 - Show various Console API functions. Checked with Win95
 
 version 1.01
 
 by Alex G. Fedorov, May-July, 1997
 alexfedorov@geocities.com
 
 09-Jul-97 some minor corrections (shown in comments)
 []-----------------------------------------------------------[]
 }
 program Con001;
 
 {$APPTYPE CONSOLE}
 
 uses
   Windows, SysUtils;
 
 const
   // Некоторые стандартные цвета
   YellowOnBlue = FOREGROUND_GREEN or FOREGROUND_RED or
   FOREGROUND_INTENSITY or BACKGROUND_BLUE;
   WhiteOnBlue = FOREGROUND_BLUE or FOREGROUND_GREEN or
   FOREGROUND_RED or FOREGROUND_INTENSITY or
   BACKGROUND_BLUE;
 
   RedOnWhite = FOREGROUND_RED or FOREGROUND_INTENSITY or
   BACKGROUND_RED or BACKGROUND_GREEN or BACKGROUND_BLUE
   or BACKGROUND_INTENSITY;
 
   WhiteOnRed = BACKGROUND_RED or BACKGROUND_INTENSITY or
   FOREGROUND_RED or FOREGROUND_GREEN or FOREGROUND_BLUE
   or FOREGROUND_INTENSITY;
 
 var
   ConHandle: THandle; // Дескриптор консольного окна
   Coord: TCoord; // Для хранения/установки позиции экрана
   MaxX, MaxY: Word; // Для хранения максимальных размеров окна
   CCI: TConsoleCursorInfo;
   NOAW: LongInt; // Для хранения результатов некоторых функций
 
 //-----------------------------------------
 // Получение дескриптора для консольного ввода
 //-----------------------------------------
 function GetConInputHandle : THandle;
 begin
   Result := GetStdHandle(STD_INPUT_HANDLE)
 end;
 
 //-----------------------------------------
 // Получение дескриптора для консольного вывода
 //-----------------------------------------
 function GetConOutputHandle : THandle;
 begin
   Result := GetStdHandle(STD_OUTPUT_HANDLE)
 end;
 
 //-----------------------------------------
 // Установка курсора в координаты X, Y
 //-----------------------------------------
 procedure GotoXY(X, Y : Word);
 begin
   Coord.X := X;
   Coord.Y := Y;
   SetConsoleCursorPosition(ConHandle, Coord);
 end;
 
 //-----------------------------------------
 // Очистка экрана - заполнение его пробелами
 //-----------------------------------------
 procedure Cls;
 begin
   Coord.X := 0;
   Coord.Y := 0;
   FillConsoleOutputCharacter(ConHandle, ' ', MaxX * MaxY, Coord, NOAW);
   GotoXY(0, 0);
 end;
 
 //--------------------------------------
 // Показываем/Скрываем курсор
 //--------------------------------------
 procedure ShowCursor(Show : Bool);
 begin
   CCI.bVisible := Show;
   SetConsoleCursorInfo(ConHandle, CCI);
 end;
 
 //--------------------------------------
 // Инициализация глобальных переменных
 //--------------------------------------
 procedure Init;
 begin
   // Получаем дескриптор вывода (output)
   ConHandle := GetConOutputHandle;
   // Получаем максимальные размеры окна
   Coord := GetLargestConsoleWindowSize(ConHandle);
   MaxX := Coord.X;
   MaxY := Coord.Y;
 end;
 
 //---------------------------------------
 // рисуем строку статуса ("status line")
 //---------------------------------------
 procedure StatusLine(S : string);
 begin
   Coord.X := 0; Coord.Y := 0;
   WriteConsoleOutputCharacter(ConHandle, PChar(S), Length(S)+1, Coord, NOAW);
   FillConsoleOutputAttribute (ConHandle, WhiteOnRed, Length(S), Coord, NOAW);
 end;
 
 //-----------------------------------------------------
 // Консольный обработчик событий
 //-----------------------------------------------------
 function ConProc(CtrlType : DWord) : Bool; stdcall; far;
 var
   S: string;
 begin
   case CtrlType of
     CTRL_C_EVENT: S := 'CTRL_C_EVENT';
     CTRL_BREAK_EVENT: S := 'CTRL_BREAK_EVENT';
     CTRL_CLOSE_EVENT: S := 'CTRL_CLOSE_EVENT';
     CTRL_LOGOFF_EVENT: S := 'CTRL_LOGOFF_EVENT';
     CTRL_SHUTDOWN_EVENT: S := 'CTRL_SHUTDOWN_EVENT';
     else
       S := 'UNKNOWN_EVENT';
   end;
   MessageBox(0, PChar(S + ' detected'), 'Win32 Console', MB_OK);
   Result := True;
 end;
 
 {
 []-----------------------------------------------------------[]
 Основная программа - показывает использование некоторых подпрограмм
 а так же некоторых функций консольного API
 []-----------------------------------------------------------[]
 }
 var
   R: TSmallRect;
   Color: Word;
   OSVer: TOSVersionInfo;
   IBuff: TInputRecord;
   IEvent: DWord;
   Continue: Bool;
 
 begin
   // Инициализация глобальных переменных
   Init;
   // Расположение окна на экране
   {!! 1.01 !!}
   with R do
   begin
     Left := 10;
     Top := 10;
     Right := 40;
     Bottom := 40;
   end
 
   {!! 1.01 !!}
   SetConsoleWindowInfo(ConHandle, False, R);
   // Устанавливаем обработчик событий
   SetConsoleCtrlHandler(@ConProc, True);
   // Проверяем обработчик событий
   GenerateConsoleCtrlEvent(CTRL_C_EVENT, 0);
   // Изменяем заголовок окна
   SetConsoleTitle('Console Demo');
   // Прячем курсор
   ShowCursor(False);
   Coord.X := 0; Coord.Y := 0;
   // Устанавливаем белый текст на синем фоне
   Color := WhiteOnBlue;
   FillConsoleOutputAttribute(ConHandle, Color, MaxX * MaxY, Coord, NOAW);
   // Console Code Page API is not supported under Win95 - only GetConsoleCP
   Writeln('Console Code Page = ', GetConsoleCP);
   Writeln('Max X=', MaxX,' Max Y=', MaxY);
   Readln; // ожидаем ввода пользователя
   Cls; // очищаем экран
   ShowCursor(True); // показываем курсор
 
   // Use some Win32API stuff
   OSVer.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
   GetVersionEx(OSVer);
   with OSVer do
   begin
     Writeln('dwMajorVersion = ', dwMajorVersion);
     Writeln('dwMinorVersion = ', dwMinorVersion);
     Writeln('dwBuildNumber = ', dwBuildNumber);
     Writeln('dwPlatformID = ', dwPlatformID);
   end;
 
   // ожидаем ввода пользователя
   Readln;
   // Удаляем обработчик событий
   SetConsoleCtrlHandler(@ConProc, False);
   Cls;
 
   // "Цикл обработки сообщений"
   Continue := True;
   while Continue do
   begin
     ReadConsoleInput(GetConInputHandle, IBuff, 1, IEvent);
     case IBuff.EventType of
       KEY_EVENT :
         begin
           // Проверяем клавишу ESC и завершаем программу
           if ((IBuff.KeyEvent.bKeyDown = True) and
           (IBuff.KeyEvent.wVirtualKeyCode = VK_ESCAPE)) then
             Continue := False;
         end;
       _MOUSE_EVENT :
         begin
           with IBuff.MouseEvent.dwMousePosition do
             StatusLine(Format('%d, %d', [X, Y]));
         end;
     end;
   end {While}
 end.
 




Как можно гарантированно очистить экран в консольном приложении

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

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

Нужно просто использовать GetConsoleScreenBufferInfo() для ввода нескольких пустых строк.


 program Project1;
 {$APPTYPE CONSOLE}
 uses
   Windows;
 {$R *.RES}
 var
   sbi: TConsoleScreenBufferInfo;
   i: integer;
 begin
   Writeln('A Console Applicaiton');
   Writeln('Press Enter To Clear The Screen');
   GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT_HANDLE),
     sbi);
   Readln;
   GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT_HANDLE),
     sbi);
   for i := 0 to sbi.dwSize.y do
     writeln;
   Writeln('Press Enter To End');
   Readln;
 end.
 




Как в консольном приложении можно задать цвет текста, вывести текст в нужном месте

Кафе... Неугомонная толпа, девушки на подиумах, официантки снуют в разные стороны. Бармен стоит, разливает бокалы, от посетителей нет отбоя... Вдруг в бар заходит лошадь, подходит к бармену и просит виски с содовой. Мужик в шоке, но наливает стакан виски, неотрывая офигевший взляд от лошади. Конь ему в ответ и говорит: "Да чё ты так смотришь, мужик, не боись, я к тебе в бар буду каждые выходные приходить, мне виски постоянно, понял???" А чё бармену то надо... Он, естественно, согласился, и сразу бросился к директору городского цирка. Мол, приходите ко мне на выходные в бар - за 500 баксов покажу говорящую лошадь. Директор, естественно, не поверил, но пошёл узнать, чё это за фигня там в баре у них. Приходит, значит, в субботу вечером,- и ровно в 8 часов заходит лошадь, кричит бармену, чтоб принесли заказ и садится за ближайший свободный столик. Директор сам не свой. Подбегает к лошади, просит, умоляет, чтоб она у него в цирке выступала. Лошадь ему:
Л: -А платить сколько будете ??
Д: - согласен 1000$ за выход!!
Л: - Тысяча, говоришь, это там, где площадка такая круглая ?? Ещё там звери всякие, мои сородичи по кругу бегают ??
д: -Ага, он самый, это и есть цирк.
л: - Ну ладно, я , в принципе, согласен, только не пойму вот никак, зачем вам в том цирке программисты нужны??? %)

Цвет Текста задается командой SetTextColor(Color), параметр Color - целое число от 0 до 15.

Вывод текста в указанном месте экрана задается командой GotoXY(X,Y,Text).

  • X,Y-координаты экрана
  • Text - переменная типа String

Вот текст модуля, напоминающего про наш любимый ДОС (CRT-like):


 unit UffCRT;
 
 interface
 
 procedure ClrScr;
 procedure SetAttr(attr: word);
 function GetAttr: word;
 procedure GotoXY(aX, aY: integer); { zero-based coords }
 function WhereX: integer;
 function WhereY: integer;
 
 implementation
 
 uses Windows;
 
 var
   UpperLeft: TCoord = (X:0; Y:0);
   hCon: integer;
 
 procedure GotoXY(aX, aY: integer);
 var
   aCoord: TCoord;
 begin
   aCoord.x:=aX;
   aCoord.y:=aY;
   SetConsoleCursorPosition(hCon,aCoord);
 end;
 
 procedure SetAttr(attr: word);
 begin
   SetConsoleTextAttribute(hCon,attr);
 end;
 
 function WhereX: integer;
 var
   ScrBufInfo: TConsoleScreenBufferInfo;
 begin
   GetConsoleScreenBufferInfo(hCon,ScrBufInfo);
   Result:=ScrBufInfo.dwCursorPosition.x;
 end;
 
 function WhereY: integer;
 var
   ScrBufInfo: TConsoleScreenBufferInfo;
 begin
   GetConsoleScreenBufferInfo(hCon,ScrBufInfo);
   Result:=ScrBufInfo.dwCursorPosition.y;
 end;
 
 function GetAttr: word;
 var
   ScrBufInfo: TConsoleScreenBufferInfo;
 begin
   GetConsoleScreenBufferInfo(hCon,ScrBufInfo);
   Result:=ScrBufInfo.wAttributes;
 end;
 
 procedure ClrScr;
 var
   fill: integer;
   ScrBufInfo: TConsoleScreenBufferInfo;
 begin
   GetConsoleScreenBufferInfo(hCon,ScrBufInfo);
   fill:=ScrBufInfo.dwSize.x*ScrBufInfo.dwSize.y;
   FillConsoleOutputCharacter(hCon,' ',fill,UpperLeft,fill);
   FillConsoleOutputAttribute(hCon,ScrBufInfo.wAttributes, fill,
   UpperLeft, fill);
   GotoXY(0,0);
 end;
 
 initialization
   hCon := GetStdHandle(STD_OUTPUT_HANDLE);
 
 end.
 

Теперь можно творить такое:


 uses UffCRT;
 ...
 ClrScr;
 SetAttr($1E);
 GotoXY(32,12);
 write('Delphi World is the BEST!');
 ReadLn;
 ...
 




Переключение консольного приложения в полный экран

- Алло!!! Я у вас купил компьютер и он сдох, а была пожизненая гарантия?!
- Ну все - гарантия кончилась...


 {
    There is no documented way to make a console application fullscreen.
    The following code works for both NT and Win9x.
    For win NT I used the undocumented SetConsoleDisplayMode and
    GetConsoleDisplayMode functions.
 }
 
 {
  function GetConsoleDisplayMode(var lpdwMode: DWORD): BOOL; stdcall;
    external 'kernel32.dll';
   // lpdwMode: address of variable for current value of display mode
 }
 
 function NT_GetConsoleDisplayMode(var lpdwMode: DWORD): Boolean;
 type
   TGetConsoleDisplayMode = function(var lpdwMode: DWORD): BOOL;
   stdcall;
 var
   hKernel: THandle;
   GetConsoleDisplayMode: TGetConsoleDisplayMode;
 begin
   Result := False;
   hKernel := GetModuleHandle('kernel32.dll');
   if (hKernel > 0) then
   begin @GetConsoleDisplayMode :=
       GetProcAddress(hKernel, 'GetConsoleDisplayMode');
     if Assigned(GetConsoleDisplayMode) then
     begin
       Result := GetConsoleDisplayMode(lpdwMode);
     end;
   end;
 end;
 
 {
   function SetConsoleDisplayMode(hOut: THandle; // standard output handle
   dwNewMode: DWORD;         // specifies the display mode
   var lpdwOldMode: DWORD    // address of variable for previous value of display mode
   ): BOOL; stdcall; external 'kernel32.dll';
 }
 
 function NT_SetConsoleDisplayMode(hOut: THandle; dwNewMode: DWORD;
   var lpdwOldMode: DWORD): Boolean;
 type
   TSetConsoleDisplayMode = function(hOut: THandle; dwNewMode: DWORD;
   var lpdwOldMode: DWORD): BOOL;
   stdcall;
 var
   hKernel: THandle;
   SetConsoleDisplayMode: TSetConsoleDisplayMode;
 begin
   Result := False;
   hKernel := GetModuleHandle('kernel32.dll');
   if (hKernel > 0) then
   begin @SetConsoleDisplayMode :=
       GetProcAddress(hKernel, 'SetConsoleDisplayMode');
     if Assigned(SetConsoleDisplayMode) then
     begin
       Result := SetConsoleDisplayMode(hOut, dwNewMode, lpdwOldMode);
     end;
   end;
 end;
 
 function GetConsoleWindow: THandle;
 var
   S: AnsiString;
   C: Char;
 begin
   Result := 0;
   Setlength(S, MAX_PATH + 1);
   if GetConsoleTitle(PChar(S), MAX_PATH) <> 0 then
   begin
     C := S[1];
     S[1] := '$';
     SetConsoleTitle(PChar(S));
     Result := FindWindow(nil, PChar(S));
     S[1] := C;
     SetConsoleTitle(PChar(S));
   end;
 end;
 
 function SetConsoleFullScreen(bFullScreen: Boolean): Boolean;
 const
   MAGIC_CONSOLE_TOGGLE = 57359;
 var
   dwOldMode: DWORD;
   dwNewMode: DWORD;
   hOut: THandle;
   hConsole: THandle;
 begin
   if Win32Platform = VER_PLATFORM_WIN32_NT then
   begin
     dwNewMode := Ord(bFullScreen);
     NT_GetConsoleDisplayMode(dwOldMode);
     hOut := GetStdHandle(STD_OUTPUT_HANDLE);
     Result := NT_SetConsoleDisplayMode(hOut, dwNewMode, dwOldMode);
   end
   else
   begin
     hConsole := GetConsoleWindow;
     Result := hConsole <> 0;
     if Result then
     begin
       if bFullScreen then
       begin
         SendMessage(GetConsoleWindow, WM_COMMAND, MAGIC_CONSOLE_TOGGLE, 0);
       end
       else
       begin
         // Better solution than keybd_event under Win9X ? 
         keybd_event(VK_MENU, MapVirtualKey(VK_MENU, 0), 0, 0);
         keybd_event(VK_RETURN, MapVirtualKey(VK_RETURN, 0), 0, 0);
         keybd_event(VK_RETURN, MapVirtualKey(VK_RETURN, 0), KEYEVENTF_KEYUP, 0);
         keybd_event(VK_MENU, MapVirtualKey(VK_MENU, 0), KEYEVENTF_KEYUP, 0);
       end;
     end;
   end;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   s: string;
 begin
   AllocConsole;
   try
     SetConsoleFullScreen(True);
     Write('Hi, you are in full screen mode now. Type something [Return]: ');
     Readln(s);
     SetConsoleFullScreen(False);
     // ShowMessage(Format('You typed: "%s"', [s])); 
   finally
     FreeConsole;
   end;
 end;
 




Как переназначить вывод в файл для консольной программы, запускаемой по CreateProcess

Автор: Кузнецов Алексей
Специально для Королевства Delphi

Я не профи в Win API, просто у меня возникла именно такая проблема. Я нашел решение устраивающее меня. И к тому же решил, поделился с вами. Если кому-то требуется что-то другое - дерзайте, я с удовольствием прочту на "Королевстве" что и как у вас получилось. Handle = Хэндл = Рукоятка :)

Хочу предложить 2 способа:

  • 1) Простой, с использованием command.com /c имя_консольной_проги > имя_файла_куда_переназначить_StdOut
  • 2) С использованием Win API (2 штуки)

Вы уж сами выберите, что вам подходит больше. Я использую способ № 2.2.

Рассмотрим их более подробно на примерах.

Способ №1


 var
   StartupInfo: TStartupInfo;
   ProcessInformation: TProcessInformation;
 begin
   GetStartupInfo(StartupInfo);
   with StartupInfo do
   begin
     wShowWindow := SW_HIDE; //не показывать окно
     dwFlags := STARTF_USESHOWWINDOW;
   end;
 
 // для примера будем запускать [c:\program files\Borland\Delphi5\Bin]grep.exe с ключом '?'
   Win32Check(CreateProcess(nil, 'command.com /c  grep.exe ? > MyStdOut.txt',
     nil, nil, FALSE, CREATE_NEW_CONSOLE, nil, nil, StartupInfo, ProcessInformation));
 
 // ждем пока наш процесс отработает
   WaitForSingleObject(ProcInfo.hProcess, INFINITE);
 
   Win32Check(CloseHandle(ProcInfo.hProcess);
 end;
 

Способ №2.1


 var
   ProcInfo: TProcessInformation;
   StartupInfo: TStartupInfo;
   hOut, hOutDup: THandle;
 begin
   // Создаем файл в который и будем переназначать StdOut
   // Например, с такими настройками, вы можете их изменить под свои нужды
   hOut := CreateFile('MyStdOut.txt', GENERIC_WRITE, 0, nil,
     CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
   if (hOut = INVALID_HANDLE_VALUE) then
     RaiseLastWin32Error;
 end;
 

А вот в этом месте и происходит все самое важное!!! Необходимо сделать рукоятку нашего файла НАСЛЕДУЕМОЙ, что и делаем…

  Win32Check(DuplicateHandle(GetCurrentProcess, hOut,
    GetCurrentProcess, @hOutDup, 0, TRUE, DUPLICATE_SAME_ACCESS));
 

Небольшое замечание: следует отметить, что если вы пишите прогу ТОЛЬКО под NT/2000, то сделать рукоятку наследуемой можно проще:

  Win32Check(SetHandleInformation (hOut, HANDLE_FLAG_INHERIT,
    HANDLE_FLAG_INHERIT);
 

и не надо будет заводить дубликат рукоятки hOutDup


 // эта рукоятка нам уже не нужна, хотя вы можете ее
 // использовать для своих целей
 Win32Check(CloseHandle(hOut));
 
 GetStartupInfo(StartupInfo);
 with StartupInfo do
 begin
   wShowWindow := SW_HIDE; // не показывать окно
   dwFlags := dwFlags or STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
   hStdOutput := hOutDup; // присваиваем рукоятку на свой файл
 end;
 

Для примера будем запускать [c:\program files\Borland\Delphi5\Bin]grep.exe с ключом '?' Вызов CreateProcess с флагом bInheritHandles = TRUE !!!


 Win32Check(CreateProcess(nil, 'grep.exe ?', nil, nil, TRUE,
   CREATE_NEW_CONSOLE, nil, nil, StartupInfo, ProcInfo));
 
 // ждем пока наш процесс отработает
 WaitForSingleObject(ProcInfo.hProcess, INFINITE);
 
 Win32Check(CloseHandle(ProcInfo.hProcess));
 
 // если вы больше ничего не хотите делать с файлом, в который
 // перенаправили StdOut, то закроем его
 Win32Check(CloseHandle(hOutDup));
 end;
 
 

Способ №2.2

Этот способ мне показал Юрий Зотов (поместив его в разделе "Обсуждение статьи"), спасибо. Оказывается, рукоятку гораздо проще сделать наследуемой, если использовать SECURITY_ATTRIBUTES.


 var
   ProcInfo: TProcessInformation;
   StartupInfo: TStartupInfo;
   SecAtrtrs: TSecurityAttributes;
   hOut: THandle;
 begin
   with SecAtrtrs do
   begin
     nLength := SizeOf(TSecurityAttributes);
     lpSecurityDescriptor := nil;
     bInheritHandle := true; // ВОТ ОНО !!! Наша рукоятка будет НАСЛЕДУЕМОЙ
   end;
 
   // Создаем файл в который и будем переназначать StdOut
   // Например, с такими настройками, вы можете их изменить под свои нужды
   hOut := CreateFile('MyStdOut.txt', GENERIC_WRITE, 0, @SecAtrtrs,
     CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
   if (hOut = INVALID_HANDLE_VALUE) then
     RaiseLastWin32Error;
 
   GetStartupInfo(StartupInfo);
   with StartupInfo do
   begin
     wShowWindow := SW_HIDE; // не показывать окно
     dwFlags := dwFlags or STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
     hStdOutput := hOutDup; // присваиваем рукоятку на свой файл
   end;
 
   // для примера будем запускать
   // [c:\program files\Borland\Delphi5\Bin]grep.exe с ключом '?'
   // Вызов CreateProcess с флагом bInheritHandles = TRUE !!!
   Win32Check(CreateProcess(nil, 'grep.exe ?', nil, nil, TRUE,
     CREATE_NEW_CONSOLE, nil, nil, StartupInfo, ProcInfo));
 
   // ждем пока наш процесс отработает
   WaitForSingleObject(ProcInfo.hProcess, INFINITE);
 
   Win32Check(CloseHandle(ProcInfo.hProcess));
 
   // если вы больше ничего не хотите делать с файлом, в который
   // перенаправили StdOut, то закроем его
   Win32Check(CloseHandle(hOut));
 end;
 
 

Заключение

Первый способ проверялся мной под Win98 и Win2k Pro. Второй (обе разновидности) только под Win2k Pro.

Оба способа служат одной и той же цели, но во втором случае программист получает больше контроля над ситуацией. Вызовы Win32Check и RaiseLastWin32Error добавляйте (убирайте) по своему вкусу.

Кстати, кто хочет узнать на эту тему больше - откройте Win32.hlp (поставляется вместе с Делфой) и на закладке "Предметный указатель" наберите "Creating a Child Process with Redirected Input and Output", "Inheritance" и "SECURITY_ATTRIBUTES" и ВНИМАТЕЛЬНО изучите. Изучив эти (и смежные) разделы вы сможете переназначить StdOut, StdIn и StdErr куда вам захочется.




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

Автор: Nomadic

Нищий на улице обращяется к Интернетчику:
- Гражданин, подайте на пропитание.
- А y тебя HTTPS есть?
- Нет.
- Тогда не дам, опасно.

Все процессы получают сигналы CTRL_CLOSE_EVENT, CTRL_LOGOFF_EVENT и CTRL_SHUTDOWN_EVENT. А делается это (грубо говоря :) так:

BOOL Ctrl_Handler( DWORD Ctrl )
 {
   if( (Ctrl == CTRL_SHUTDOWN_EVENT) || (Ctrl == CTRL_LOGOFF_EVENT) )
   {
     // Вау! Юзер обламывает!
   }
   else
   {
     // Тут что-от другое можно творить. А можно и не творить :-)
   }
   return TRUE;
 }

 function Ctrl_Handler(Ctrl: Longint): LongBool;
 begin
   if Ctrl in [CTRL_SHUTDOWN_EVENT, CTRL_LOGOFF_EVENT] then
   begin
     // Вау, вау
   end
   else
   begin
     // Am I creator?
   end;
   Result := true;
 end;
 

А где-то в программе:


 SetConsoleCtrlHandler( Ctrl_Handler, TRUE );
 

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

Короче, смотри описание SetConsoleCtrlHandler -- там всё есть.




Как сделать, чтобы в DBGrid вместо цифр были соответствующие константы


Ламер к юзеру пришел, и спросил наш ламер:
"Что такой дисковод, и что такое сканер?"
Юзер голову поднял и ответил ясно:
"Шел бы ты куда подальше, идиот несчастный!"


 procedure TForm1.Grid1DrawColumnCell(Sender: TObject; const Rect: TRect;
           DataCol: Integer; Column: TColumn; State: TGridDrawState);
 begin
   // ВАЖНО: имя поля большими буквами!
   if Column.Field.FieldName = 'PLATEZH' then
   begin
     Grid1.Canvas.FillRect(Rect);
     if Column.Field.AsInteger = 0 then
       Grid1.Canvas.TextOut(Rect.Left + 1, Rect.Top + 2, 'наличными')
     else
       Grid1.Canvas.TextOut(Rect.Left + 1, Rect.Top + 2, 'безнал');
   end;
 end;
 




Что я получаю от наличия ConstraintBroker

Автор: Nomadic

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




Как ограничить длину текста, вводимого в TEdit, так чтобы ширина текста не превышала ширину TEditа

Windows CE + Windows ME + Windows NT = Windows CEMENT.

В примере приведено два способа ограничить длинну текста в TEdit так чтобы она не превышала ширину клиентской области окна TEdit'а и не появлялась прокрутка текста. Первый способ устанавливает свойство TEdit'а MaxLength равным числу букв "W", которые поместятся в TEdit. "W" выбрана потому, что является, наверное, самой широкой буквой в любом шрифте. Этот метод сносно работает для шрифтов с фиксированной шириной букв, но для шрифтов с переменной шириной букв вряд ли сгодится. Второй способ перхватывает событие KeyPress TEdit'а и измеряет ширину уже введенного текста и ширину нового символа. Если ширина больше чем клиентская область TEdit'а новый символ отбрасывается и вызывается MessageBeep.


 procedure TForm1.FormCreate(Sender: TObject);
 var
   cRect: TRect;
   bm: TBitmap;
   s: string;
 begin
   Windows.GetClientRect(Edit1.Handle, cRect);
   bm := TBitmap.Create;
   bm.Width := cRect.Right;
   bm.Height := cRect.Bottom;
   bm.Canvas.Font := Edit1.Font;
   s := 'W';
   while bm.Canvas.TextWidth(s) < CRect.Right do
     s := s + 'W';
   if length(s) > 1 then
   begin
     Delete(s, 1, 1);
     Edit1.MaxLength := Length(s);
   end;
 end;
 
 {Другой вариант}
 procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
 var
   cRect: TRect;
   bm: TBitmap;
 begin
   if ((Ord(Key) VK_TAB) and (Ord(Key) VK_RETURN) and
      (Ord(Key) VK_LEFT) and (Ord(Key) VK_BACK)) then
   begin
     Windows.GetClientRect(Edit1.Handle, cRect);
     bm := TBitmap.Create;
     bm.Width := cRect.Right;
     bm.Height := cRect.Bottom;
     bm.Canvas.Font := Edit1.Font;
     if bm.Canvas.TextWidth(Edit1.Text + Key) > CRect.Right then
     begin
       Key := #0;
       MessageBeep(-1);
     end;
     bm.Free;
   end;
 end;
 




Ограничение размеров окна


 private
   { Private declarations }
   procedure WMGetMinMaxInfo(var Info: TWMGetMinMaxInfo); message wm_GetMinMaxInfo;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.WMGetMinMaxInfo(var Info:TWMGetMinMaxInfo);
 begin
   with Info.MinMaxInfo^ do
   begin
       ptMinTrackSize.x := 200;
       ptMinTrackSize.y := 100;
       ptMaxTrackSize.x := 300;
       ptMaxTrackSize.y := 200;
       ptMaxPosition.x := BoundsRect.Left;
       ptMaxPosition.y := BoundsRect.top;
   end;
   inherited;
 end;
 




Контролы в WinXP выглядят как в WinXP

Наверняка, если ты кодишь на Delphi и твоя ось на данный момент это Windows XP ты заметил что твои проги после компиляции не выглядят по XP'шному, т.е. все кнопки и другие элементы программы остались такими же как и в прошлых Виндах (Win98,2000 и т.д.)... 

Чтобы исправить эту проблему и продолжить нормально кодить под Win XP делаем следущее: 

1) Создаем файл (например mainfest.txt) со следующим содержимым и сохраняем его: 


<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0">
<assemblyIdentity
name="Microsoft.Windows.ApplicationName"
processorArchitecture="x86"
version="1.0.0.0"
type="win32"/>
<description>ApplicationDescription</description>
<dependency>
<dependentAssembly>
<assemblyIdentity
type="win32"
name="Microsoft.Windows.Common-Controls"
version="6.0.0.0"
processorArchitecture="x86"
publicKeyToken="6595b64144ccf1df"
language="*"
/>
</dependentAssembly>
</dependency>
</assembly>

2)Создаем еще один файл , в нем пишем:


1 24 [путь к файлу]/manifest.txt и сохранем его в папку ../Delphi/Bin/ с именем resfile.rc 

3)Запускаем файл ../Delphi/Bin/brcc32.exe resfile.rc 

4)После всех этих действий в папке ../Delphi/Bin/ появится файлик с именем resfile.res 
его нужно прописать в разделе implementation вашего приложения... 
Т.е. после implementation пишется следущее: 


 {$R resfile.res}
 

Вот и всё! Теперь можно смело сказать что ваша прога заточена под Windows XP ;) 




Использование клавиш для управления компонентами

Автор: Robert Wittig

Все, что написано на клаве
Ведет к погибели иль славе...

Так, если у меня есть своего рода кнопка (check, radio, speed и т.п.), то почему я не могу с помощью клавиш курсора управлять ею?

После некоторых экспериметов я создал метод, который привожу ниже, способный перехватывать в форме все нажатые клавиши позиционирования и управлять ими выбранным в настоящий момент элементом управления. Имейте в виду, что элементы управления (кроме компонентов Label) должны иметь возможность "выбираться". Для возможности выбрать GroupBox или другой компонент, удедитесь, что их свойство TabStop установлено в True. Вы можете переместить управление на GroupBox, но, так как он не выделяется целиком, узнать, что он действительно имеет управление, достаточно непросто. Если вам не нужно передавать управление в контейнерные элементы (нижеследующий код исходит из этого предположения), то вы можете управлять элементами, просто перемещая управление в сам GroupBox.

В нижеследующем коде FormActivate является обработчиком события формы OnActivate, тогда как ProcessFormMessages никакого отношения к событиям формы не имеет. Не забудьте поместить объявление процедуры ProcessFormMessages в секцию 'Private' класса вашей формы.

Надеюсь, что вам помог.


 procedure TForm1.FormActivate(Sender: TObject);
 begin
   { Делаем ссылку на нового обработчика сообщений }
   Application.OnMessage := ProcessFormMessages;
 end;
 
 procedure tForm1.ProcessFormMessages(var Msg: tMsg;
   var Handled: Boolean);
 var
   Increment: Byte;
   TheControl: tWinControl;
 begin
   { проверка наличия системного сообщения KeyDown }
   case Msg.Message of
     WM_KEYDOWN: if Msg.wParam in [VK_UP, VK_DOWN, VK_LEFT, VK_RIGHT] then
       begin
         { изменяем величину приращения взависимости
         от состояния клавиши Shift }
         if GetKeyState(VK_SHIFT) and $80 = 0 then
           Increment := 8
         else
           Increment := 1;
 
         { Этот код перемещает управление на родительский
         GroupBox, если один из его контейнерных элементов
         получает фокус. Если вам необходимо управлять
         элементами внутри контейнера, удалите блок IF и
         измените в блоке CASE TheControl на ActiveControl }
 
         if (ActiveControl.Parent is tGroupBox) then
           TheControl := ActiveControl.Parent
         else
           TheControl := ActiveControl;
 
         case Msg.wParam of
           VK_UP: TheControl.Top := TheControl.Top - Increment;
           VK_DOWN: TheControl.Top := TheControl.Top + Increment;
           VK_LEFT: TheControl.Left := TheControl.Left - Increment;
           VK_RIGHT: TheControl.Left := TheControl.Left + Increment;
         end;
 
         { сообщаем о том, что сообщение обработано }
         Handled := True;
       end;
   end;
 end;
 




Контролировать Excel, используя OLE


 uses
   ComObj;
 
 var
   ExcelApp: OleVariant;
 
 implementation
 
 
 procedure TForm1.Button1Click(Sender: TObject);
 const
   // SheetType 
   xlChart = -4109;
   xlWorksheet = -4167;
   // WBATemplate 
   xlWBATWorksheet = -4167;
   xlWBATChart = -4109;
   // Page Setup 
   xlPortrait = 1;
   xlLandscape = 2;
   xlPaperA4 = 9;
   // Format Cells 
   xlBottom = -4107;
   xlLeft = -4131;
   xlRight = -4152;
   xlTop = -4160;
   // Text Alignment 
   xlHAlignCenter = -4108;
   xlVAlignCenter = -4108;
   // Cell Borders 
   xlThick = 4;
   xlThin = 2;
 var
   ColumnRange: OleVariant;
 
   // Function to get the number of Rows in a Certain column 
   function GetLastLine(AColumn: Integer): Integer;
   const
     xlUp = 3;
   begin
     Result := OLEConTainer1.OleObject.Range[Char(96 + AColumn) +
       IntToStr(65536)].end[xlUp].Rows.Row;
   end;
 
 begin
   { Start Excel }
 
   // By using GetActiveOleObject, you use an instance o
   // f Word that's already running, 
   // if there is one. 
   try
     ExcelApp := GetActiveOleObject('Excel.Application');
   except
     try
       // If no instance of Word is running, try to Create a new Excel Object 
       ExcelApp := CreateOleObject('Excel.Application');
     except
       ShowMessage('Cannot start Excel/Excel not installed ?');
       Exit;
     end;
   end;
 
   // Add a new Workbook, Neue Arbeitsmappe offnen 
   ExcelApp.Workbooks.Add(xlWBatWorkSheet);
 
   // Open a Workbook, Arbeitsmappe offnen 
   ExcelApp.Workbooks.Open('c:\YourFileName.xls');
 
 
   // Rename the active Sheet 
   ExcelApp.ActiveSheet.Name := 'This is Sheet 1';
 
   // Rename 
   ExcelApp.Workbooks[1].WorkSheets[1].Name := 'This is Sheet 1';
 
   // Insert some Text in some Cells[Row,Col] 
   ExcelApp.Cells[1, 1].Value := 'SwissDelphiCenter.ch';
   ExcelApp.Cells[2, 1].Value := 'http://www.swissdelphicenter.ch';
   ExcelApp.Cells[3, 1].Value := FormatDateTime('dd-mmm-yyyy', Now);
 
   // Setting a row of data with one call 
   ExcelApp.Range['A2', 'D2'].Value := VarArrayOf([1, 10, 100, 1000]);
 
   // Setting a formula 
   ExcelApp.Range['A11', 'A11'].Formula := '=Sum(A1:A10)';
 
   // Change Cell Alignement 
   ExcelApp.Cells[2, 1].HorizontalAlignment := xlright;
 
   // Change the Column Width. 
   ColumnRange := ExcelApp.Workbooks[1].WorkSheets[1].Columns;
   ColumnRange.Columns[1].ColumnWidth := 20;
   ColumnRange.Columns[2].ColumnWidth := 40;
 
   // Change Rowheight / Zeilenhohe andern: 
   ExcelApp.Rows[1].RowHeight := 15.75;
 
   // Merge cells, Zellen verbinden: 
   ExcelApp.Range['B3:D3'].Mergecells := True;
 
   // Apply borders to cells, Zellen umrahmen: 
   ExcelApp.Range['A14:M14'].Borders.Weight := xlThick; // Think line/ Dicke Linie 
   ExcelApp.Range['A14:M14'].Borders.Weight := xlThin;  // Thin line Dunne Linie 
 
   // Set Bold Font in cells, Fettdruck in den Zellen 
 
   ExcelApp.Range['B16:M26'].Font.Bold := True;
 
   // Set Font Size, Schriftgro?e setzen 
   ExcelApp.Range['B16:M26'].Font.Size := 12;
 
   //right-aligned Text, rechtsbundige Textausrichtung 
   ExcelApp.Cells[9, 6].HorizontalAlignment := xlright;
 
   // horizontal-aligned text, horizontale Zentrierung 
   ExcelApp.Range['B14:M26'].HorizontalAlignment := xlHAlignCenter;
 
   // left-aligned Text, vertikale Zentrierung 
   ExcelApp.Range['B14:M26'].VerticallyAlignment := xlVAlignCenter;
 
 
   { Page Setup }
 
   ExcelApp.ActiveSheet.PageSetup.Orientation := xlLandscape;
 
   // Left, Right Margin (Seitenrander) 
   ExcelApp.ActiveSheet.PageSetup.LeftMargin  := 35;
   ExcelApp.ActiveSheet.PageSetup.RightMargin := -15;
 
   // Set Footer Margin 
   ExcelApp.ActiveSheet.PageSetup.FooterMargin := ExcelApp.InchesToPoints(0);
 
   // Fit to X page(s) wide by Y tall 
   ExcelApp.ActiveSheet.PageSetup.FitToPagesWide := 1;  // Y 
   ExcelApp.ActiveSheet.PageSetup.FitToPagesTall := 3; // Y 
 
   // Zoom 
   ExcelApp.ActiveSheet.PageSetup.Zoom := 95;
 
   // Set Paper Size: 
   ExcelApp.PageSetup.PaperSize := xlPaperA4;
 
   // Show/Hide Gridlines: 
   ExcelApp.ActiveWindow.DisplayGridlines := False;
 
   // Set Black & White 
   ExcelApp.ActiveSheet.PageSetup.BlackAndWhite := False;
 
   // footers 
   ExcelApp.ActiveSheet.PageSetup.RightFooter := 'Right Footer / Rechte Fu?zeile';
   ExcelApp.ActiveSheet.PageSetup.LeftFooter  := 'Left Footer / Linke Fu?zeile';
 
   // Show Excel Version: 
   ShowMessage(Format('Excel Version %s: ', [ExcelApp.Version]));
 
   // Show Excel: 
   ExcelApp.Visible := True;
 
   // Save the Workbook 
   ExcelApp.SaveAs('c:\filename.xls');
 
   // Save the active Workbook: 
   ExcelApp.ActiveWorkBook.SaveAs('c:\filename.xls');
 
 end;
 
 procedure TForm1.FormDestroy(Sender: TObject);
 begin
   // Quit Excel 
   if not VarIsEmpty(ExcelApp) then
   begin
     ExcelApp.DisplayAlerts := False;  // Discard unsaved files.... 
     ExcelApp.Quit;
   end;
 end;
 




Изображение контрола сохранить в файл

Билл Гейтс спросил меня, наверное, уже тысячу раз:
- Хочешь сохранить изменения?
Когда же он, наконец, спросит:
- Хочешь изменить сохранения?


 procedure TForm1.GrabControl(const aControl: TControl;
  const FileName: string);
 var
   B: TBitmap;
   srcRect,dstRect: TRect;
 begin
   B:=TBitmap.Create;
   with dstRect do begin
     Left:=0;
     Top:=0;
     Right:=aControl.Width+1;
     Bottom:=aControl.Height+1;
   end;
   with srcRect do begin
     Left:=aControl.Left;
     Right:=aControl.Left+aControl.Width;
     Top:=aControl.Top;
     Bottom:=aControl.Top+aControl.Height;
   end;
 
   B.Width:=aControl.Width;
   B.Height:=aControl.Height;
 
   B.Canvas.CopyRect(dstRect,Self.Canvas,srcRect);
 
   // сохранить с палитрой 256 цветов
   B.PixelFormat:=pf8bit;
   B.SaveToFile(FileName);
 
   B.Free;
 end;
 
 ...
   GrabControl(Memo1,'memo_pic.bmp');
   GrabControl(Edit1,'edit_pic.bmp');
 




Управлять сервисом на другом компьютере в W2k


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


 uses
   Windows, Messages, SysUtils, StdCtrls, SvcMgr;
 
 var
   ssStatus: TServiceStatus;
   schSCManager, schService: SC_HANDLE ;
 
 begin
   schSCManager := OpenSCManager( PChar('Comp1'), // имя компьютера, nil - local machine
   nil, // ServicesActive database
   SC_MANAGER_ALL_ACCESS); // full access rights
 
   if schSCManager = 0 then
     exit; //Ошибка?
 
   schService := OpenService(
   schSCManager, // SCM database
   PChar('SQLServerAgent'), // посмотри имя в Services. В данном случае - MS Server Agent
   SERVICE_ALL_ACCESS);
 
   if schService = 0 then
     exit; //Ошибка?
 
   if not QueryServiceStatus(
   schService, // handle to service
   ssStatus) then // address of status information structure
     exit; //Ошибка?
 
   case ssStatus.dwCurrentState of:
     SERVICE_RUNNING: ShowMessage('Работает!');
     SERVICE_STOPPED: ShowMessage('Выключен');
     // ну и т.д.
   end;
 end;
 




Функция вычисления контрольной суммы

Один программист спрашивает у другого:
- Как ты считаешь контрольную сумму?
Второй не задумываясь:
- Я честно считаю контрольную сумму!


 //Проверка ИНН
 
 //Функция вычисления контрольной суммы
 function TForm1.KontrSumINN(n:integer;inn:string):integer;
 var
   s, i: integer;
   checksum: array [1..11] of integer;
 begin
   s:=0;
   checksum[1] :=3;
   checksum[2] :=7;
   checksum[3] :=2;
   checksum[4] :=4;
   checksum[5] :=10;
   checksum[6] :=3;
   checksum[7] :=5;
   checksum[8] :=9;
   checksum[9] :=4;
   checksum[10]:=6;
   checksum[11]:=8;
   for i:=1 to n-1 do
     s:=s+(strtoint(copy(inn,i,1))*checksum[12-n+i]);
 
   Result:=s mod 11 mod 10;
 end;
 
 //Функция проверки ИНН, если ИНН правильный возвращает TRUE
 function TForm1.INN(inn:string):boolean;
 var
   len:integer;
 begin
   len:=length(inn);
   Result:=false;
   if len = 10 then
     if strtoint(copy(inn,10,1))=KontrSumINN(10,inn) then
       Result:=true;
   if len = 11 then
     if strtoint(copy(inn,11,1))=KontrSumINN(11,inn) then
       Result:=true;
   if len = 12 then
     if strtoint(copy(inn,12,1))=KontrSumINN(12,inn) then
       Result:=true;
 end;
 
 //Пример:
 procedure TForm1.Button1Click(Sender: TObject);
 begin
 
   if Inn('5436100041') then
     label1.Caption:='ИНН Правильный!'
   else
     label1.Caption:='ИНН НЕ Правильный!';
 
 // inn('5436100041')=true;
 // inn('5436100042')=false;
 
 end;
 




Преобразуем доменное имя в IP-адрес

Развод по-инетовски: В игнор и девичий IP.

Описывается функция, которая показывает, как вычислить IP адрес компьютера в интернете по его доменному имени.

Объявляем Winsock, для использования в функции:


 function HostToIP(name: string; var Ip: string): Boolean;
 var
   wsdata : TWSAData;
   hostName : array [0..255] of char;
   hostEnt : PHostEnt;
   addr : PChar;
 begin
   WSAStartup ($0101, wsdata);
   try
     gethostname (hostName, sizeof (hostName));
     StrPCopy(hostName, name);
     hostEnt := gethostbyname (hostName);
     if Assigned (hostEnt) then
       if Assigned (hostEnt^.h_addr_list) then begin
         addr := hostEnt^.h_addr_list^;
         if Assigned (addr) then begin
           IP := Format ('%d.%d.%d.%d', [byte (addr [0]),
           byte (addr [1]), byte (addr [2]), byte (addr [3])]);
           Result := True;
         end
         else
           Result := False;
       end
       else
         Result := False
     else begin
       Result := False;
     end;
   finally
     WSACleanup;
   end
 end;
 

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


 procedure TForm1.Button1Click(Sender: TObject);
 var
   IP: string;
 begin
   if HostToIp(Edit1.Text, IP) then
     Label1.Caption := IP;
 end;
 




Преобразование цвета RGB в HLS


 { Максимальные значения }
 const
   HLSMAX = 240;
   RGBMAX = 255;
   UNDEFINED = (HLSMAX*2) div 3;
 var
   H, L, S: integer; { H-оттенок, L-яркость, S-насыщенность }
   R, G, B: integer; { цвета }
 
 procedure RGBtoHLS;
 var
   cMax, cMin: integer;
   Rdelta, Gdelta, Bdelta: single;
 begin
   cMax := max( max(R,G), B);
   cMin := min( min(R,G), B);
   L := round( ( ((cMax+cMin)*HLSMAX) + RGBMAX )/(2*RGBMAX) );
 
   if (cMax = cMin) then
   begin
     S := 0;
     H := UNDEFINED;
   end
   else
   begin
     if (L <= (HLSMAX/2)) then
       S := round( ( ((cMax-cMin)*HLSMAX) + ((cMax+cMin)/2) ) / (cMax+cMin) )
     else
       S := round( ( ((cMax-cMin)*HLSMAX) + ((2*RGBMAX-cMax-cMin)/2) )
       / (2*RGBMAX-cMax-cMin) );
     Rdelta := ( ((cMax-R)*(HLSMAX/6)) + ((cMax-cMin)/2) ) / (cMax-cMin);
     Gdelta := ( ((cMax-G)*(HLSMAX/6)) + ((cMax-cMin)/2) ) / (cMax-cMin);
     Bdelta := ( ((cMax-B)*(HLSMAX/6)) + ((cMax-cMin)/2) ) / (cMax-cMin);
     if (R = cMax) then
       H := round(Bdelta - Gdelta)
     else
     if (G = cMax) then
       H := round( (HLSMAX/3) + Rdelta - Bdelta)
     else
       H := round( ((2*HLSMAX)/3) + Gdelta - Rdelta );
     if (H < 0) then
       H:=H + HLSMAX;
     if (H > HLSMAX) then
       H:= H - HLSMAX;
   end;
   if S<0 then
     S:=0;
   if S>HLSMAX then
     S:=HLSMAX;
   if L<0 then
     L:=0;
   if L>HLSMAX then
     L:=HLSMAX;
 end;
 
 
 procedure HLStoRGB;
 var
   Magic1, Magic2: single;
 
   function HueToRGB(n1, n2, hue: single): single;
   begin
     if (hue < 0) then
       hue := hue+HLSMAX;
     if (hue > HLSMAX) then
       hue:=hue - HLSMAX;
     if (hue < (HLSMAX/6)) then
       result:= ( n1 + (((n2-n1)*hue+(HLSMAX/12))/(HLSMAX/6)) )
     else
     if (hue < (HLSMAX/2)) then
       result:=n2
     else
     if (hue < ((HLSMAX*2)/3)) then
       result:= ( n1 + (((n2-n1)*(((HLSMAX*2)/3)-hue)+(HLSMAX/12))/(HLSMAX/6)))
     else
       result:= ( n1 );
   end;
 
 begin
   if (S = 0) then
   begin
     B:=round( (L*RGBMAX)/HLSMAX );
     R:=B;
     G:=B;
   end
   else
   begin
     if (L <= (HLSMAX/2)) then
       Magic2 := (L*(HLSMAX + S) + (HLSMAX/2))/HLSMAX
     else
       Magic2 := L + S - ((L*S) + (HLSMAX/2))/HLSMAX;
     Magic1 := 2*L-Magic2;
     R := round( (HueToRGB(Magic1,Magic2,H+(HLSMAX/3))*RGBMAX + (HLSMAX/2))/HLSMAX );
     G := round( (HueToRGB(Magic1,Magic2,H)*RGBMAX + (HLSMAX/2)) / HLSMAX );
     B := round( (HueToRGB(Magic1,Magic2,H-(HLSMAX/3))*RGBMAX + (HLSMAX/2))/HLSMAX );
   end;
   if R<0 then
     R:=0;
   if R>RGBMAX then
     R:=RGBMAX;
   if G<0 then
     G:=0;
   if G>RGBMAX then
     G:=RGBMAX;
   if B<0 then
     B:=0;
   if B>RGBMAX then
     B:=RGBMAX;
 end;
 




Преобразование в EBCDIC

Автор: Matthew Augier

- Ну какой ты гад, ну какой ты гад! - сказал громко Билл Гейтс и улыбнулся своему отражению.


 Const
   a2e: array [0..255] of byte =
 
 (000,001,002,003,055,045,046,047,022,005,037,011,012,013,014,159,
 016,017,018,019,182,181,050,038,024,025,063,039,028,029,030,031,
 064,090,127,123,091,108,080,125,077,093,092,078,107,096,075,097,
 240,241,242,243,244,245,246,247,248,249,122,094,076,126,110,111,
 124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214,
 215,216,217,226,227,228,229,230,231,232,233,173,224,189,095,109,
 121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150,
 151,152,153,162,163,164,165,166,167,168,169,192,106,208,161,007,
 104,220,081,066,067,068,071,072,082,083,084,087,086,088,099,103,
 113,156,158,203,204,205,219,221,224,236,252,176,177,178,062,180,
 069,085,206,222,073,105,154,155,171,015,186,184,183,170,138,139,
 060,061,098,079,100,101,102,032,033,034,112,035,114,115,116,190,
 118,119,120,128,036,021,140,141,142,065,006,023,040,041,157,042,
 043,044,009,010,172,074,174,175,027,048,049,250,026,051,052,053,
 054,089,008,056,188,057,160,191,202,058,254,059,004,207,218,020,
 225,143,070,117,253,235,238,237,144,239,179,251,185,234,187,255);
 
 
 Procedure StringA2E(var StringToConvert:String);
 Var
   Loop: Integer;
 begin
   For Loop := 1 to length(StringToConvert) do
     StringToConvert[Loop] := a2e[ord(StringToConvert[Loop])];
 end;
 




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



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



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


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