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

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


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

БОЛЬШОЙ FAQ ПО DELPHI



Как при выполнении долгой операции в Oracle показать прогресс бар


Автор: Philip A. Milovanov

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

Ниже приведен пример, как это сделать при помощи Direct Oracle Access, надеюсь этот кусок кода несложно запустить в отдельном процессе, а в другом можно запустить перемесчатель прогресс бара. Есть готовая компонента, могу поделиться.


 //на создании потока вставим то, что будет выбирать необходимую информацию
 
 Self.fods.SQL.Text:='SELECT SOFAR FROM V$SESSION_LONGOPS WHERE CONTEXT=:FK_ID';
 Self.fods.DeclareVariable('FK_ID',otInteger);
 Self.fods.SetVariable('FK_ID',ID);
 
 //На выполнение потока вешаем открытие/закрытие TOracleDataSet
 while (Terminated = false) do
 begin
   Self.fods.Close;
   Self.fods.Open;
   Self.fpb.Progress:=Self.fods.FieldByName('SOFAR').AsInteger;
   //^^^^Эта строчка как раз и устанавливает нужный прогрессбар в нужную позицию...
 end;
 

Ну и соответсвенно перед выполнением всего этого дела необходимо выставить максимальное число (100%):


 procedure SETMaxValue(nVal in NUMBER);
 

Минимальное:


 procedure SETMinValue(nVal in NUMBER);
 

Значение шага:


 procedure SetStepValue(nValue in NUMBER);
 

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


 PROGRESS_BAR.STEPIT;
 

Код пакета PROGRESS_BAR приведен ниже:


 create or replace package PROGRESS_BAR
 is
   -- Wrote by Philip A. Milovanov
   nMaxValue NUMBER:=0;
   nMinValue NUMBER:=0;
   nCurrentValue NUMBER:=0;
   nStepValue NUMBER:=1;
   nID PLS_INTEGER;
   slno PLS_INTEGER;
   target PLS_INTEGER;
   procedure SETMaxValue(nVal in NUMBER);
   procedure SETMinValue(nVal in NUMBER);
   function INIT RETURN NUMBER;
   procedure StepIt;
   procedure SetStepValue(nValue in NUMBER);
   procedure StepIt(C in NUMBER);
 end; -- package Specification PROGRESS_BAR
 
 --Сам пакет:
 Create or Replace package Body PROGRESS_BAR
 is
   -- Wrote by Philip A. Milovanov
   procedure SETMaxValue(nVal in NUMBER) is
   begin
     if nVal<nMinValue then
       RAISE_APPLICATION_ERROR(-20001,'...:'||nMinValue||' ,...:'||nVal);
     end if;
     nMaxValue:=nVal;
   end;
 
   procedure SETMinValue(nVal in NUMBER) is
   begin
     if nVal>nMaxValue then
       RAISE_APPLICATION_ERROR(-20001,'...:'||nVal||' ,...:'||nMaxValue);
     end if;
     nMinValue:=nVal;
   end;
 
   function INIT RETURN NUMBER is
   CURSOR c is SELECT OBJECT_ID FROM ALL_OBJECTS WHERE OBJECT_NAME='PROGRESS_BAR';
   i NUMBER;
   begin
     OPEN c;
     FETCH c INTO target;
     CLOSE c;
     SELECT SEQ_TPROCESS_BAR.NEXTVAL INTO i FROM DUAL;
     nCurrentValue:=nMinValue;
     nID:=DBMS_APPLICATION_INFO.set_session_longops_nohint;
     DBMS_APPLICATION_INFO.SET_SESSION_LONGOPS(nID,slno,
     'CALCULATING REPORT',target,i,nCurrentValue,nMaxValue,'PROGRESS BAR INFO',NULL);
     RETURN i;
   end;
 
   procedure StepIt is
   begin
     nCurrentValue:=nCurrentValue+nStepValue;
     DBMS_APPLICATION_INFO.SET_SESSION_LONGOPS(nID,slno, 'CALCULATING REPORT',
     target,nMinValue,nCurrentValue,nMaxValue,'PROGRESS BAR INFO',NULL);
   end;
 
   procedure SetStepValue(nValue in NUMBER) is
   begin
     nStepValue:=nValue;
   end;
 
   procedure StepIt(C in NUMBER) is
   begin
     nCurrentValue:=nCurrentValue+c;
     DBMS_APPLICATION_INFO.SET_SESSION_LONGOPS (nID,slno,'CALCULATING REPORT',
     target,nMinValue,nCurrentValue,nMaxValue,'PROGRESS BAR INFO',NULL);
   end;
 
 end;
 
 ...
 




Создать ProgressBar в колонке TListView


 procedure TForm1.Button1Click(Sender: TObject);
 var
   r: TRect;
   pb: TProgressBar;
 begin
   Listview1.Columns.Add.Width := 100;
   Listview1.Columns.Add.Width := 200;
   Listview1.ViewStyle         := vsReport;
   Listview1.Items.Add.Caption := 'Text';
 
   r := Listview1.Items[0].DisplayRect(drBounds);
   r.Left  := r.Left + Listview1.columns[0].Width;
   r.Right := r.Left + Listview1.columns[1].Width;
 
   pb := TProgressBar.Create(Self);
   pb.Parent := Listview1;
   pb.BoundsRect := r;
   pb.Position := 30;
   Listview1.Items[0].Data := pb;
 end;
 
 
 // Change the ProgressBar Position 
 // ProgressBar Position andern 
 
 procedure TForm1.Button2Click(Sender: TObject);
 var
   pb: TProgressBar;
 begin
   pb := TProgressBar(Listview1.Items[0].Data);
   pb.StepIt;
 end;
 




Как вставить ProgressBar в StatusBar


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   with ProgressBar1 do
   begin
     Parent := StatusBar1;
     Position := 100;
     Top := 2;
     Left := 0;
     Height := StatusBar1.Height - Top;
     Width := StatusBar1.Panels[0].Width - Left;
   end;
 end;
 




Как вставить ProgressBar в StatusBar 2

  • pgProgress положить на форму как Visible := false;
  • StatusPanel надо OwnerDraw сделать и pефpешить, если Position меняется.

 procedure TMainForm.stStatusBarDrawPanel(StatusBar: TStatusBar;
 Panel: TStatusPanel; const Rect: TRect);
 begin
   if Panel.index = pnProgress then
   begin
     pgProgress.BoundsRect := Rect;
     pgProgress.PaintTo(stStatusBar.Canvas.Handle, Rect.Left, Rect.Top);
   end;
 end;
 




ProgressBar с невидимой рамкой

Автор: VS

Заказчик моего проекта обратился с просьбой - "Сделать прогресс индикатор как в приложениях Нортона. Чтоб был в статус строке и НИКАКИХ рамок". ProgressBar в StatusBar - нет проблем, но как быть с рамкой от ProgressBar? ProgressBar всегда вычерчивает рамку и не имеет методов ее управления. Однако появилась интересная идея, воплотившаяся в компонент с новым свойством ShowFrame. Решение оказалось на удивление простым. На рисунке сравнение стандартного ProgressBar и ProgressBar с невидимой рамкой.


 unit vsprgs;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
     ComCtrls;
 
 type
   TNProgressBar = class(TProgressBar)
     procedure WMNCPAINT(var Msg: TMessage); message WM_NCPAINT;
   private
     FShowFrame: boolean;
     procedure SetShowFrame(Value: boolean);
   protected
   public
     constructor Create(AOwner: TComponent); override;
   published
     property ShowFrame: boolean read FShowFrame write SetShowFrame;
   end;
 
 procedure Register;
 
 implementation
 { TNProgressBar }
 
 constructor TNProgressBar.Create(AOwner: TComponent);
 begin
   inherited;
   FShowFrame := True;
 end;
 
 procedure TNProgressBar.SetShowFrame(Value: boolean);
 begin
   if FShowFrame <> Value then
   begin
     FShowFrame := Value;
     RecreateWnd;
   end;
 end;
 
 procedure TNProgressBar.WMNCPAINT(var Msg: TMessage);
 var
   DC: HDC;
   RC: TRect;
 begin
   if ShowFrame then
   begin
     inherited;
     Invalidate;
   end
   else
   begin
     DC := GetWindowDC(Handle);
     try
       Windows.GetClientRect(Handle, RC);
       with RC do
       begin
         Inc(Right, 2);
         Inc(Bottom, 2);
       end;
       Windows.FillRect(DC, RC, Brush.Handle);
     finally
       ReleaseDC(Handle, DC);
     end;
   end;
 end;
 
 procedure Register;
 begin
   RegisterComponents('Controls', [TNProgressBar]);
 end;
 
 end.
 




Свойства в Delphi

- Ты видел, козлина, чтобы я наш apple гадостью всякой поливал?
- Урод ты, дед. У нас четвертый пень уже год стоит вместо MAC`a.
- Да, внучек, я этот пентиум на мешок с маком и выменял.

Свойства в Delphi могут быть простыми, перечислимыми, типа множество, объектными и массивами.

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


 unit OurComponent;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
 
 type
   TOurComponent = class(TComponent)
   private
     { Private declarations }
     FMyInteger: Integer;
     FMyChar: Char;
     FMyString: string;
     procedure SetMyInteger(const Value: Integer);
     procedure SetMyChar(const Value: Char);
     procedure SetMyString(const Value: string);
   protected
     { Protected declarations }
   public
     { Public declarations }
   published
     { Published declarations }
     property MyInteger: Integer read FMyInteger write SetMyInteger;
     property MyChar: Char read FMyChar write SetMyChar;
     property MyString: string read FMyString write SetMyString;
 end;
 
 procedure register;
 
 implementation
 
 procedure register;
 begin
   RegisterComponents('Samples', [TOurComponent]);
 end;
 
 { TOurComponent }
 
 procedure TOurComponent.SetMyChar(const Value: Char);
 begin
   FMyChar := Value;
 end;
 
 procedure TOurComponent.SetMyInteger(const Value: Integer);
 begin
   FMyInteger := Value;
 end;
 
 procedure TOurComponent.SetMyString(const Value: string);
 begin
   FMyString := Value;
 end;
 
 end.
 

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


 unit OurComponent;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics,
   Controls, Forms, Dialogs;
 
 type
   TMyEnumerate = (meFirst, meSecond, meThird);
 
   TOurComponent = class(TComponent)
   private
     { Private declarations }
     FMyBoolean: Boolean;
     FMyCursor: TCursor;
     FMyEnumerate: TMyEnumerate;
     procedure SetMyCursor(const Value: TCursor);
     procedure SetMyBoolean(const Value: Boolean);
     procedure SetMyEnumerate(const Value: TMyEnumerate);
   protected
     { Protected declarations }
   public
     { Public declarations }
   published
     { Published declarations }
     property MyCursor: TCursor read FMyCursor write SetMyCursor;
     property MyBoolean: Boolean read FMyBoolean write SetMyBoolean;
     property MyEnumerate: TMyEnumerate read FMyEnumerate write
     SetMyEnumerate;
 end;
 
 procedure register;
 
 implementation
 
 procedure register;
 begin
   RegisterComponents('Samples', [TOurComponent]);
 end;
 
 { TOurComponent }
 
 procedure TOurComponent.SetMyCursor(const Value: TCursor);
 begin
   FMyCursor := Value;
 end;
 
 procedure TOurComponent.SetMyEnumerate(const Value: TMyEnumerate);
 begin
   FMyEnumerate := Value;
 end;
 
 procedure TOurComponent.SetMyBoolean(const Value: Boolean);
 begin
   FMyBoolean := Value;
 end;
 
 end.
 

Свойства типа множество - это стандандартные, а также определенные пользователем, множества. В инспекторе объектов для них редакторы свойств имеют знак [+] перед названием свойства.

Размер публикуемых (published) свойств ограничен 32 элементами. Если вам необходимо свойство с более чем 32 элементами - объявите свое свойство публичным (public).


 unit OurComponent;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics,
   Controls, Forms, Dialogs;
 
 type
   TMySet = (msOne, msTwo, msThee, msFour, msFive);
   TMySets = set of TMySet;
 
   TOurComponent = class(TComponent)
   private
     { Private declarations }
     FMySet: TMySets;
     procedure SetMySet(const Value: TMySets);
   protected
     { Protected declarations }
   public
     { Public declarations }
   published
     { Published declarations }
     property MySet: TMySets read FMySet write SetMySet;
 end;
 
 procedure register;
 
 implementation
 
 procedure register;
 begin
   RegisterComponents('Samples', [TOurComponent]);
 end;
 
 { TOurComponent }
 
 procedure TOurComponent.SetMySet(const Value: TMySets);
 begin
   FMySet := Value;
 end;
 
 end.
 

Объектные свойства - это стандартные (TFont, TCanvas и т.п.) или определенные пользователем объекты, как правило наследники TPersistent. В инспекторе объектов для них редакторы свойств имеют знак [+] перед названием свойства и кнопку с тремя точками [...](пользовательский редактор свойства).


 unit OurComponent;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls,
   Forms, Dialogs;
 
 type
 
   TOurComponent = class(TComponent)
   private
     { Private declarations }
     FMyFont: TFont;
     procedure SetMyFont(const Value: TFont);
   protected
     { Protected declarations }
   public
     { Public declarations }
     constructor Create(AOwner: TComponent); override;
     destructor Destroy; override;
   published
     { Published declarations }
     property MyFont: TFont read FMyFont write SetMyFont;
 end;
 
 procedure register;
 
 implementation
 
 procedure register;
 begin
   RegisterComponents('Samples', [TOurComponent]);
 end;
 
 { TOurComponent }
 
 constructor TOurComponent.Create(AOwner: TComponent);
 begin
   inherited Create(AOwner);
   {В отличие от предыдущих свойств, объекты обязательно
   необходимо создавать в конструкторе компонента, как
   правило после вызова унаследованного конструктора}
   FMyFont.Create;
 end;
 
 destructor TOurComponent.Destroy;
 begin
   FMyFont.Free;
   {В отличие от предыдущих свойств, объекты обязательно
   необходимо разрушать в деструкторе компонента, как
   правило перед вызовом унаследованного деструктора}
   inherited Destroy;
 end;
 
 procedure TOurComponent.SetMyFont(const Value: TFont);
 begin
   {Объектному свойству значение присваивается с
   помощью вызова метода Assign}
   FMyFont.Assign(Value);
 end;
 
 end.
 

На заметку:

Перемещение между объявлением метода и реализацией происходит по нажатию клавиш Ctrl + Shift + стрелки вверх/вниз.

Свойства типа масив - обычные массива Object Pascal, но в отличии от последних могут индексироваться не только числовыми значениями но и строковыми. К сожалению этот тип свойства требует пользовательского редактора свойств (в инспекторе объектов редактор свойства имеет кнопку с тремя точками [...]), по-этому в указанном ниже примере свойство ArrayProp объявлено в секции public.


 type
   TOurComponent = class(TComponent)
   private
     { Private declarations }
     FArrayProp: array[0..9] of integer;
     function GetArrayProp(aIndex: integer): integer;
     procedure SetArrayProp(aIndex: integer; const Value: integer);
   protected
     { Protected declarations }
   public
     { Public declarations }
     property ArrayProp[aIndex: integer]: integer read GetArrayProp
     write SetArrayProp;
   published
     { Published declarations }
 end;
 

Спецификаторы свойств

Спецификатор default указывает сохранять значение свойства в файле формы или нет. Если значение свойства совпадает со значением default - значение в файле формы не сохраняется, если значения не равны - сохраняется. Это можно проверить, положив компонент на форму и выбрать правой кнопкой мыши пункт меню "View as Text". Default не устанавливает первоначальное значение свойства к указанному. Это необходимо сделать в конструкторе компонента.


 unit OurComponent;
 
 interface
 
 uses
   Windows, SysUtils, Classes, Graphics, Forms, Controls;
 
 type
   TOurComponent = class(TComponent)
   private
     { Private declarations }
     FMyInteger: Integer;
   protected
     { Protected declarations }
   public
     { Public declarations }
     constructor Create(AOwner: TComponent); override;
   published
     { Published declarations }
     property MyInteger: Integer read FMyInteger write FMyInteger default 10;
 end;
 
 implementation
 
 constructor TOurComponent.Create(AOwner: TComponent);
 begin
   inherited Create(AOwner);
   FInteger := 10;
 end;
 
 end.
 

Спецификатор nodefault отменяет заданное по умолчанию значение свойства. Этот спецификатор, как правило, используется для отмены заданого по умолчанию значения унаследованного свойства. Например: property AutoSize nodefault; Спецификатор stored указывает когда сохранять в файле формы значение свойства. После stored может стоять true (всегда сохранять), false (никогда не сохранять) или название функции, которая возвращает логический результат.


 property OneProp: integer read FOneProp write SetOneProp stored False;
 property TwoProp: integer read FTwoProp write SetTwoProp stored True;
 property ThreeProp: integer read FThreeProp write SetThreeProp stored Fuct;
 

Спецификатор index мы разберем в следующем выпуске, когда будем говорить о методах доступа к значению свойства. На заметку: Выделять прямоугольный фрагмент текста в редакторе исходного кода можно с помощью комбинации клавиш Alt + Shift + стрелки вверх/вниз.




Создание свойства-массива компонентов

Автор: Mike Scott

У меня есть форма, на которой имеется около 20 компонентов CheckBox, и я хотел бы поочередно ссылаться на них как на элементы массива...

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

Здесь я приведу два способа "собирания" CheckBox в одном массиве. Один просто собирает все CheckBox на форме. Это простой список, но вы должны убедиться в том, что порядок размещения в нем компонентов такой, каким вы хотите его видеть в массиве. Это нормально в данном случае. Другой способ перечисляет все компоненты согласно их нумерации, заложенной в их имени, но чтобы им воспользоваться, его необходимо раскоментарить. Существует множество других способов. Пусть данный совет послужит вам отправной точкой в изучении интересного вопроса оптимизации кода.


 type
   TForm1 = class(TForm)
     procedure FormCreate(Sender: TObject);
     procedure FormDestroy(Sender: TObject);
   private
     FCheckboxes: TList;
     function GetCheckbox(Index: integer): TCheckbox;
   public
     property Checkboxes[Index: integer]: TCheckbox read GetCheckbox;
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.FormCreate(Sender: TObject);
 var
   i: integer;
   AComponent: TComponent;
 begin
   FCheckboxes := TList.Create;
 
   { ТАКЖЕ: это собирает все CheckBox в порядке очередности }
   for i := 0 to ComponentCount - 1 do
     if Components[i] is TCheckbox then
       FCheckboxes.Add(Components[i]);
 
   { ИЛИ: если они имеют имя CheckboxNN и вы хотите
   разместить их в массиве в том же порядке... }
   {for i := 1 to MaxInt do begin
   AComponent := FindComponent( 'Checkbox' + IntToStr( i ) ) ;
   if AComponent = NIL then break ;
   FCheckboxes.Add( AComponent ) ;
   end ;}
 end;
 
 procedure TForm1.FormDestroy(Sender: TObject);
 begin
   FCheckboxes.Free;
 end;
 
 function TForm1.GetCheckbox(Index: integer): TCheckbox;
 begin
   Result := TCheckbox(FCheckboxes[Index]);
 end;
 




Редактор свойства Color с заданными ограничениями

Автор: Ed Jordan

Редактор свойства, пример которого приведен ниже, имеет ограничение на устанавливаемые цвета: только clRed, clWhite или clBlue.


 unit ClrComps;
 
 interface
 
 uses
   SysUtils, WinTypes, WinProcs, Messages, Classes,
   Graphics, Controls, Forms, Dialogs, DsgnIntf;
 
 type
   TColorComponent = class(TComponent)
   private
     FColor: TColor;
   protected
     procedure SetColor(Value: TColor);
   public
     constructor Create(AnOwner: TComponent); override;
   published
     property Color: TColor read FColor write SetColor;
   end;
 
   { Это специальный редактор свойства выбора цветов... }
   TMyColorProperty = class(TIntegerProperty)
   public
     function GetAttributes: TPropertyAttributes; override;
     function GetValue: string; override;
     procedure GetValues(Proc: TGetStrProc); override;
     procedure SetValue(const Value: string); override;
   end;
 
 procedure Register;
 
 implementation
 
 { TMyColorProperty }
 
 function TMyColorProperty.GetAttributes: TPropertyAttributes;
 begin
   Result := [paMultiSelect, paValueList];
 end;
 
 function TMyColorProperty.GetValue: string;
 begin
   Result := ColorToString(TColor(GetOrdValue));
 end;
 
 procedure TMyColorProperty.GetValues(Proc: TGetStrProc);
 begin
   Proc('clRed');
   Proc('clWhite');
   Proc('clBlue');
 end;
 
 procedure TMyColorProperty.SetValue(const Value: string);
 var
   NewValue: Longint;
 begin
   if IdentToColor(Value, NewValue) and
     ((NewValue = clRed) or
     (NewValue = clWhite) or
     (NewValue = clBlue)) then
     SetOrdValue(NewValue);
 end;
 
 { Образец компонента... }
 
 constructor TColorComponent.Create(AnOwner: TComponent);
 begin
   inherited Create(AnOwner);
   FColor := clRed;
 end;
 
 procedure TColorComponent.SetColor(Value: TColor);
 begin
   if (Value = clRed) or
     (Value = clWhite) or
     (Value = clBlue) then
   begin
     FColor := Value;
   end;
 end;
 
 procedure Register;
 begin
   RegisterComponents('Samples', [TColorComponent]);
   RegisterPropertyEditor(TypeInfo(TColor), TColorComponent,
     'Color', TMyColorProperty);
 end;
 
 end.
 




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

- Убирать за собой надо... - раздраженно сказал программист, удаляя папку `mssetup.t


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




Защита программ от взлома


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

Эта статья посвящена достаточно актуальной в настоящее время тематике - защите программ от взлома и нелегального копирования. Этой теме посвящено много статей, одна из наиболее интересных (из тех, которые попались мне) - статья "Защита shareware-программ" Владимира Каталова в Компьютерре Online#240. Он привел ряд советов по написанию shareware программ и я не хочу повторяться - сходите, почитайте.

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

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

Отладчики.
Позволяют прерывать выполнение программы при достижении заранее заданных условий, производить пошаговое выполнение программы, изменять содержимое памяти и регистров и т.п. . Наиболее популярным, удобным и мощным является отладчик SoftICE, который при достаточно примитивном интерфейсе обладает приличными возможностями и весьма стабильно работает.
Дизассемблеры.
Производят дизассемблирование программы для дальнейшего изучения полученного кода. Один из наиболее популярных - IDA. От дизассемблера достаточно легко защититься - зашифровать или заархивировать программу. Тогда дизассемблируется только архиватор или кодировщик.
Средства мониторинга.
Это набор утилит, отслеживающих операции с файлами, реестром, портами и сетью.
Средства пассивного анализа программы.
Показывают разную информацию о программе - извлекают ресурсы, показывают связи, используемые библиотеки. Классический пример - утилита DEPENDS.EXE из комплекта Visual Studio. Она показывает, какие библиотеки используются программой и какие функции импортируются.
Прочие утилиты.
Их великое множество (можно найти на диске типа "Все для хакера", причем в изобилии). Это разнообразные редакторы, анализаторы ...

Наиболее популярны следующие программы мониторинга :

  • FileMon - утилита, позволяющая вести мониторинг всех операций с файлами. Имеет удобный фильтр, может сохранять отчет в файле. Поэтому нет смысла делать "секретные" файлы где-нибудь в Windows/System - их элементарно найти.
  • RegMon - аналог FileMon, только ведется мониторинг всех операций с реестром. Аналогично файлам, бессмысленно создавать в реестре "секретные" ключи - они сразу бросаются в глаза.
  • PortMon - мониторинг работы с портами ввода/вывода
  • TCP_VIEW - монитор соединений по TCP-IP
  • RegUtils - набор утилит для контроля за реестром - делает копии реестра, позволяет сравнивать копии и просматривать изменения.

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

Основы построения защиты - шаг за шагом

Как ввести регистрационный код. Ввод пароля или регистрационного номера является ответственным делом - хакер постарается отловить адрес памяти, в который будет записан пароль. Затем на обращение по этому адресу ставится точка останова (команда BPM в SoftICE), что позволяет поймать начало процедуры проверки регистрационного кода. Если для ввода используются стандартные элементы ввода Windows, то алгоритм действий хакера можно формализовать и выглядит он примерно так:

  1. Устанавливает точку останова на считывание текста из стандартного элемента ввода (функции GetWindowText, GetGlgItemText модуля KERNEL32)
  2. При вызове этой функции анализируем ее параметры и таким образом определяем, по какому адресу будет размещено считываемое значение и ставим обращение к этой области памяти точку останова. А достоверности определенного адреса легко убедиться - после выполнения функции там появится введенная строка
  3. При срабатывании этой точки останова мы попадаем в анализатор введенного значения и либо делаем генератор регистрационных ключей, либо ломаем процедуру проверки. И то, и другое весьма просто сделать - достаточно только изучить ассемблер и API

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

Рассмотри несколько решений, которые могут затруднить взлом на этом этапе.

  • Старайтесь как можно меньше применять стандартные функции (особенно API-шные) и компоненты VCL. Так что Assembler, Assembler и еще раз Assembler ... Сущность этого совета надеюсь очевидна - современные дизассемблеры умеют распознавать стандартные процедуры высокоуровневых языков, а API - вообще отдельный разговор - SoftICE обладает изумительной возможностью - загружать символьные имена для любых указанных библиотек (особенно для KERNEL32.DLL) - отладка резко упрощается, т.к. мы видим имена вызываемых функций и можем ставить точки останова на вызов функций по их имени.
  • Применяйте нестандартный способ ввода пароля. Наипростейший путь - написать свой визуальный компонент для ввода регистрационного кода. Он конечно должен будет обрабатывать события от клавиатуры, но момент считывания кода нельзя поймать избитыми методами. Это уже что-то, но есть второй способ взлома, основанный на поиске введенного кода в памяти. Для этого в SoftICE есть удобная команда "S стартовый адрес L длина 'образец'" , которая позволяет найти введенное значение в памяти.
  • Не храните введенный код в одном месте !
  • Не храните введенный код открытым текстом ! Итак, что же следует сделать. Для начала необходимо завести в программе 5-10 переменных типа STRING и после ввода кода переписать введенное значение в них. Делать это лучше всего не в одном месте, а распределить по программе. Таким образом поиск даст кучу адресов, по которым будет находиться введенный код. Я в таком случае поступаю так - по таймеру создаю в динамической памяти новую строковую переменную, пишу в нее код. Затем на следующем срабатывании таймера создаю новую переменную, переписываю в нее код, а старую уничтожаю. При определенном навыке можно заполонить память значениями введенного кода и сделать поиск почти бесполезным. Причем такое копирование можно совместить с проверкой кода или эмуляцией этой проверки. Затем с эти строками неплохо поделать какие-либо операции - сравнить с чем-нибудь ... Советы 3 и 1 можно объединить - создать свой компонент, который позволит вводить код нестандартным способом с его одновременной шифровкой. Анализ регистрационного кода. Итак, код введен и приняты меры для того, чтобы его было непросто найти (хотя найти то его можно, но это время, навык ...). Теперь следующий шаг - анализ. Поэтому сразу совет:
  • Ни в коем случае не анализируйте код сразу после его ввода. Чем дальше ввод кода от его анализа, тем лучше. Самое разумное - после ввода кода поблагодарить пользователя за сотрудничество и сообщить, что со временем будет выполнена регистрация программы. А анализ кода произвести, например, через 1-2 минуты в совершенно другом месте программы.
  • Не проверяйте код только в одном месте и не пишите для проверки функцию. Достаточно найти и отключить эту проверку, и защита взломана. Если проверок несколько, они разные и распределены по программе, то взлом затрудняется.
  • Не проверяйте пароль одним алгоритмом. Рекомендуется разработать 2-3 алгоритма проверки, например 1-2 цифры должны делиться на 3, а 3-7 наложенные по какому-либо алгоритму на имя пользователя должны дать в сумме 4. Эти две проверки осуществляем в различных местах с достаточно большим временным разносом - взломав первый метод хакер не будет догадываться о существовании еще нескольких, которые проявятся со временем.
  • Ни в коем случае не предпринимайте никаких действий после проверки. По неизвестной причине большинство программ выглядят примерно так

 if not(SuperRegCodeCheck) then
 begin
   ShowMessage('Неверный код, дальнейшая работа невозможна');
   halt;
 end;
 

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

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

 if not(LegalCopy) then
   ShowMessage('Сохранение работает только в зарегистрированной версии')
 else
   SaveFile;
 

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


 MOV [адрес LegalCopy], 1
 RET
 

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

Типичная ошибка - выяснили, что копия зарегистрирована и сделали где-нибудь метку. Отловить это достаточно просто (см. описание REGMON и FILEMON). Наилучший способ - сохранить пароль и имя пользователя в том виде, в котором он их ввел. Затем при каждом запуске программы проверять корректность этого кода, но не забывая Совет _11. Ничего не проверяйте сразу при запуске приложения или сразу после считывания сохраненного имени или кода. Помните, что считывание кода и его ввод в окне регистрации идентичны по мерам защиты - дублирование в разных областях памяти, шифрование ...

Выводы:

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

Общие советы по защите программ

  • CRC - контрольные суммы. Любой файл, строку или блок данных можно защитить контрольной суммой, которую затем можно рассчитать и сравнить с эталоном. При сравнении с эталоном конечно следует весть осторожно - см. первые 11 советов. Итак, совет 12. Защищайте программы и данные контрольными суммами. Это поможет не только от взлома, но и защитит программы от вируса или внедрения троянца.
  • Применяйте шифровку программ и данных. Очень неплохо сжать программу и данные. Я, например, разработал свой собственный архиватор - RAR-у и ZIP-у он конкуренции не составит, но сжатые им данные разжать очень непросто, придется изрядно повозиться. Да и изменить их проблематично - придется разжать, изменить и сжать.
  • Отлов пошаговой отладки программы. Существует много способов, я в свое время провел целое исследование этого вопроса под DOS, насобирал и придумал не менее 20 методов, но они мало приемлемы под Windows. Самый простой и надежный способ - таймер. При работе программы периодически фиксируем системное время и рассчитываем время работы фрагментов кода между ними. И если 200-400 команд процессора работают 2-3 минуты, то тут есть над чем задуматься.
  • Не определяйте дату и время стандартными способом !! Придумайте что-нибудь оригинальное.
  • Не стоит хранить что-либо секретное в файлах или реестре. Работа с файлами или реестром может быть детально запротоколирована и проанализирована, и все тайное станет явным.
  • Не храните ничего важного открытым текстом, особенно сообщения типа "Это незарегистрированная версия ...", "Введенный пароль не верен ...".

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

Советы по созданию меток для организации ограничения по времени

Защита "ограничение времени работы" состоит в том, что программа каким образом фиксирует момент своего первого запуска и работает установленное время (обычно 20-30 дней). После истечения этого срока программа отказывается запускаться. Как проверить текущую дату я уже где-то тут писал - нестандартным способом, например по дате на файлах реестра или свежесозданном своем файле. Весь фокус в другом - как зафиксировать на компьютере дату первого запуска (естественно так, чтобы изничтожение программы и ее повторная установка не давали эффекта). Использование "секретных" файлов в системных папках или изменения в существующих файлах легко отловить при помощи FILEMON. Реестр то же отпадает из-за REGMON. Прочие методы (типа записи в ВООТ сектор ...) тоже неприемлемы - не те времена, по Windows все это не пройдет. Наиболее оригинально (на мой взгляд) прошить дату в саму программу и постоянно обновлять ее на своем сайте (естественно, автоматически). Таким образом отсчет неявно идет от момента скачивания программы с сайта. Есть тут правда и минус - после завершения срока можно повторно скачать эту программу и получить еще 15-20 дней ... . С другой стороны это оригинально - пользователю рано или поздно надоест скачивать эту программу и он или откажется от нее, или купит. Но при этом стоит помнить, что программу можно скачать несколько раз и сравнить варианты, выявив, где лежит дата. Поэтому стоит позаботиться о том, чтобы изменился почти весь файл (например, изменить пару опций компилятора)

Советы по формированию регистрационных кодов

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

  • Жестко фиксированные коды, прошитые в программу. Их обычно немного и их огласка сводит защиту к нулю.
  • Некий алгоритм проверки кода. Немного лучше первого, но лишь немного. Возьмите за пример код Windows - его знает любой пользователь
  • Алгоритм проверки кода, использующий имя пользователя. Очевидно, что для каждого имени будет уникальный номер (или номера - их может быть несколько, в зависимости от алгоритма). Это уже лучше, но нелегальное распространение держится на эгоизме зарегистрированных пользователей - ничто не мешает им предать имя/пароль огласке, но тогда хотя бы можно вычислить виновника и заблокировать его код
  • Алгоритм проверки кода, использующий имя пользователя и некоторые уникальные или динамически изменяющиеся параметры, например информацию о компьютере. Это надежно, дает привязку к компьютеру, но в наш век постоянных апгрейдов очень неудобен.
  • On-Line регистрация. Состоит в том, что программа в On-Line связывается с сайтом разработчиков (или компании, осуществляющей продужу софта) и передает туда ревизиты пользователя. В ответ программе передается регистрационная информация. Этот метод может и хорош для ряда программ, но на мой взгляд не выдерживает никакой критики по двум соображениям:
    1. Никто не может гарантировать, что конкретно передаст программа в Инет. А передать она может все, что угодно - параметры компьютера, пароли, любые данные и т.п.
    2. Конкретный пользователь ножет не иметь доступа к Инет. Это особенно важно для программ, работа которых не связана напрямую с Сетью. И зарегистрировать такую программу его практически никто к себе на компьютер не пустит (из соображений п.п. 1)

Рекомендовать тут что-либо бесполезно, но я например использую разновидности метода 3.




Запись буфера BDE на диск

Can't write: disk full. (R)etry, (F)ormat, (C)all #911?

Общее:

Сделанные в таблице изменения непосредственно на диск не записываются до тех пор, пока таблица не будет закрыта. Потеря питания или сбой в системе может привести к потере данных и прочим неприятностям. Чтобы избежать этого, существует два прямых вызова Database Engine, дающих один и тот же результат. Эти функции - DbiUseIdleTime и DbiSaveChanges.

DbiSaveChanges(hDBICur):

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


 procedure TForm1.Table1AfterPost(DataSet: TDataSet);
 begin
   DbiSaveChanges(Table1.handle);
 end;
 

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

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

Эта функция не применима к таблицам SQL.

DbiUseIdleTime:

DbiUseIdleTime может быть вызвана, если "Windows Message Queue" (очередь запросов Windows) пуста. Это позволяет Database Engine сохранить на диске "грязные буферы". Другими словами, выполняется операция DbiSaveChanges, но применительно ко ВСЕМ измененным таблицам. Тем не менее, данная операция не обязательно должна выполняться после каждого обновления записи, ее нужно приберечь для "холостого" периода (период простоя, idle).

В Delphi это может быть использовано таким образом (добавьте dbiProcs в список используемых модулей):


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Application.onIdle := UseIdle;
 end;
 
 procedure Tform1.UseIdle(Sender: TObject; var Done: Boolean);
 begin
   DbiUseIdleTime;
 end;
 

Некоторые замечания:

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

В случае, если в таблице выполняется не слишком много изменений, клиент может использовать вызов DbiSaveChanges после каждого постинга или же "повесить" на таймер вызов DbiUseIdleTime.




Как поместить картинку в заголовок TListView

Программисты (он и она) лежат в постели и отдыхают после занятий любовью.
Она: - Не хочешь повторить процедуру?
Он: - Функция еще не вернула значения.

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


 procedure TForm1.SetColumnImage( List: TListView; Column,
 Image: Integer; ShowImage: Boolean);
 var
   Align, hHeader: integer;
   HD: HD_ITEM;
 begin
   hHeader := SendMessage(List.Handle, LVM_GETHEADER, 0, 0);
   with HD do
   begin
     case List.Columns[Column].Alignment of
       taLeftJustify:
         Align := HDF_LEFT;
       taCenter:
         Align := HDF_CENTER;
       taRightJustify:
         Align := HDF_RIGHT;
       else
         Align := HDF_LEFT;
     end;
 
     mask := HDI_IMAGE or HDI_FORMAT;
 
     pszText := PChar(List.Columns[Column].Caption);
 
     if ShowImage then
       fmt := HDF_STRING or HDF_IMAGE or HDF_BITMAP_ON_RIGHT
     else
       fmt := HDF_STRING or Align;
 
     iImage := Image;
   end;
   SendMessage(hHeader, HDM_SETITEM, Column, Integer(@HD));
 end;
 

Картинки берутся из списка SmallImages. Вам надо будет вызвать эту функцию для каждой колонки и установить ShowImage в TRUE для той колонки, которую Вы будете сортировать. Сделать это можно в функции OnColumnClick():


 procedure TForm1.ListView1ColumnClick(Sender: TObject;
 Column: TListColumn);
 var
   i: integer;
 begin
   // Это Ваша собственная функция сортировки
   CustomSort( @CustomSortProc, Column.index );
   // Этот цикл отображает иконку в выбранной колонке.
   for i := 0 to ListView1.Columns.Count-1 do
     SetColumnImage( ListView1, i, 0, i = Column.index );
 end;
 

Проблема:

Изменение размера колонки генерирует сообщение WM_PAINT, которое стирает картинку, поэтому Вам прийдётся переопределить WM_PAINT и вызвать SetColumnImage снова.

Использовался компонент TApplicationEvents в delphi 5.




В DBGrid напротив некоторых строк можно поставить галочку

Идут курсы Майкрософт по Win'98. Инструктор (И) читает лекции чайникам-слушателям, среди которых случайно затесался программер. (П).
(И) Windows - это абсолютно надежная система, но если все же что-то случится, то для этих целей существует утилита Scandisk, которая работает абсолютно безупречно. Главное: не вздумайте отключать автоматический запуск этой утилиты после сбоев в работе. Вот недавно был такой случай: один программист удалил Scandisk, и когда Windows'98 случайно повисла, то после перезагрузки жесткий диск был поврежден, а неисправность не была устранена. А на другом компьютере, где была установлена эта утилита, после сбоя в работе Windows'98 проверила диск, поставила новые параметры и для подстраховки перезагрузила компьютер.
(П) Ага, знаю я этот комп, до сих пор Scandisk'ом проверяется, ставит новые параметры и для подстраховки перезагружается.

Нa сервере - тaблицa Advertis.DB, первичный ключ ID - autoincrement. Ha локaльном диске - тaблицa Founds.DB, с полем Advertis: integer, по которому есть индекс, и


 tblFounds.IndexFieldNames = 'Advertis'
 

Ha гриде:


 procedure TMainForm.dbgWorkDblClick(Sender: TObject);
 begin
   TriggerRowSelection;
 end;
 
 procedure TMainForm.TriggerRowSelection;
 begin
   if dmFile.AdvertisCount <> 0 then
   begin
     with dmFile do
       if not tblFounds.FindKey([tblAdvertisID.Value]) then
         tblFounds.AppendRecord([tblAdvertisID.Value])
       else
         tblFounds.Delete;
     dbgWork.Refresh;
   end;
 end;
 
 procedure TMainForm.dbgWorkDrawColumnCell(Sender: TObject;
           const Rect: TRect; DataCol: Integer; Column: TColumn;
           State: TGridDrawState);
 begin
   if DataCol = 0 then
     with dmFile, dbgWork.Canvas do
     begin
       FillRect(Rect); {clear the cell}
       if tblFounds.FindKey([tblAdvertisID.Value]) then
         TextOut(Rect.Left, Rect.Top, 'ь');
     end;
 end;
 

Окaзывaется, я переопределял рисовaние гридa, a не вычислял поле. Не помню точно, но кaжется, чтобы не перечитывaть тaблицу нa кaждый дaблклик, a только перерисовaть грид.

А колонкa для гaлки в гриде определялaсь тaк:


 with dmFile, dbgWork.Columns do
 begin
   BeginUpdate;
   Clear;
 
   {check mark}
   nc := Add;
   nc.Width := 14;
   nc.Font.name := 'Wingdings';
   nc.Font.Size := 11;
   nc.Alignment := taRightJustify;
   nc.Title.Caption := 'ю';
   nc.Title.Font.name := 'Wingdings';
   nc.Title.Font.Size := 10;
   nc.Title.Alignment := taCenter;
 
   {skip определения остaльных колонок}
 
   EndUpdate;
 end;
 

Вроде всё. Ну, кaк нaпечaтaть/обрaботaть только помеченное, сaм рaзберёшься. У меня тaм нaкручено чего-то с фильтрaми, думaю, можно проще. Что кaсaется других способов - можно вместо временной тaблицы попользовaть список, мaссив или in-memory table.




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

Автор: Mike Scott

Я не могу разобраться как мне вставить TTimer в мой компонент и получить доступ к его методам и свойствам. Я нигде не могу найти пример такого использования таймера. Кто-нибудь может мне помочь?

Я просто создал это для вас:


 type
   TMyControl = class(TCustomControl)
   private
     FTimer: TTimer;
     procedure TimerEvent(Sender: TObject);
   public
     constructor Create(AOwner: TComponent); override;
   end;
 
 constructor TMyControl.Create(AOwner: TComponent);
 begin
   inherited Create(AOwner);
   FTimer := TTimer.Create(Self);
   FTimer.Interval := 100; { 100 ms }
   FTimer.OnTimer := TimerEvent;
 end;
 
 procedure TMyControl.TimerEvent(Sender: TObject);
 begin
   { вот ваш обработчик события, который вызывается при каждом
   срабатывании таймера - делайте здесь все что вам необходимо }
 end;
 

Легче не бывает! Правда, есть за что любить Delphi?




Качественно уменьшить изображение

В Delphi изменять размеры изображения очень просто, используя CopyRect:


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   Form1.Canvas.Font.Size := 24;
   Form1.Canvas.TextOut(0, 0, 'Text');
   Form1.Canvas.CopyRect(Bounds(0, 50, 25, 10), Form1.Canvas,
   Bounds(0, 0, 100, 40));
 end;
 

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


 procedure TForm1.Button1Click(Sender: TObject);
 var
   x, y: integer;
   i, j: integer;
   r, g, b: integer;
 begin
   Form1.Canvas.Font.Size := 24;
   Form1.Canvas.TextOut(0, 0, 'Text');
   for y := 0 to 10 do
   begin
     for x := 0 to 25 do
     begin
       r := 0;
       for i := 0 to 3 do
         for j := 0 to 3 do
           r := r + GetRValue(Form1.Canvas.Pixels[4*x+i, 4*y+j]);
       r := round(r / 16);
       g := 0;
       for i := 0 to 3 do
         for j := 0 to 3 do
           g := g + GetGValue(Form1.Canvas.Pixels[4*x+i, 4*y+j]);
       g := round(g / 16);
       b := 0;
       for i := 0 to 3 do
         for j := 0 to 3 do
           b := b + GetBValue(Form1.Canvas.Pixels[4*x+i, 4*y+j]);
       b := round(b / 16);
       Form1.Canvas.Pixels[x,y+50] := RGB(r, g, b)
     end;
     Application.ProcessMessages;
   end;
 end;
 




Модуль, позволяющий в Delphi осуществить форму запроса для DBGrid

Автор: Rick Rutt

Визит министра здравоохранения (МЗ) в одну из психиатрических лечебниц. Осмотрев палаты, процедурные залы, столовую МЗ изьявляет желание проверить, как содержатся буйнопомешанные больные, опасные для окружающих. Спускаются на 1-й этаж, Главный врач (ГВ) отпирает стальную кованую дверь. За дверью длинный коридор. МЗ переходит от камеры, к камере, читает таблички, иногда заглядывает внутрь. Около одной из камер. МЗ:
- Так-так. Острая паранойя, OS/2 Warp, мания величия...
Заглядывает в окошко. Угрюмый тип, увидев МЗ, начинает метаться по камере, крича: "Ла-а-меры!!! Ла-а-а-меры!!! Суксь, Суксь МастДайная!!!"
МЗ: (Обращается к ГВ) Часто он так?
ГВ: Как новое лицо увидит, сразу приступ... Идут дальше.
МЗ: Так-так. Острая паранойя.
UNIX, мания величия... Заглядывает в окошко. Угpюмый тип, оторвавшись от созерцания собственных рук, поворачивается, и расплывшись в улыбке, изрекает: "Истинная многозадачность, полный контроль, Рулез Форева!"
МЗ: (Обращается к ГВ) Тихий какой! Выздоравливает?
ГВ: Hет, временное улучшение.
(Повернувшись к окошку) - NT!
Больной, вскочив с кровати, начинает метаться по камере, крича: "А-а-а!!! Вытесняющая многозадачность!!! Исходные тексты!!! Суксь!!! Ла-а-а-меpы!!!"
Идут дальше.
МЗ: Так-так. Острая паранойя.
Windows'95, мания величия. Заглядывает в окошко... Камера пуста. МЗ: (Hедоумённо поворачивается к ГВ)
- А где же больной? Hа процедурах?
ГВ: Видите ли... Только поймите нас правильно... Бухгалтерия у нас на Excel, личные дела больных на Access...

Предлагаю Вашему вниманию модуль Delphi для модального диалога, поддерживающий форму запроса (Query By Form - QBF) для компонентов DbGrid с возможностью получения данных от Table-компонентов (не используя Query-компонентов).

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

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


 unit Db_QBF; { Форма запроса базы данных }
 
 { Все права защищены. Автор Rick Rutt.
 
 Данный модуль может без какой-либо оплаты быть использован в программе,
 скопирован или распространен любым человеком и для любой цели, если все
 копии данного модуля сохраняют это авторское уведомление.
 Автор предоставляет разрешение каждому для создания производного кода, если
 каждая производная работа содержит авторское уведомление и строку
 "Части данной работы основываются на Db_QBF.PAS, созданным Rick Rutt."
 }
 
 { Данный модуль обеспечивает простую, но эффективную форму запроса
 
 для доступа приложений к базам данных, используя Borland Delphi.
 Данный модуль также располагает сервисом Sort By Form (форма сортировки).
 
 Форма запроса отображает модальное диалоговое окно с компонентом StringGrid,
 содержащим искомые поля, полученные при вызове DbGrid. Пользователь может
 ввести точную величину поиска для любого количества полей и использовать
 функцию drag and drop (перетащи и брось) для изменения порядка сортировки полей.
 (Только тех полей, которые содержат искомые величины, влияющие на сортировку.)
 Когда пользователь щелкает в диалоговом окне на кнопку OK, данный модуль
 модифицирует значение свойства IndexFieldNames компонента DbGrid, применяет
 диапазон поиска (точные величины), и обновляет данные.
 В случае, если пользователь не указывает ни одной из величин поиска,
 данный модуль очищает значение свойства IndexFieldNames компонента DbGrid,
 очищает диапазон поиска и обновляет данные.
 
 Сервис Sort By Form работает аналогично, за исключением того,
 что не принимает в расчет величину поиска, введенную пользователем. Пользователь
 пользуется функцией drag and drop (перетащи и брось) для установления порядка
 сортировки и затем нажимает на кнопку OK. Данный модуль модифицирует
 значение свойства IndexFieldNames компонента DbGrid, очищает диапазон поиска
 и обновляет данные.
 }
 
 { Создайте соответствуюшую форму диалога, используя меню "File/New.../Dialogs"
 
 и выбрав пункт "Standard Dialog Box". Разместите на форме компонент StringGrid
 (Вы найдете его в палитре компонентов на странице "Additional").
 Установите следующие размеры StringGrid: высота 161 и ширина 305.
 И, наконец, замените исходный код новой формы (PAS-файл) данным модулем.
 }
 
 interface
 
 uses WinTypes, WinProcs, Classes, Graphics, Forms, Controls, Buttons,
 
   StdCtrls, ExtCtrls, Grids, DBGrids;
 
 { Следующие две процедуры обеспечивают механизм доступа
 
 сервисов данного модуля.
 
 Кнопка (или пункт меню) вызывают процедуру,
 передавая ей в качестве аргумента DbGrid. (Не забудьте добавить строку
 "uses Db_QBF;" в секцию реализации модуля вызова форм.)
 
 Ограничение: компонент DbGrid должен ссылаться на DataSource,
 который, в свою очередь, ссылается на DataSet, работающий с
 таблицой. Данный модуль не поддерживает запрос напрямую к
 DataSet ввиду отсутствия свойства IndexFieldNames.
 }
 
 procedure QueryByForm(grid: TDbGrid);
 
 procedure SortByForm(grid: TDbGrid);
 
 { Следующая секция управляется средой Delphi. }
 
 type
 
   TdlgQBF = class(TForm)
     OKBtn: TBitBtn;
     CancelBtn: TBitBtn;
     HelpBtn: TBitBtn;
     gridQBF: TStringGrid;
     procedure OKBtnClick(Sender: TObject);
     procedure CancelBtnClick(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
 
   dlgQBF: TdlgQBF;
 
 implementation
 
 { Следующая секция пишется программистом
 
 с помощью среды Delphi. }
 
 uses Dialogs, Db, DbTables;
 
 {$R *.DFM}
 
 const
 
   qbfRowHeight = 16;
   qbfColWidth = 150;
 
   qbfFieldLabel = '<<Поле>>';
   qbfValueLabel = '<<Значение>>';
 
   qbfQueryCaption = 'Запрос для таблицы ';
   qbfSortCaption = 'Порядок сортировки для таблицы ';
 
 var
 
   { Объявим некоторые элементы управления, участвующие
   в QBF-диалоге при нажатии кнопки OK. }
   CallingGrid: TDbGrid;
   CallingMode: (modeQuery, modeSort);
 
 procedure SetupAndShowForm;
   { Инициализация формы, обеспечивающей визуализацию
   работы двух объявленных выше процедур }
 var
 
   i, j, n: integer;
   tbl: TTable;
   f: TField;
 begin
 
   n := CallingGrid.FieldCount;
   if n <= 0 then
   begin { Вместо вывода сообщений могут генерится исключительные ситуации }
     MessageDlg(
       'При обращении к DbGrid, модуль Db_QBF не обнаружил полей',
       mtWarning, [mbOK], 0);
   end
   else if CallingGrid.DataSource = nil then
   begin
     MessageDlg(
       'При обращении к DbGrid, модуль Db_QBF не обнаружил ссылки на DataSource',
       mtWarning, [mbOK], 0);
   end
   else if CallingGrid.DataSource.DataSet = nil then
   begin
     MessageDlg(
       'При обращении к DbGrid, модуль Db_QBF обнаружил подключенный
       DataSource без ссылки на DataSet',
       mtWarning, [mbOK], 0);
   end
   else if not (CallingGrid.DataSource.DataSet is TTable) then
   begin
     MessageDlg(
       'При обращении к DbGrid, модуль Db_QBF обнаружил подключенный
       DataSource с сылкой на DataSet, не являющийся таблицей.',
       mtWarning, [mbOK], 0);
   end
   else
     with dlgQBF.gridQBF do
     begin
       { Данные свойства могут быть изменены и в режиме проектирования }
       DefaultRowHeight := qbfRowHeight;
       Scrollbars := ssVertical;
       ColCount := 2; { Для режима сортировки необходимы две пустые колонки }
 
       { Данные свойства должны быть установлены во время выполнения программы }
       RowCount := Succ(n);
       Cells[0, 0] := qbfFieldLabel;
       Options := Options + [goRowMoving];
 
       tbl := TTable(CallingGrid.DataSource.DataSet);
 
       if CallingMode = modeQuery then
       begin
         dlgQBF.Caption := qbfQueryCaption + tbl.TableName;
         Cells[1, 0] := qbfValueLabel;
         Options := Options + [goEditing];
           { Позволяем пользователю ввести значение }
         DefaultColWidth := qbfColWidth;
       end
       else
       begin
         dlgQBF.Caption := qbfSortCaption + tbl.TableName;
         Cells[1, 0] := '';
           { Ввод "пустышки" для первой, нефункциональной колонки }
         Options := Options - [goEditing]; { Убираем возможность редактирования }
         DefaultColWidth := (2 * qbfColWidth);
           { Этим трюком мы помещаем две пустых секции над одной колонкой }
       end;
 
       j := 0; { Фактическое число полей, показываемое пользователю }
       for i := 1 to n do
       begin
         f := CallingGrid.Fields[Pred(i)];
         if f.DataType in [ftBlob, ftBytes, ftGraphic, ftMemo, ftUnknown,
           ftVarBytes] then
           RowCount := Pred(RowCount) { Игнорируем неиндексируемые поля }
         else
         begin
           Inc(j);
           Cells[0, j] := f.FieldName;
           Cells[1, j] := ''; { Сбрасываем искомую величину }
         end;
       end;
 
       dlgQBF.HelpBtn.Visible := False; { Помощь, понятно, отсутствует... }
       dlgQBF.ShowModal;
     end; { with dlgQBF.gridQBF }
 end;
 
 procedure QueryByForm(Grid: TDbGrid);
 begin
 
   CallingGrid := Grid; { Сохраняем для использования при нажатии на кнопку OK }
   CallingMode := modeQuery;
   SetupAndShowForm;
 end;
 
 procedure SortByForm(Grid: TDbGrid);
 begin
 
   CallingGrid := Grid; { Сохраняем для использования при нажатии на кнопку ОК }
   CallingMode := modeSort;
   SetupAndShowForm;
 end;
 
 procedure TdlgQBF.CancelBtnClick(Sender: TObject);
 begin
 
   { Просто прячем диалог, не делая никаких изменений в вызывающем Grid'е. }
   dlgQBF.Hide;
 end;
 
 procedure TdlgQBF.OKBtnClick(Sender: TObject);
 var
 
   flds, sep, val: string;
   i, n, nfld: integer;
 begin
 
   flds := ''; { Список полей, разделенных ';'. }
   sep := ''; { Разделитель ';' ставится после добавления первого поля. }
   nfld := 0; { Количество полей в списке. }
 
   with dlgQBF.gridQBF do
   begin
     n := Pred(RowCount);
     if n > 0 then
       for i := 1 to n do
       begin
         val := Cells[1, i];
           { Значение поиска, введенное пользователем (если имеется) }
         if (CallingMode = modeSort)
           or (val <> '') then
         begin
           flds := flds + sep + Cells[0, i];
           sep := ';';
           nfld := Succ(nfld);
         end;
       end;
 
     with CallingGrid.DataSource.DataSet as TTable do
     begin
       IndexFieldNames := flds;
       if (CallingMode = modeSort)
         or (flds = '') then
       begin
         CancelRange;
       end
       else
       begin
         SetRangeStart;
         for i := 1 to n do
         begin
           val := Cells[1, i];
           if val <> '' then
           begin
             FieldByName(Cells[0, i]).AsString := val;
           end;
         end;
 
         {Устанавливаем конец диапазона так, чтобы он соответствовал его началу}
         SetRangeEnd;
         for i := 1 to n do
         begin
           val := Cells[1, i];
           if val <> '' then
           begin
             FieldByName(Cells[0, i]).AsString := val;
           end;
         end;
         ApplyRange;
       end;
 
       Refresh;
     end; { with CallingGrid.DataSource.DataSet }
   end; { with dlgQBF.gridQBF }
 
   dlgQBF.Hide;
 end;
 
 end.
 




Параметризованные запросы

Как мне передать переменную в запрос?

Сначала вы должны создать запрос, использующий переменную.

  Select Test."FName", Test."Salary Of Employee"
   From Test
   Where Test."Salary of Employee" > :val
Примечание: Если вы просто пишете имя поля как "Salary of Employee", вы получите ошибку "Capability Not Supported". Это должно быть просто Test."Salary of Employee".

В нашем случае имя переменной "val", но это может быть любое другое (естественно). Затем вы переходите к свойству TQuery's params и устанавливаете параметр "val" в зависимости от требуемого типа. В нашем примере мы используем тип integer.

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


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   with Query1 do
   begin
     Close;
     ParamByName('val').AsInteger := StrToInt(Edit1.Text);
     Open;
   end;
 end;
 

Примечание: рекомендуем в качестве меры предосторожности разместить приведенный выше код в блоке try..except.

Если в своем запросе вы хотите использовать ключевое слово LIKE, то вы можете сделать это так:

Примечание: Следующий код использует таблицу пользователя, расположенную в каталоге \delphi\demos\data. При этом также возможно использование псевдонима DBDEMOS.

Код SQL для свойства TQuery.SQL:

  SELECT * FROM CUSTOMER
   WHERE Company LIKE :CompanyName

Код Delphi:


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   with Query1 do
   begin
     Close;
     ParamByName('CompanyName').AsString := Edit1.Text + '%';
     Open;
   end;
 end;
 

Альтернативный способ передачи параметра (с последующим использованием ParamByName) - params[TheParameterNumber].

Вот демонстрация такого способа:


 ParamByName('CompanyName').AsString := Edit1.Text + '%';
 

или, в качестве альтернативы:


 Params[0].AsString := Edit1.Text + '%';
 

Хитрость шаблона - в конкатенирующем знаке процента в конце параметра.




Проблемы со шрифтами у QuickReport

Я использую Delphi 2.0 и QuickReports 1.1.

Я создал ОЧЕНЬ сложный (графически, во всяком случае) отчет и только что обнаружил, что это не выводится как положено на экране и на принтере во время выполнения программы (хотя это и корректно отображается в окне предварительного просмотра в режиме проектирования). Ошибка возникает только в том случае, если в Windows 95 установлены большие (LARGE) системные шрифты! Ну и что мне теперь прикажете делать?

У меня тоже была такая же серьезная проблема, но только при печати под Win 95 на офисный HP 4M и при просмотре отчета под NT 4.0. Но то же самое приложение у меня прекрасно работало под NT 3.51 SP5.

Я видел дискуссию по поводу этой ошибки, возникающей в GDI коде под NT 4.0, поэтому я не удивился, обнаружив ее у себя. Мне пришлось засучить рукава и очень тесно познакомиться с кодом QuickReports, особенно с процедурой первичного вывода текста, когда программа изменяет шрифт в каждой выводимой области. Вот этот злосчастный сегмент кода в методе TQRCustomControl.Print:


 QRPrinter.Canvas.Font:=Font;
 QRPrinter.Canvas.Font.size:=trunc(abs(parentreport.xpos(font.size)));
 QRPrinter.Canvas.brush.Color:=Color;
 

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

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

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

Лучшее решение я увидел в следующем:


 // При установке нового шрифта сохраняем шрифт принтера
 SaveFont := TFont.Create;
 SaveFont.Assign(QRPrinter.Canvas.Font);
 
 QRPrinter.Canvas.Font:=Font;
 QRPrinter.Canvas.Font.size:=trunc(abs(parentreport.xpos(font.size)));
 QRPrinter.Canvas.brush.Color:=Color;
 
 // Освобождаем сохраненный шрифт принтера. Теперь работа сделана.
 SaveFont.Free;
 SaveFont := nil;
 

Дополнительными строками нам удается проверить тот факт, что шрифт принтера уже используется или же для холста принтера выбирается тот же самый шрифт. Это работает уже вполне корректно и позволяет печатать правильные отчеты под NT 4.0. Некоторым странным совпадением можно считать устранение зашитых жирных шрифтов, изменившее шрифты, печатаемые под Win95.

Так, если у вас есть зарегистрированная версия QuickReports, вы можете сделать коррекцию исходных файлов, и вы увидите, что ваши отчеты будут генериться быстрее, выглядеть "мягче" и не будет ошибок и издержек шрифтовых ресурсов из-за ограничения кода расширенных метафайлов и GDI.




Заголовок окна предварительного просмотра QuickReport

Попробуйте сделать следующее:


 QRPrinter.PreviewCaption := 'Мой заголовок';
 

QRPrinter - глобальная переменная, определенная в модуле Quickrep.pas




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


 // Только для не SQL-ых, т.е не промышленных БД (dBase, Paradox ..)
 // Путь нужно задавать только АНГЛИЙСКИМИ буквами
 procedure QuickCopyTable(T: TTable; DestTblName: string; Overwrite: boolean);
 var
   DBType: DBIName;
   WasOpen: boolean;
   NumCopied: word;
 begin
   WasOpen := T.Active;
   if not WasOpen then
     T.Open;
   Check(DbiGetProp(hDBIObj(T.Handle),drvDRIVERTYPE, @DBType,SizeOf(DBINAME), NumCopied));
   Check(DbiCopyTable(T.DBHandle, Overwrite, PChar(T.TableName),DBType, PChar(DestTblName)));
   T.Active := WasOpen;
 end;
 




Быстрый поиск в базах данных

Кинул как-то уркаган маляву по Яндексу...

Я представляю на Ваш суд утилиту быстрого поиска по базе данных. Данная технология производит поиск по полям, преобразуя их значения в строки (все значения преобразуются в верхний регистр, включая действительные числа). Данное решение может быть не самым быстрым, однако на поверку оно оказывается быстрее остальных, обнаруженных мною в Интернете (может вам повезет больше). Более того, представьте, что действительное значение какого-либо поля равно 4.509375354, а значение поиска равно 7, в этом случае утилита засчитает "попадание". Утилита удобна также тем, что она за один проход производит поиск более, чем в одном поле. Это удобно, если у Вас имеются, к примеру, два поля с адресами. Это моя первая "серьезная" разработка, так как первое, с чем я столкнулся, изучая Delphi, стала необходимость включения процедуры поиска в любое приложение, работающее с базой данных. А так как поиск - вещь тоже сугубо специфическая, как и любое приложение, то мне пришлось побороть свой страх перед "крутым программированием" и попробовать написать свой поисковый механизм, удовлетворивший меня (и, надеюсь, других) своей скоростью и возможностью "мульти"-поиска по нескольким полям. Я надеюсь, что он поможет тем программистам, кто часто сталкивается с подобными задачами. Технология довольно легка для понимания, но если у Вас возникли какие-либо вопросы, пошлите мне письмо электронной почтой, я буду рад Вам помочь. Посмотрев код, можно легко узнать поддерживаемые типы полей (добавить новые не составит проблем). Если кто-либо обнаружит ошибочный код или расширит функциональность утилиты, пожалуйста, пошлите это мне, я буду весьма благодарен. Спасибо.


 unit Finder;
 
 interface
 
 uses DB, DBTables, SysUtils;
 
 function GrabMemoFieldAsPChar(TheField: TMemoField): PChar;
 function DoFindIn(TheField: TField; SFor: string): Boolean;
 function FindIt(TheTable: TDataSet; TheFields: array of integer;
 
   SearchBackward: Boolean; FromBeginning: Boolean; SFor: string): Boolean;
 {применение функции FindIt -
 
 if FindIt(NotesSearchT,
 [NotesSearchT.FieldByName('Leadman').Index],
 False, True, SearchText.Text) then DoSomething; }
 
 implementation
 
 function GrabMemoFieldAsPChar(TheField: TMemoField): PChar;
 begin
   with TBlobStream.Create(TheField, bmRead) do
 
   begin
     GetMem(Result, Size + 1);
     FillChar(Result^, Size + 1, #0);
     Read(Result^, Size);
     Free;
   end;
 end;
 
 function DoFindIn(TheField: TField; SFor: string): Boolean;
 var
 
   PChForMemo: PChar;
 begin
   Result := False;
   case TheField.DataType of
 
     ftString:
       begin
         if (Pos(SFor, UpperCase(TheField.AsString)) > 0) then
           Result := True;
       end;
     ftInteger:
       begin
         if (Pos(SFor, TheField.AsString) > 0) then
           Result := True;
       end;
     ftBoolean:
       begin
         if SFor = UpperCase(TheField.AsString) then
           Result := True;
       end;
     ftFloat:
       begin
         if (Pos(SFor, TheField.AsString) > 0) then
           Result := True;
       end;
     ftCurrency:
       begin
         if (Pos(SFor, TheField.AsString) > 0) then
           Result := True;
       end;
     ftDate..ftDateTime:
       begin
         if (Pos(SFor, TheField.AsString) > 0) then
           Result := True;
       end;
     ftMemo:
       begin
         SFor[Ord(SFor[0]) + 1] := #0;
         PChForMemo := GrabMemoFieldAsPChar(TMemoField(TheField));
         StrUpper(PChForMemo);
         if not (StrPos(PChForMemo, @SFor[1]) = nil) then
           Result :=
             True;
         FreeMem(PChForMemo, StrLen(PChForMemo + 1));
       end;
   end;
 end;
 
 function FindIt(TheTable: TDataSet; TheFields: array of integer;
 
   SearchBackward: Boolean; FromBeginning: Boolean; SFor: string): Boolean;
 var
 
   i, HighTheFields, LowTheFields: integer;
   BM: TBookmark;
 begin
   TheTable.DisableControls;
   BM := TheTable.GetBookmark;
   try
     LowTheFields := Low(TheFields);
     HighTheFields := High(TheFields);
     SFor := UpperCase(SFor);
     Result := False;
     if FromBeginning then
       TheTable.First;
     if SearchBackward then
 
     begin
       TheTable.Prior;
       while not TheTable.BOF do
       begin
         for i := LowTheFields to HighTheFields do
         begin
           if DoFindIn(TheTable.Fields[TheFields[i]], SFor) then
           begin
             Result := True;
             Break;
           end;
         end;
         if Result then
           Break
         else
           TheTable.Prior;
       end;
     end
     else
     begin
       TheTable.Next;
       while not TheTable.EOF do
       begin
         for i := LowTheFields to HighTheFields do
         begin
           if DoFindIn(TheTable.Fields[TheFields[i]], SFor) then
           begin
             Result := True;
             Break;
           end;
         end;
         if Result then
           Break
         else
           TheTable.Next;
       end;
     end;
   finally
     TheTable.EnableControls;
     if not Result then
 
       TheTable.GotoBookmark(BM);
     TheTable.FreeBookmark(BM);
   end;
 
 end;
 
 end.
 




Пример быстрой работы с графикой

Автор: Koster

Пример быстрой работы с графикой в среде Windows без использования средств DirectX Совместимость: Windows 95, 98, NT, 2000, Me, TrE, XP, Whistler, Tristler :))


 // © Koster < mtaurus@rambler.ru >
 // Greetz to: Vano aka RIS, Uras aka Assargadon
 // Special thanx to: Leon the Trillennium
 
 unit VisualForm;
 
 interface
 
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   StdCtrls, ExtCtrls, Buttons, ComCtrls;
 
 type
   TfmMain = class(TForm)
     Panel1: TPanel;
     Panel2: TPanel;
     pbDraw: TPaintBox;
     Timer1: TTimer;
     Label1: TLabel;
     procedure FormCreate(Sender: TObject);
     procedure FormDestroy(Sender: TObject);
     procedure FormResize(Sender: TObject);
     procedure Timer1Timer(Sender: TObject);
   private
     { Private declarations }
     procedure CreateBitmap(aSX, aSY: Integer);
     procedure RecreateBitmap(aSX, aSY: Integer);
     procedure DeleteBitmap;
 
     procedure RestrictSize(var msg: TMessage); message WM_GETMINMAXINFO;
     procedure pbDrawPaint(Sender: TObject);
   private
     ScrBitmap: TBitmap;
     Scr: Pointer;
     SX, SY: Integer;
   public
     { Public declarations }
   end;
 
 var
   fmMain: TfmMain;
 
 implementation
 
 {$R *.DFM}
 
 type
   TBig = array[0..0] of Integer;
 
 procedure TfmMain.CreateBitmap(aSX, aSY: Integer);
 var
   BInfo: tagBITMAPINFO;
 begin
   // Создание DIB
   SX := aSX; SY := aSY;
   BInfo.bmiHeader.biSize := sizeof(tagBITMAPINFOHEADER);
   BInfo.bmiHeader.biWidth := SX;
   BInfo.bmiHeader.biHeight := -SY;
   BInfo.bmiHeader.biPlanes := 1;
   BInfo.bmiHeader.biBitCount := 32;
   BInfo.bmiHeader.biCompression := BI_RGB;
   ScrBitmap := TBitmap.Create();
   ScrBitmap.Handle := CreateDIBSection(Canvas.Handle, BInfo, DIB_RGB_COLORS, Scr, 0, 0);
   ZeroMemory(Scr, SX * SY * 4);
 end;
 
 procedure TfmMain.DeleteBitmap;
 begin
   // Удаление DIB
   ScrBitmap.FreeImage();
   ScrBitmap.Destroy;
 end;
 
 procedure TfmMain.RecreateBitmap(aSX, aSY: Integer);
 var
   BInfo: tagBITMAPINFO;
 begin
   // Пересоздание DIB при изменении размеров "экрана"
   ScrBitmap.FreeImage();
   SX := aSX; SY := aSY;
   BInfo.bmiHeader.biSize := sizeof(tagBITMAPINFOHEADER);
   BInfo.bmiHeader.biWidth := SX;
   BInfo.bmiHeader.biHeight := -SY;
   BInfo.bmiHeader.biPlanes := 1;
   BInfo.bmiHeader.biBitCount := 32;
   BInfo.bmiHeader.biCompression := BI_RGB;
   ScrBitmap.Handle := CreateDIBSection(Canvas.Handle, BInfo, DIB_RGB_COLORS, Scr, 0, 0);
   ZeroMemory(Scr, SX * SY * 4);
 end;
 
 procedure TfmMain.FormCreate(Sender: TObject);
 begin
   CreateBitmap(pbDraw.ClientWidth, pbDraw.ClientHeight);
   pbDraw.Canvas.Draw(0, 0, ScrBitmap);
   Caption := 'Визуализатор'; Application.Title := Caption;
 end;
 
 procedure TfmMain.FormDestroy(Sender: TObject);
 begin
   DeleteBitmap();
 end;
 
 procedure TfmMain.FormResize(Sender: TObject);
 begin
   ReCreateBitmap(pbDraw.ClientWidth, pbDraw.ClientHeight);
   pbDraw.Canvas.Draw(0, 0, ScrBitmap);
 end;
 
 procedure TfmMain.RestrictSize(var msg: TMessage);
 var
   p: PMinMaxInfo;
 begin
   // Ограничитель размеров окна (обработка сообщений Windows).
   // Удобная вещь кстати (важно: см. объявление процедуры в классе TFmMain)
   // The lParam contains a pointer on a structure of type TMinMaxInfo
   p := PMinMaxInfo(Msg.lParam);
   // This represents the size of the Window when Maximized
 //  p.ptMaxSize.x := 320;
 //  p.ptMaxSize.y := 240;
   // This represents the position of the Window when Maximized
 //  p.ptMaxPosition.x := 10;
 //  p.ptMaxPosition.y := 10;
   // This represents the minimum size of the Window
   p.ptMinTrackSize.x := 520;
   p.ptMinTrackSize.y := 240;
   // This represents the maximum size of the Window
 //  p.ptMaxTrackSize.x := 400;
 //  p.ptMaxTrackSize.y := 320;
 end;
 
 procedure TfmMain.pbDrawPaint(Sender: TObject);
 begin
   pbDraw.Canvas.Draw(0, 0, ScrBitmap);
 end;
 

Пример работы с данной конструкцией:
SX - текущий размер нашего "экрана" по горизонтали
SY - по вертикали
TBig(Scr^). Scr - это указатель на массив пикселей битмапа, который в нашем случае имеет разрядность 32 (32 бита, или 4 байта на пиксел, что эквивалентно типу Integer. См. объявление типа TBig). Конструкция TBig(Scr^) позволяет адресовать эту память как массив пиксел. Чтобы получить доступ к пикселу нужно использовать индекс массива [x + y * SX].

Функция RGB. Это стандартная делфяцкая функция, не приспособленная для того что мы тут творим, а только для своего "родного" класс TCanvas и его цветовых кодов. В Windows при использовании 32-разрядных битмапов формат пиксела такой (начиная с первого байта):

             BBBBBBBB GGGGGGGG RRRRRRRR ********
 

В Delphi (то что ВСЕГДА возвращает функция RGB, при любой разрядности картинки):

             RRRRRRRR GGGGGGGG BBBBBBBB ********
 

Усматривается аналогия :) Все что нужно это просто перечислить аргументы функции в обратном порядке :))

             TBig(Scr^)[x + y * SX] := RGB(B, G, R);
 

B, G, R - соответственно значения интенсивности синего, зеленого, и красного цветов размером байт, т.е. [0..255].

Палитра 32-разрядным режимом не поддерживается, за нас думает Windows (вернее, понятия палитры в таком режиме вообще нет). Ну а нам остается это все юзать как надо +)))

Чтобы почистить виртуальный экран, нужно сделать так: ZeroMemory(Scr, SX * SY * 4);


 procedure TfmMain.Timer1Timer(Sender: TObject);
 var
   x, y: Integer;
 
 begin
   // В цикле рисуется полная левота. Рисуйте тут свою левоту :)
   for x := 0 to SX - 1 do for y := 0 to SY - 1 do
     TBig(Scr^)[x + y * SX] := RGB(Random(256),Random(256),Random(256));
 
   // При желании, используем средства Delphi на объекте ScrBitmap типа TBitmap
   // в т.ч. можно нарисовать на нем другой Bitmap с помощью функции
   // ScrBitmap.Canvas.Draw(x,y,AnotherBitmap);
   // Чтобы текст выглядел красивее (без фона), раскомментируйте строки
   // SetBkMode(ScrBitmap.Canvas.Handle, TRANSPARENT);
   ScrBitmap.Canvas.Font.Size := 24;
   ScrBitmap.Canvas.TextOut(10, 10, 'Demo');
   // SetBkMode(ScrBitmap.Canvas.Handle, OPAQUE);
 
   // Нарисуемся
   pbDrawPaint(Self);
 end;
 
 end.
 




Быстрый поиск в списке


 ListBox1.Perform(LB_SELECTSTRING, -1, longint(Pchar(Edit1.text)));
 




Быстрая сортировка

Автор: www.structur.h1.ru

Цель: изучение алгоритма быстрой сортировки и ее модификаций.

На этом занятии мы изучим алгоритм быстрой сортировки, который, пожалуй, используется более часто, чем любой другой. Основа алгоритма была разработана в 1960 году (C.A.R.Hoare) и с тех пор внимательно изучалась многими людьми. Быстрая сортировка особенно популярна ввиду легкости ее реализации; это довольно хороший алгоритм общего назначения, который хорошо работает во многих ситуациях, и использует при этом меньше ресурсов, чем другие алгоритмы.

Основные достоинства этого алгоритма состоят в том, что он точечный (использует лишь небольшой дополнительный стек), в среднем требует только около N log N операций для того, чтобы отсортировать N элементов, и имеет экстремально короткий внутренний цикл. Недостатки алгоритма состоят в том, что он рекурсивен (реализация очень затруднена когда рекурсия недоступна), в худшем случае он требует N2 операций, кроме того он очень "хрупок": небольшая ошибка в реализации, которая легко может пройти незамеченной, мо жет привести к тому, что алгоритм будет работать очень плохо на некоторых файлах.

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

Улучшить алгоритм быстрой сортировки является большим искушением: более быстрый алгоритм сортировки - это своеобразная "мышеловка" для программистов. Почти с того момента, как Oia?a впервые опубликовал свой алгоритм, в литературе стали появляться "улучшен ные" версии этого алгоритма. Было опробовано и проанализировано множество идей, но все равно очень просто обмануться, поскольку алгоритм настолько хорошо сбалансирован, что результатом улучшения в одной его части может стать более сильное ухудшение в друг ой его части. Мы изучим в некоторых деталях три модификации этого алгоритма, которые дают ему существенное улучшение.

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

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


 program Quitsort;
  uses
    crt;
  Const
   N=10;
  Type
   Mas=array[1..n] of integer;
 var
   a: mas;
   k: integer;
 function Part(l, r: integer):integer;
 var
   v, i, j, b: integer;
 begin
   V:=a[r];
   I:=l-1;
   j:=r;
   repeat
     repeat
       dec(j)
     until (a[j]<=v) or (j=i+1);
     repeat
       inc(i)
     until (a[i]>=v) or (i=j-1);
     b:=a[i];
     a[i]:=a[j];
     a[j]:=b;
   until i>=j;
   a[j]:=a[i];
   a[i]:= a[r];
   a[r]:=b;
   part:=i;
 end;
 procedure QuickSort(l, t: integer);
 var i: integer;
 begin
   if l<t then
     begin
       i:=part(l, t);
       QuickSort(l,i-1);
       QuickSort(i+1,t);
     end;
 end;
 begin
   clrscr;
   randomize;
   for k:=1 to 10 do
     begin
       a[k]:=random(100);
       write(a[k]:3);
     end;
   QuickSort(1,n);
   writeln;
   for k:=1 to n do
     write(a[k]:3);
   readln;
 end.
 
 

 Пример:
 
 60,79, 82, 58, 39, 9, 54, 92, 44, 32
 60,79, 82, 58, 39, 9, 54, 92, 44, 32
 9,79, 82, 58, 39, 60, 54, 92, 44, 32
 9,79, 82, 58, 39, 60, 54, 92, 44, 32
 9, 32, 82, 58, 39, 60, 54, 92, 44, 79
 9, 32, 44, 58, 39, 60, 54, 92, 82, 79
 9, 32, 44, 58, 39, 54, 60, 92, 82, 79
 9, 32, 44, 58, 39, 92, 60, 54, 82, 79
 9, 32, 44, 58, 39, 54, 60, 79, 82, 92
 9, 32, 44, 58, 54, 39, 60, 79, 82, 92
 9, 32, 44, 58, 60, 39, 54, 79, 82, 92
 9, 32, 44, 58, 54, 39, 60, 79, 82, 92
 9, 32, 44, 58, 54, 39, 60, 79, 82, 92
 9, 32, 44, 58, 54, 39, 60, 79, 82, 92
 9, 32, 39, 58, 54, 44, 60, 79, 82, 92
 9, 32, 39, 58, 54, 44, 60, 79, 82, 92
 9, 32, 39, 44, 54, 58, 60, 79, 82, 92
 9, 32, 39, 44, 58, 54, 60, 79, 82, 92
 9, 32, 39, 44, 54, 58, 60, 79, 82, 92
 9, 32, 39, 44, 54, 58, 60, 79, 92, 82
 9, 32, 39, 44, 54, 58, 60, 79, 82, 92
 

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

Самая сомнительная черта вышеприведенной программы состоит в том, что она очень мало эффективна на простых подфайлах. Например, если файл уже сортирован, то разделы будут вырожденными, и программа просто вызовет сама себя N раз, каждый раз с меньшим на од ин элемент подфайлом. Это означает, что не только производительность программы упадет примерно до N2/2, но и пространство необходимое для ее работы будет около N (смотри ниже), что неприемлемо. К счастью, есть довольно простые способы сделать так, чтобы т акой "худший" случай не произошел при практическом использовании программы.

Когда в файле присутствуют одинаковые ключи, то возникает еще два сомнительных вопроса. Первое, должны ли оба указателя останавливаться на ключах равных делящему элементу или останавливать только один из них, а второй будет проходить их все, или оба указа теля должны проходить над ними. На самом деле, этот вопрос детально изучался, и результаты показали, что самое лучшее - это останавливать оба указателя. Это позволяет удерживать более или менее сбалансированные разделы в присутствии многих одинаковых ключ ей. На самом деле, эта программа может быть слегка улучшена терминированием сканирования j<i, и использованием после этого quicksort(l, j) для первого рекурсивного вызова.

Характеристики Производительности Быстрой Сортировки

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

CN = 2CN/2+N - наилучший случай.

(2CN/2 покрывает расходы по сортировке двух полученных подфайлов; N - это стоимость обработки каждого элемента, используя один или другой указатель.) Нам известно также, что примерное значение этого выражения равно CN = N lg N.

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

Свойство 1 Быстрая сортировка в среднем использует 2N ln N сравнений.

Методы улучшения быстрой сортировки.

1. Небольшие Подфайлы.

Первое улучшение в алгоритме быстрой сортировки возникает из наблюдения, что программа гарантировано вызывает себя для огромного количества небольших подфайлов, поэтому следует использовать самый лучший метод сортировки когда мы встречаем небольшой подфай л. Очевидный способ добиться этого, это изменить проверку в начале рекурсивной функции из "if r>l then" на вызов сортировки вставкой (соответственно измененной для восприятия границ сортируемого подфайла): "if r-l<=M then insertion(l, r)." Значение для M не обязано быть "самым-самым" лучшим: алгоритм работает примерно одинаково для M от 5 до 25. Время работы программы при этом снижается примерно на 20% для большинства программ.

При небольших подфайлах (5- 25 элементов) быстрая сортировка очень много раз вызывает сама себя (в наше примере для 10 элементов она вызвала сама себя 15 раз), поэтому следует применять не быструю сортировку, а сортировку вставкой.


 procedure QuickSort (l,t:integer);
 var
   i:integer;
 begin
   if t-l>m then
     begin
       i:=part(l,t);
       QuickSort (l,i-1);
       QuickSort (i+1,t);
     end
   Else
     Insert(l,t);
 end;
 

2. Деление по Медиане из Трех

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

Более полезное улучшение состоит в том, чтобы взять из файла три элемента, и затем использовать среднее из них в качестве делящего элемента. Если элементы взяты из начала, середины, и конца файла, то можно избежать использования сторожевых элементов: сорт ируем взятые три элемента, затем обмениваем центральный элемент с a[r-1], и затем используем алгоритм деления на массиве a[l+1..r-2]. Это улучшение называется делением по медиане из трех.

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


 procedure exchange(i,j:integer);
 var
   k:integer;
 begin
   k:=a[i];
   a[i]:=a[j];
   a[j]:=k;
 end;
 
 procedure Mediana;
 var i:integer;
 begin
   i:=n div 4;{Рис.}
   if a[i]>a[i*2] then
     if a[i]>a[i*3] then
       exchange(i,n)
     else
       exchange(i*3,n)
   else
     if a[i*2]>a[i*3] then
       exchange(i*2,n);
   quicksort(1,n);
 end;
 

3. Нерекурсивная реализация.

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

Комбинация нерекурсивной реализации деления по медиане из трех с отсечением на небольшие файлы может улучшить время работы алгоритма от 25% до 30%.

Итак, на сегодняшнем занятии мы рассмотрели алгоритм быстрой сортировки.

Слияние

На сегодняшнем занятии мы начнем рассмотрении темы внешняя сортировка.

Внешняя сортировка сортирует файлы, которые не помещаются целиком в оперативную память.

Внешняя сортировка сильно отличается от внутренней. Дело в том, что доступ к файлу является последовательным, а не параллельным как это было в массиве. И поэтому считывать файл можно только блоками и этот блок отсортировать в памяти и снова записать в фай л.

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

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

Слияние - намного более простая операция, чем сортировка.

Мы рассмотрим 2 алгоритма слияния:

Прямое слияние. Алгоритм Боуза - Нельсона Естественное (Неймановское) слияние.
Прямое слияние. Алгоритм Боуза - Нельсона Последовательность а разбивается на две половины b и с.

Последовательности b и с сливаются при помощи объединения отдельных элементов в упорядоченные пары.

Полученной последовательности присваивается имя а, после чего повторяются шаги 1 и 2; при этом упорядоченные пары сливаются в упорядоченные четверки.

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

Пример

 Исходная последовательность
 
 А = 44 55 12 42 94 18 06 67
 
 1
 
 b = 44 55 12 42
 с = 94 18 06 67
 а = 44 94' 18 55' 06 12' 42 67
 
 2
 
 b = 44 94' 18 55'
 с =06 12' 42 67
 а = 06 12 44 94' 18 42 55 67'
 
 3
 
 b = 06 12 44 94'
 с = 18 42 55 67'
 а = 06 12 18 42 44 55 67 94
 

Операция, которая однократно обрабатывает всё множество данных, называется фазой.

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

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

Главным минусом сортировки слиянием является удвоение размера памяти, первоначально занятой сортируемыми данными. Рассмотрим алгоритм с рекурсивным актом слияния, предложенный Боузом и Нельсоном и не требующий резерва памяти.

Он основан на очевидной идее: слить две равные упорядоченные части можно слиянием их начальных половин, слиянием конечных и слиянием 2-й половины 1-го результата с 1-й половиной 2-го результата, например:

Если части не равны или не делятся точно пополам, процедуру уточняют надлежащим образом. Аналогично слияние "половинок" можно свести к слиянию "четвертушек", "восьмушек" и т. д.; имеет место рекурсия.


 Const n=200;
 
 Type
 tipkl=word;
 tip = Record
 kl: tipkl;
 z:Array[1..50] of real
 End;
 
 Var
 A: Array[1..n] of tip;
 j:word;
 
 Procedure Bose (Var AA; voz:Boolean);
 Var
 m,j:word; x:tip; {tip - тип сортируемых записей}
 A: Array [1..65520 div Sizeof(tip)] of tip Absolute AA;
 Procedure Sli(j,r,m: word); { r - расстояние между началами
 сливаемых частей, а m - их размер, j - наименьший номер записи}
 Begin
 if j+r<=n Then
 If m=1 Then
 Begin
 If voz Xor (A[j].kl < A[j+r].kl) Then
 Begin
 x:=A[j];
 A[j]:= A[j+r];
 A[j+r]:=x
 End
 End
 Else
 Begin
 m:=m div 2;
 Sli(j,r,m); {Слияние "начал"}
 If j+r+m<=n Then
 Sli(j+m,r,m); {Слияние "концов"}
 Sli(j+m,r-m,m) End {Слияние в центральной части}
 End{блока Sli};
 Begin
 m:=1;
 Repeat
 j:=1; {Цикл слияния списков равного размера: }
 While j+m<=n do
 Begin
 Sli(j,m,m);
 j:=j+m+m
 End;
 m:=m+m {Удвоение размера списка перед началом нового прохода}
 Until m >= n {Конец цикла, реализующего все дерево слияний}
 End{блока Bose};
 BEGIN
 Randomize;
 For j:=1 to n do
 begin
 A[j].kl:= Random(65535);
 Write(A[j].kl:8);
 end;
 Readln;
 Bose(A,true);
 For j:=1 to n do
 Write(A[j].kl:8);
 Readln
 END.
 
 

Естественное (Неймановское) слияние.

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

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

Пример:

 Пусть даны ключи записей
 
 5    7    8    3    9     4    1    7    6
 

Ищем подсписки

В один общий список соединяются 1-й, 3-й, 5-й и т. д. подсписки, в другой - 2-й, 4-й и т. д. подсписки.

Произведем слияние 1 подсписка 1 списка и 1 подсписка 2 списка, 2 подсписка 1 списка и 2 подсписка 2 списка и т.д.

 Будут получены следующие цепи
 
 3 --> 5 --> 7 --> 8 --> 9 и 1 --> 4 --> 7
 

Подсписок, состоящий из записи "6", пары не имеет и "принудительно" объединяется с последней цепью, принимающей вид 1 --> 4--> 6 --> 7.

При нашем небольшом числе записей 2-й этап, на котором сливаются две цепи, окажется последним.

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

Для программной реализации заводят массив sp: элемент sp[i] - это номер записи, которая следует за i-й.

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


 Repeat {Повторение актов слияний подсписков}
 If A[j].kl < A[i].kl Then {Выбирается меньшая запись}
 Begin sp[k]:=j; k:=j; j:=sp[j];
 If j<=0 Then {Сцепление с остатком "i"-подсписка}
 Begin sp[k]:=i; Repeat m:=i; i:=sp[i] Until i<=0 End
 End
 Else
 Begin sp[k]:=i; k:=i; i:=sp[i];
 If i<=0 Then {Сцепление с остатком "j"-подсписка}
 Begin sp[k]:=j; Repeat m:=j; j:=sp[j] Until j<=0 End
 End;
 If j<=0 Then Begin sp[m]:= 0; sp[p]:=-sp[p]; i:=-i;
 j:=-j; If j<>0 Then p:=r; k:=r; r:=m End
 Until j=0;
 
 

{В конец сформированного подсписка всегда заносится нулевая ссылка (sp[m]:= 0), ибо он может оказаться последним.

Действие sp[p]:= -sp[p] обозначает минусом конец ранее построенного подсписка.

В переменных i,j ссылки на начала новых сливаемых подсписков - со знаком минус; его снимаем. Переход к новым подспискам требует обновления переменных p, k, r}

Итак, на сегодняшнем занятии мы рассмотрели алгоритмы слияния.




Группа радиокнопок и ActiveControl

Автор: Ralph Friedman

На форме я имею группу радиокнопок. Я хотел бы вызывать контекстно-зависимую подсказку, если пользователь нажал F1. Для данной конкретной группы радиокнопок я установил HelpContext равным 22, но при любом вызове ActiveControl.HelpContext это возвращает (0). Все другие элементы управления работают как положено. Что я делаю неправильно?

Нет. Проблема в том, что ActiveControl - RadioButton, а не RadioButtonGroup. Поместите следующий код в обработчик события формы OnShow, он должен решить вашу проблему:


 procedure TForm1.FormShow(Sender: TObject);
 var
   c: integer;
 begin
   with RadioGroup1 do
   begin
     for c := 0 to ControlCount - 1 do
       TRadioButton(Controls[c]).HelpContext := HelpContext;
   end;
 end;
 




Readln для более чем 255 символов

Построили новый полностью роботизированный завод. Идет экскурсия по цехам. Экскурсовод:
- Внимание, господа, в этом цехе все роботы управаляются операцинной системой MS-DOS.
Посмотрели, идут дальше.
- В этом цехе все роботы работают под управлением операционной системы Unix.
Посмотрели, идут дальше.
- Вот в этом цехе все роботы работают под управлением операционной системы QNX.
Проходят в след. цех.
- А в этом цехе все роботы управляются операционной системой Microsoft Windows'98. Всем присутствующим просьба надеть защитные каски.

ReadLn акцептует массив символов array [0..something] of Char и использует его в качестве буфера для чтения символов, замыкая цепочку терминирующим нулем. Единственное ограничение: компилятор должен иметь возможность вычисления размера буфера во время компиляции, что делает невозможным объявление переменой типа PChar и ее распределение во время выполнения программы.

Обходной путь:


 type
   {используем самое большое количество символов в
   строке, с которым вы можете иметь дело}
   TLine = array[0..1024] of Char;
   PLine = ^TLine;
 
 var
   pBuf: PLine;
   ...
 
   New(pBuf);
   ...
 
   ReadLn(F, pBuf^);
 

Для передачи pBuf функциям, которым требуется параметр типа Pchar, используйте приведение типа подобно PChar( pBuf ).

Примечание: вы, конечно, можете использовать объявление переменной типа TLine или непосредственно массив символов, но я предпочитаю распределять из кучи нечто большее, чем 4 байта...




Читаем файл Access используя ADO


 // Читаем файл (любой версии) 
 // Проверяем что это ACCESS MDB 
 // Нужны компаненты: 
 // TADOtable,TDataSource,TOpenDialog,TDBGrid,TBitBtn. 
 unit uMain;
 
 interface
 
 uses
 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
 Db, DBTables, ADODB, Grids, DBGrids, ExtCtrls, DBCtrls, StdCtrls, Buttons;
 
 type
   TfrmMain = class(TForm)
     DSUsers: TDataSource;
     DBGridUsers: TDBGrid;
     BitBtn1: TBitBtn;
     OpenDialog1: TOpenDialog;
     TUsers: TADOTable;
     procedure FormCreate(Sender: TObject);
     procedure ValidateAccessDB;
     function CheckIfAccessDB(lDBPathName: string): boolean;
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 var
   frmMain: TfrmMain;
 const
   DBNAME = 'ADODemo.MDB';
   DBPASSWORD = '123'; // Access DB Password Protected 
 
 implementation
 
 {$R *.DFM}
 
 procedure TfrmMain.FormCreate(Sender: TObject);
 begin
   validateAccessDB;
 end;
 
 procedure TfrmMain.ValidateAccessDB;
 var
   lDBpathName : String;
   lDBcheck : boolean;
 begin
   if FileExists(ExtractFileDir(Application.ExeName) + '\' + DBNAME) then
     lDBPathName := ExtractFileDir(Application.ExeName) + '\' + DBNAME
   else if OpenDialog1.Execute then
     // Set the OpenDialog Filter for ADOdemo.mdb only 
     lDBPathName := OpenDialog1.FileName;
 
   lDBCheck := False;
   if Trim(lDBPathName) <> '' then
     lDBCheck := CheckIfAccessDB(lDBPathName);
 
   if lDBCheck = True then
   begin
     // ADO Connection String to the MS-ACCESS DB 
     TUsers.ConnectionString :=
       'Provider=Microsoft.Jet.OLEDB.4.0;' +
       'Data Source=' + lDBPathName + ';' +
       'Persist Security Info=False;' +
       'Jet OLEDB:Database Password=' + DBPASSWORD;
     TUsers.TableName := 'Users';
     TUsers.Active := True;
   end
   else
     frmMain.Free;
 end;
 
 // Check if it is a valid ACCESS DB File Before opening it. 
 
 function TfrmMain.CheckIfAccessDB(lDBPathName: string): Boolean;
 var
   UnTypedFile: file of byte;
   Buffer: array[0..19] of byte;
   NumRecsRead: Integer;
   i: Integer;
   MyString: string;
 begin
   AssignFile(UnTypedFile, lDBPathName);
   reset(UnTypedFile);
   BlockRead(UnTypedFile, Buffer, High(Buffer), NumRecsRead);
   CloseFile(UnTypedFile);
   for i := 1 to High(Buffer) do
     MyString := MyString + Trim(Chr(Ord(Buffer[i])));
   Result := False;
   if Mystring = 'StandardJetDB' then
     Result := True;
   if Result = False then
     MessageDlg('Invalid Access Database', mtInformation, [mbOK], 0);
 end;
 end.
 




Читаем Adobe Acrobat PDF файлы из нашего приложения

Adobe Acrobat PDF - хорошо извесный формат, который нравится многим пользователям. Давайте посмотрим, как можно заставить приложение на Delphi прочитать файл такого формата.

Итак, Вы должны быть уверены, что у вас проинсталлирован Acrobat Reader, елси таковой программы нет, то её можно скачать с http://www.adobe.com

После этого необходимо проинсталировать типовую библиотеку для Acrobat (Project -> Import Type Library из меню Delphi) выберите "Acrobat Control for ActiveX (version x)". Где x - текущая версия библиотеки. Нажмите кнопку инсталяции.

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


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   if OpenDialog1.Execute then
     pdf1.src := OpenDialog1.FileName;
 end;
 

в юните PdfLib_TLB вы можете найти интерфейс класса TPdf:


 TPdf = class(TOleControl)
   private
     FIntf: _DPdf;
     function GetControlInterface: _DPdf;
   protected
     procedure CreateControl;
     procedure InitControlData; override;
   public
     function LoadFile(const fileName: WideString): WordBool;
     procedure setShowToolbar(On_: WordBool);
     procedure gotoFirstPage;
     procedure gotoLastPage;
     procedure gotoNextPage;
     procedure gotoPreviousPage;
     procedure setCurrentPage(n: Integer);
     procedure goForwardStack;
     procedure goBackwardStack;
     procedure setPageMode(const pageMode: WideString);
     procedure setLayoutMode(const layoutMode: WideString);
     procedure setNamedDest(const namedDest: WideString);
     procedure Print;
     procedure printWithDialog;
     procedure setZoom(percent: Single);
     procedure setZoomScroll(percent: Single; left: Single; top: Single);
     procedure setView(const viewMode: WideString);
     procedure setViewScroll(const viewMode: WideString; offset: Single);
     procedure setViewRect(left: Single; top: Single; width: Single; height: Single);
     procedure printPages(from: Integer; to_: Integer);
     procedure printPagesFit(from: Integer; to_: Integer; shrinkToFit: WordBool);
     procedure printAll;
     procedure printAllFit(shrinkToFit: WordBool);
     procedure setShowScrollbars(On_: WordBool);
     procedure AboutBox;
     property ControlInterface: _DPdf read GetControlInterface;
     property DefaultInterface: _DPdf read GetControlInterface;
   published
     property TabStop;
     property Align;
     property DragCursor;
     property DragMode;
     property ParentShowHint;
     property PopupMenu;
     property ShowHint;
     property TabOrder;
     property Visible;
     property OnDragDrop;
     property OnDragOver;
     property OnEndDrag;
     property OnEnter;
     property OnExit;
     property OnStartDrag;
     property src: WideString index 1 read GetWideStringProp write SetWideStringProp stored False;
 end;
 

в заключение можно добавить следующее:

Если Вы не уверены, что у конечного пользователя Вашей программы установлен Acrobat Reader, то необходимо, чтобы приложение проверяло эту ситуацию, прежде чем будут производится различные манипуляции с компонентой TPdf. И второе, если файл PDF имеет различные связи, например с AVI файлами, то они не будут работать из Delphi.

Надеюсь этот пример будет Вам полезен.




Чтение бинарного файла


 var
   f: File;
   c: Char;
 begin
   AssignFile(f, 'this.bin');
   Reset(f, 1);
   BlockRead(f, c, sizeof(c));
   CloseFile(f);
 end;
 


 function FindInFile(cFileName: string; cCh: char): boolean;
 var
   fFile: file;
   aBuf: array[1..1024] of char;
   lFound: boolean;
   x, nRead: integer;
 begin
   Assign(fFile, cFileName);
   Reset(fFile, 1);
   lFound := False;
   repeat
     BlockRead(fFile, aBuf, SizeOf(aBuf), nRead);
     x := 1;
     while not lFound and (x <= nRead) do
     begin
       lFound := (aBuf[x] = cCh)
         Inc(x)
     end;
   until
     (nRead < SizeOf(aBuf)) or lFound;
   FindInFile := lFound
 end;
 

Взгляните на следующий код:


 var
   f: file;
   c: Char;
 begin
   AssignFile(f, 'c:\autoexec.bat');
   Reset(f, 1);                        <- Примечание: Размер записи = 1 байту это нормально!
   while not Eof(f) do
   begin
     BlockRead(f, c, SizeOf(c));
     {Теперь обрабатываем c}
   end;
   CloseFile(f);
 end;
 

Для ускорения этой процедуры не следует за один проход читать по одному символу. Возможно, лучшим решением будет объявление PChar скажем, размером 200, и чтением за один проход блоков размером 200 байт. {например, BlockRead(f, p, 200);} Но для этого требуется немного больше кода, чем показано здесь... (Используйте все тот же recordsize, равный 1, меняется только blocksize).




Как прочитать байт из параллельного порта

Как объяснить тупому, что такое бит? Элементарно - это байт минус налоги. Как объяснить тупому, что такое байт? Элементарно - объясните ему 8 раз, что такое бит. Что такое килобайт? Это слишком долго рассказывать...


 var
   BytesRead: BYTE;
 begin
   asm { Читаем порт (LPT1) через встроенный ассемблер }
     MOV dx,$379;
     in al,dx;
     MOV BytesRead,al;
   end;
   BytesRead := (BytesRead or $07); { OR а затем XOR данных }
   BytesRead := (BytesRead xor $80); { маскируем неиспользуемые биты }
 end;
 




Как прочитать байт из параллельного порта 2

Используем команды Turbo Pascal ...


 value:=port[$379]; { Прочитать из порта }
 port[$379]:=value; { Записать в порт }
 




Чтение сложных OLE-документов

Автор: John Lam

Не используйте для этого компонент TOleContainer. Создавая приложение с возможностью доступа к файлам OLE Structured Storage (стуктурное хранилище), реально необходима только пара вызовов OLE API, и 5-6 вызовов API для доступа к функциям-членам интерфейсов IStorage, IRootStorage и IStream. Я подозреваю, что функция-член TOleContainer IStorage является указателем на корневое хранилище файла Structured Storage, создаваемого функциями-членами LoadFromFile/SaveToFile TOleContainer.

Необходимые функции API:

StgOpenStorage
StgIsStorageFile

Если у вас есть OLE 2.01 SDK, вы можете найти определения там.

Будьте внимательны, при переносе заголовочных файлов C++ из OLE SDK в Delphi, Borland допустил несколько ошибок. Одна из ошибок при создании апплета обернулась мне тремя бессонными ночами. Вот правильное определение IStorage:


 MyIStorage = class(IUnknown)
 function CreateStream(const pwcsName: PChar; grfMode: Longint; reserved1: Longint;
 reserved2: Longint; var ppstm: IStream): HResult; virtual; cdecl; export; abstract;
 function OpenStream(const pwcsName: PChar; reserved1: Pointer; grfMode: Longint;
 reserved2: Longint; var ppstm: IStream): HResult; virtual; cdecl; export; abstract;
 function CreateStorage(const pwcsName: PChar; grfMode: Longint;
 reserved1: Longint; reserved2: Longint; var ppstg: MyIStorage): HResult;
 virtual; cdecl; export; abstract;
 function OpenStorage(const pwcsName: PChar; pstgPriority: MyIStorage;
 grfMode: Longint; snbExclude: PStr; reserved: Longint;
 var ppstg: MyIStorage): HResult; virtual; cdecl; export; abstract;
 function CopyTo(ciidExclude: Longint; const rgiidExclude: IID;
 var snbExclude: PStr; pstgDest: MyIStorage): HResult; virtual; cdecl; export; abstract;
 function MoveElementTo(const lpszName: PChar; pstgDest: MyIStorage;
 const lpszNewName: PChar; grfFlags: Longint): HResult; virtual; cdecl; export; abstract;
 function Commit(grfCommitFlags: Longint): HResult; virtual; cdecl; export; abstract;
 function Revert: HResult; virtual; cdecl; export; abstract;
 function EnumElements(reserved1: Longint; reserved2: Pointer; reserved3: Longint;
 var ppenm: IEnumStatStg): HResult; virtual; cdecl; export; abstract;
 function DestroyElement(const pwcsName: PChar): HResult; virtual; cdecl; export; abstract;
 function RenameElement(const pwcsOldName: PChar;
 const pwcsNewName: PChar): HResult; virtual; cdecl; export; abstract;
 function SetElementTimes(const lpszName: PChar; const pctime: TFileTime;
 const patime: TFileTime; const pmtime: TFileTime): HResult;
 virtual; cdecl; export; abstract;
 function SetClass(const clsid: IID): HResult; virtual; cdecl; export; abstract;
 function SetStateBits(grfStateBits: Longint; grfMask: Longint): HResult;
 virtual; cdecl; export; abstract;
 function Stat(var pstatstg: TStatStg; grfStatFlag: Longint): HResult;
 virtual; cdecl; export; abstract;
 end;
 

Проблема заключалась в том, что некоторые параметры неправильно были объявлены как VAR, тогда как в действительности они объявлены как CONST - это важно, поскольку иногда функции-члены интерфейса ожидают параметры со значением, равным NIL.

Надеюсь, это поможет.




Прочесть текстовый файл DOS

Лозунг компании Microsoft на презентации Windows ME: "ДОС - НАФИГ!"

Если попытаться открыть текст, написанный в DOS, не меняя свойство Charset, то получится набор непонятных символов. Например в Windows символ с кодом 174 - это значок "®", а в DOS это обычная "о". Свойство Charset, установленное в OEM_CHARSET, заставляет выводить именно "о", если код символа 174. Эта программа читает файлы DOS.


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   Memo1.Font.Charset := OEM_CHARSET;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   if OpenDialog1.Execute then
     Memo1.Lines.LoadFromFile(OpenDialog1.FileName)
 end;
 




Считать данные из ячеек Excel

Автор: Rusher


 var
  Excel: variant;
   i, j: word;
      S: string;
 begin
      Excel := CreateOleObject('Excel.Application');
      Excel.Workbooks.Open(FileName);
      Excel.Visible:=True;
      for i := 1 to 5 do
        for j := 1 to 5 do
         begin
           S := Excel.Sheets[1].Cells[i,j].Text;
           ShowMessage(S);
         end;
 end;
 




Как прочесть атрибут файла Last Accessed (последний доступ)


 procedure TForm1.Button1Click(Sender: TObject);
 var
   FileHandle: THandle;
   LocalFileTime: TFileTime;
   DosFileTime: DWORD;
   LastAccessedTime: TDateTime;
   FindData: TWin32FindData;
 begin
   FileHandle := FindFirstFile('AnyFile.FIL', FindData);
   if FileHandle <> INVALID_HANDLE_VALUE then
   begin
     Windows.FindClose(Handle);
     if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then
     begin
       FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime);
       FileTimeToDosDateTime(LocalFileTime,
         LongRec(DosFileTime).Hi, LongRec(DosFileTime).Lo);
       LastAccessedTime := FileDateToDateTime(DosFileTime);
       Label1.Caption := DateTimeToStr(LastAccessedTime);
     end;
   end;
 end;
 




Чтение из файла длинной строки

Автор: LazyMan

Для решения этой задачи на помощь можно призвать потоки (TFileStream, TMemoryStream). Для поиска конца строк нужно искать пары CR/LF, но это делается очень легко, приблизительно так (я сегодня вечером слишком ленивый для реального кода):


 Start := Stream.Position;
 End := Start;
 Repeat
 
 Stream.Read(Buffer^, 1024);
 CRPos := FindCR(Buffer^);   { где FindCR возвращает 0..1023 для CR,
 и 1024, если он не найден}
 Inc(End, CRPos);
 Until CRPos < 1024;
 GetMem(MyPChar, End - Start);  { Здесь может быть +-1 -- мне лень сегодня проверять! }
 Stream.Seek(Start);
 Stream.Read(MyPChar^, End - Start)
 

Затем установите CR в конце MyPChar в 0, и сделайте Seek в конец (End + 1), или что-то еще, чтобы пропустить LF.




Как прочитать из модема

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

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


 var
   PortSpec : array[0..255] of char;
   PortNo : Word;
   success : Boolean;
   error:integer;
 begin
   FillChar(PortSpec,Sizeof(PortSpec),#0);
   StrPCopy(PortSpec,'Com1:19200,n,8,1');
   PortSpec[3]:=Char(Ord(PortSpec[3])+Ord(PortNo));
 
   if not BuildCommDCB(PortSpec,Mode) then
   begin
     //какая-то ошибка...
     Exit;
   end;
 
   PortSpec[5]:=#0; { 'Com1:' }
 
   Mode.Flags:=EV_RXCHAR + EV_EVENT2; { $1001 }
 
   Com := CreateFile(PortSpec,GENERIC_READ or GENERIC_WRITE,
   0,             { comm устройство открывается с эксклюзивным доступом }
   nil,           { нет security битов }
   OPEN_EXISTING, { comm устройства должны использовать OPEN_EXISTING }
   0,             { not overlapped I/O }
   0              { hTemplate должен быть NULL для comm устройств }
   );
 
   if Com = INVALID_HANDLE_VALUE then
     Error := GetLastError;
   Success := GetCommState(Com,Mode);
 
   if not Success then // Обработчик ошибки.
   begin
   end;
 
   Mode.BaudRate := 19200;
   Mode.ByteSize := 8;
   Mode.Parity := NOPARITY;
   Mode.StopBits := ONESTOPBIT;//нужен был для перезаписи в NT
 
   Success := SetCommState(Com, Mode);
 
   if not Success then // Обработчик ошибки.
   begin
   end;
 end;
 

Переменная "com" типа dword.

Вы так же можете очистить буффер COM порта


 PurgeComm(Com, PURGE_RXCLEAR or PURGE_TXCLEAR);
 

И прочитать из него


 function ReadCh(var Ch: Byte): dword;
 var
   n: dword;
 begin
   Readfile(Com, ch, 1, result, nil);
 end;
 




Читаем из файла, открытого другим приложением

Даже если файл открыт с низкими привелегиями (используя ReadOnly, ShareReadWrite) , иногда открытие уже открытого файла может приводить к ошибкам, особенно, если это файл интенсивно используется другим приложением. Самый простой способ решить эту проблемму - это использовать MemoryStream вместо непосредственного доступа к файлу:


 var
   Memory: TMemoryStream;
 begin
   Memory := TMemoryStream.Create;
   try
     Memory.LoadFromFile('DelphiWorld.dat'); // это он!!
     ...
     Memory.read(...); // Вы можете использовать методы чтения как у файлов
     Memory.Seek(...);
     FileSize := Memory.Size;
     ...
   finally
     Memory.Free;
   end;
 end;
 

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




Чтение OLE из Blob поля Paradox

Автор: Eryk

...после моих дискуссий с людьми из службы технической поддержки Borland вывод один -- это невозможно!

Попробуйте так:


 procedure TForm1.SpeedButton1Click(Sender: TObject);
 var
   b: TBlobStream;
 begin
   try
     b := TBlobStream.Create((Table1.FieldByName('OLE') as TBlobField),bmRead);
     OLEContainer1.LoadFromStream(b);
   finally
     b.free;
   end;
 end;
 

...и:


 procedure TForm1.SpeedButton2Click(Sender: TObject);
 var
   b: TBlobStream;
 begin
   try
     Table1.Insert;
     b := TBlobstream.Create((Table1.FieldByName('OLE') as TBlobField),bmReadWrite);
     OLEContainer1.SaveToStream(b);
     Table1.Post;
   finally
     b.free;
   end;
 end;
 

Я, кажется, припоминаю несколько ошибок GPFs с этим кодом, но это, вероятно, связано с тем, что я использую WinNT с другим распределением памяти... тем не менее, основные функции работали как положено (т.е. данные сохранялись и загружались). Основная специфика проявилась в том, что PdoxWIN не смог прочесть данные TOLEContainer. Но это результаты моих экспериментов и предположений, исходя из которых PdoxWIN ожидает 8-байтовый заголовок BLOB-поля, который ему просто не дает TOLEContainer... если это так, то это легко обойти.




Установка атрибута Только для чтения у столбцов компонента StringGrid

Сидят двое программистов в кафе и, натурально, пьют пиво. Мимо проходит такая девушка, вся из себя девушка. Один программист другому:
- Ты посмотри какие propertes!!!
Другой:
- Вчера проверял, все read only.

Манипулирование вышеуказанным атрибутом возможно в обработчике события OnSelectCell:


 if Col mod 2 = 0 then
   grd.Options := grd.Options + [goEditing]
 else
   grd.Options := grd.Options - [goEditing];
 




Чтение текста RichEdit из базы данных

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

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


 procedure ReadRichEditFromTable(Table : TTable; var RichEdit : TRichEdit);
 var
   BlobStream: TBlobStream;
 begin
   try
     BlobStream := TBlobStream.Create(Table.FieldByName('BODY') as TBlobField, bmRead);
     if (not Table.FieldByName('BLOBFieldName').IsNull) then
     begin
       RichEdit.Lines.LoadFromStream (BlobStream);
     end;
   finally
     BlobStream.Free;
   end;
 end;
 




Как прочитать русский текст MS-DOS

- Почему не было Windows 96?
- Очень похоже на 69.

Для перекодировки из Win(1251) кодовой страницы в Dos(866) кодовую страницу и обратно используются функции:

  • CharToOEM
  • OEMToChar
  • CharToOEMBuff
  • OEMToCharBuff
  • OemToAnsi
  • AnsiToOem:

Пример чтения текста dos из файла в memo


 procedure TForm1.FormCreate(Sender: TObject);
 var
   N: PChar;
 begin
   memo1.Lines.LoadFromFile('c:\file.txt');
   N := Memo1.Lines.GetText;
   OemToAnsi(N, N);
   Memo1.Lines.Text := StrPas(N);
 end;
 




Как прочитать русский текст MS-DOS 2

Hам не заменят ДОС'а пpостоту заманчивые окны пополамов!


 procedure TForm1.FormCreate(Sender: TObject);
 var
   i, j: integer;
   s: string;
   c: set of char;
 begin
   c := ['А'..'Я', 'а'..'я'];
   memo1.Lines.LoadFromFile('c:\11.txt');
   for i:=0 to memo1.Lines.Count do
   begin
     s:=memo1.Lines.Strings[i];
     for j:=1 to length(s) do
       if chr(ord(S[j])+64) in c then
         s[j]:=chr(ord(S[j])+64);
     memo1.Lines.Strings[i]:=s;
   end;
 end;
 




Как прочитать русский текст MS-DOS 3

- У меня проблема с ДОСОМ!
- Что, компьютер не запускается?
- Нет. Дасморк.

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


 const
   ConvertSet: array[0..255] of byte =
   {таблица перекодировки ASCII с альтернативной кодовой страницой 866 в
   WIN 1251. Украинские символы - по кодовой таблице PRINTFXU. Непечатные
   символы заменяются пробелами}
   {основная таблица}
   { 00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F }
   {00} ( 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32,
   {10} 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32,
   {20} 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47,
   {30} 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63,
   {40} 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79,
   {50} 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95,
   {60} 96, 97, 98, 99,100,101,102,103,104,105,106,107,108,109,110,111,
   {70} 112,113,114,115,116,117,118,119,120,121,122,123,124,125,126,127,
   {дополнительная таблица}
   {80} 192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,
   {90} 208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,
   {A0} 224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,
   {B0} 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32,
   {C0} 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32,
   {B0} 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32,
   {E0} 240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,
   {F0} 168,184,178,179, 32, 32,175,191,170,186, 32,177,185, 32, 32, 32);
 
 var
   TextString : string[250];
   TextTmpArr : array[0..250] of byte absolute TextString;
   WinString : string[250];
   WinTmpArr : array[0..250] of byte absolute WinString;
 
   DosFile : Text;
   TextFName : string;
   TextFDir : string;
   WinFName : string;
 
 procedure TMainFm.ConvertFile;
 var
   I: Integer;
 begin
   AssignFile(DosFile,TextFName);
   ReSet(DosFile);
   while not(EOF(DosFile)) do
   begin
     ReadLn(DosFile,TextString);
     WinTmpArr[0] := TextTmpArr[0];
     for I := 1 to TextTmpArr[0] do
       WinTmpArr[I] := ConvertSet[TextTmpArr[I]];
     Memo.Lines.Add(WinString);
   end;
 end;
 




Как прочитать русский текст MS-DOS 4

"Компьютерщики" - это такие люди, у которых слова "вчера с матерью трахался" вызывают не возмущение, а сочувствие.


 function ConvertAnsiToOem(const S: string): string;
 { ConvertAnsiToOem translates a string into the OEM-defined character set }
 {$IFNDEF WIN32}
 var
   Source, Dest : array[0..255] of Char;
 {$ENDIF}
 begin
   {$IFDEF WIN32}
   SetLength(Result, Length(S));
   if Length(Result) > 0 then
     AnsiToOem(PChar(S), PChar(Result));
   {$ELSE}
   if Length(Result) > 0 then
   begin
     AnsiToOem(StrPCopy(Source, S), Dest);
     Result := StrPas(Dest);
   end;
   {$ENDIF}
 end; { ConvertAnsiToOem }
 
 function ConvertOemToAnsi(const S: string): string;
 { ConvertOemToAnsi translates a string from the OEM-defined
 character set into either an ANSI or a wide-character string }
 {$IFNDEF WIN32}
 var
   Source, Dest : array[0..255] of Char;
 {$ENDIF}
 begin
   {$IFDEF WIN32}
   SetLength(Result, Length(S));
   if Length(Result) > 0 then
     OemToAnsi(PChar(S), PChar(Result));
   {$ELSE}
   if Length(Result) > 0 then
   begin
     OemToAnsi(StrPCopy(Source, S), Dest);
     Result := StrPas(Dest);
   end;
   {$ENDIF}
 end; { ConvertOemToAnsi }
 




Запись и чтение чисел в Blob-поле

Автор: Ralph Friedman

Болтают трое молодых программистов о жизни. Двое холостых и один женатый.
- Зря вы говорите, что жениться sux, вот я жене на домашнем компе права админа дал!

Мне нужно записать серию чисел в файл Paradox в blob-поле. Числа получаются из значений компонент, размещенных на форме. Затем мне нужно будет считывать числа из blob-поля и устанавливать согласно им значения компонент. Как мне сделать это?

Вы можете начать свое исследование со следующего модуля:


 unit BlobFld;
 
 interface
 
 uses
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls, Buttons, DBTables, DB, ExtCtrls, DBCtrls,
   Grids, DBGrids;
 
 type
   TFrmBlobFld = class(TForm)
     BtnWrite: TBitBtn;
     Table1: TTable;
     DataSource1: TDataSource;
     DBNavigator1: TDBNavigator;
     LbxDisplayBlob: TListBox;
     Table1pubid: TIntegerField;
     Table1comments: TMemoField;
     Table1UpdateTime: TTimeField;
     Table1Real1: TFloatField;
     Table1Real2: TFloatField;
     Table1Real3: TFloatField;
     Table1Curr1: TCurrencyField;
     Table1Blobs: TBlobField;
     Table1Bytes: TBytesField;
     CbxRead: TCheckBox;
     procedure BtnWriteClick(Sender: TObject);
     procedure DataSource1DataChange(Sender: TObject; Field: TField);
     procedure FormShow(Sender: TObject);
     procedure FormClose(Sender: TObject; var Action: TCloseAction);
   private
     { Private-Deklarationen }
   public
     { Public-Deklarationen }
   end;
 
 var
   FrmBlobFld: TFrmBlobFld;
 
 implementation
 
 {$R *.DFM}
 
 type
   ADouble = array[1..12] of double;
   PADouble = ^ADouble;
 
 procedure TFrmBlobFld.BtnWriteClick(Sender: TObject);
 var
   i: integer;
   myBlob: TBlobStream;
   v: longint;
 begin
   Table1.Edit;
 
   myBlob := TBlobStream.Create(Table1Blobs, bmReadWrite);
   try
     v := ComponentCount;
     myBlob.Write(v, sizeof(longint));
 
     for i := 0 to ComponentCount - 1 do
     begin
       v := Components[i].ComponentIndex;
       myBlob.Write(v, sizeof(longint));
     end;
   finally
     Table1.Post;
     myBlob.Free;
   end;
 end;
 
 procedure TFrmBlobFld.DataSource1DataChange(Sender: TObject; Field: TField);
 var
   i: integer;
   myBlob: TBlobStream;
   t: longint;
   v: longint;
 begin
   if CbxRead.Checked then
   begin
     LbxDisplayBlob.Clear;
 
     myBlob := TBlobStream.Create(Table1Blobs, bmRead);
     try
       myBlob.Read(t, sizeof(longint));
       LbxDisplayBlob.Items.Add(IntToStr(t));
 
       for i := 0 to t - 1 do
       begin
         myBlob.Read(v, sizeof(longint));
         LbxDisplayBlob.Items.Add(IntToStr(v));
       end;
     finally
       myBlob.Free;
     end;
   end;
 end;
 
 procedure TFrmBlobFld.FormShow(Sender: TObject);
 begin
   Table1.Open;
 end;
 
 procedure TFrmBlobFld.FormClose(Sender: TObject;
   var Action: TCloseAction);
 begin
   Table1.Close;
 end;
 
 end.
 




Чтение и запись компонента

Автор: Blake

Вот участок кода из предстоящей статьи о VBX/OCX, который я написал чтобы протестировать поточность своих компонентов. Если компонент поточнен, код сможет его сохранить и загрузить. В противном случае вы получите сообщение об ошибке, отладка которой сравнительна легка для определении проблем с VCL.

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


 procedure TForm1.StoreClick(Sender: TObject);
 var
   W: TWriter;
 begin
   W := TWriter.Create(
     TFileStream.Create('c:\source\delphi\example.dob', fmCreate), 4096);
   W.WriteSignature;
   W.WriteComponent(Spin);
   W.Free;
 end;
 
 procedure TForm1.LoadClick(Sender: TObject);
 var
   R: TReader;
 begin
   R := TReader.Create(
     TFileStream.Create('c:\source\delphi\example.dob', fmOpenRead), 4096);
   Spin := R.ReadRootComponent(nil) as TSpinner;
   Spin.Top := 0;
   Spin.Left := 0;
   Spin.Parent := Self;
   InsertComponent(Spin);
   R.Free;
 end;
 




Чтение и запись файлов

1) Направление выходного потока вашей программы в файл.
2) Направление выходного потока вашей программы на принтер.
3) Чтение из входного файла.

Направление выходного потока вашей программы в файл

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

Просто в Delphi ....


 program CrtApp;
 uses WinCrt;
 var outfile: TextFile;
 begin
 AssignFile(outfile, 'c:\outfile.txt');
 Rewrite(outfile);
 writeln(outfile, 'Привет из Delphi');
 writeln(outfile, 'Моя программа работает, и выводит ' +
 'данный текст, чтобы доказать это...');
 CloseFile(outfile);
 end.
 

Просто в Паскале.....


 Program HelloWorld;
 var
 outfile: text;
 begin
 assign(outfile, 'c:\output.txt');
 rewrite(outfile);
 writeln(outfile, 'Здравствуй, мир');
 writeln(outfile, 'Моя программа работает, и выводит
 данный текст, чтобы доказать это...');
 close(outfile);
 end.
 

Направление выходного потока вашей программы на принтер

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

В Delphi ...


 program CrtApp;
 uses WinCrt;
 var outfile: TextFile;
 begin
 assignfile(outfile, 'LPT1');
 rewrite(outfile);
 writeln(outfile, 'Привет из Delphi');
 writeln(outfile, 'Моя программа работает, и выводит ' +
 'данный текст, чтобы доказать это...');
 closefile(outfile);
 end.
 

В Паскале ...


 Program HelloWorld;
 var
 outfile: text;
 begin
 assign(outfile, 'LPT1');
 rewrite(outfile);
 writeln(outfile, 'Здравствуй, мир');
 writeln(outfile, 'Моя программа работает, и выводит
 данный текст, чтобы доказать это...');
 close(outfile);
 end.
 

Чтение из входного файла

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

В Delphi ...


 program CrtApp;
 uses WinCrt;
 var
 infile, outfile: TextFile;
 num_lines, x: integer;
 line: string;
 begin
 assignfile(infile, 'C:\INFILE.TXT');
 assignfile(outfile, 'C:\OUTFILE.TXT');
 reset(infile);  {перемещаем указатель}
 {в начало файла.}
 rewrite(outfile);  {очищаем содержимое файла}
 readln(infile, num_lines);
 for x:= 1 to num_lines do
 begin
 readln(infile, line);
 writeln(outfile, line);
 end;
 closefile(infile);
 closefile(outfile);
 end.
 

В Паскале ...


 Program ReadInput;
 var
 infile, outfile: text;
 num_lines, x: integer;
 line: string;
 begin
 assign(infile, 'C:\INFILE.TXT');
 assign(outfile, 'C:\OUTFILE.TXT');
 reset(infile);  {перемещаем указатель}
 {в начало файла.}
 rewrite(outfile);  {очищаем содержимое файла}
 readln(infile, num_lines);
 for x:= 1 to num_lines do
 begin
 readln(infile, line);
 writeln(outfile, line);
 end;
 close(infile);
 close(outfile);
 end.
 

{НАЧАЛО INFILE.TXT}
 2
 Здравствуй, мир
 Моя программа работает, и этот текст доказательство этому.
 {КОНЕЦ INFILE.TXT}
Для получения дополнительной информации обратитесь к Руководству Разработчика. Ознакомьтесь с описанием функций AssignFile, Assign, Reset, Rewrite, readln, writeln, Close, CloseFile.

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




Как читать-писать в I-O порты


 A := Port[20];   {чтение байта из порта 20}
 Port[20] := A;   {запись байта в порт 20}
 B := PortW[20];  {чтение слова из порта 20-21}
 PortW[20] := B;  {запись слова в порт 20-21}
 




Запись и чтение из файла массива записей

Это не очень Delphi-подобно (тем не менее, работа происходит с действительно паскалевскими записями), но вы можете писать и читать записи из/в файл, используя паскалевские процедуры для работы с файлами:


 type
   TMyRec = record ;
     Field1: integer;
     Field2: string;
   end;
 
   TMyRecArray = array[0..9] of TMyRec;
 
 var
   MyArray: TMyRecArray;
   MyRec: TMyRec;
   RecFile: file of TMyRec;
 
 begin
   {...здесь должен быть расположен код инициализации MyArray...}
 
   AssignFile(RecFile, 'MYREC.FIL');
   ReWrite(RecFile);
   for i := 0 to 9 do
   begin
     Write(RecFile, MyRec[i]);
   end;
   CloseFile(RecFile);
 end;
 

Также, вы можете использовать Read() для чтения записи из вашего файла, и Seek() для перемещения на его конкретную запись (начиная с 0). Для получения дополнительной информации обратитесь к разделу "I/O Routines" электронной справки по Delphi.

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




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



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



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


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