Объектное ориентирование

Code:

type

IAutoClean = interface

['{61D9CBA6-B1CE-4297-9319-66CC86CE6922}']

end;

TAutoClean = class(TInterfacedObject, IAutoClean)

private

FObj: TObject;

public

constructor Create(AObj: TObject);

destructor Destroy; override;

end;

implementation

constructor TAutoClean.Create(AObj: TObject);

begin

FObj := AObj;

end;

destructor TAutoClean.Destroy;

begin

FreeAndNil(FObj);

inherited;

end;

Code:

procedure TForm1.Button1Click(Sender: TObject);

var

a: IAutoClean;

//must declare as local variable, so when this procedure finished, it's out of scope

o: TOpenDialog; //any component

begin

o := TOpenDialog.Create(self);

a := TAutoClean.Create(o);

if o.Execute then

ShowMessage(o.FileName);

end;

Code:

TBoolList = class(TPersistent)

private

FValue1: Boolean;

FValue2: Boolean

published

property Value1: Boolean read FValue1 write FValue1;

property Value2: Boolean read FValue2 write FValue2;

end;

Code:

TMyPanel = class(TCustomPanel)

private

FBoolList: TBoolList;

public

constructor Create( AOwner: TComponent ); override;

published

property BoolList: TBoolList read FBoolList write FBoolLisr;

end;

Code:

constructor TMyPanel.Create( AOwner: TComponent );

begin

inherited Create( AOwner );

FBoolList := TBoolList.Create;

end;

Code:

type

TForm1 = class(TForm)

protected

MyLabel: TLabel;

procedure LabelClick(Sender: TObject);

procedure CreateControl;

end;

procedure TForm1.LabelClick(Sender: TObject);

begin

(Sender asLabel).Caption := ...

end;

procedure TForm1.CreateControl;

var

ALeft, ATop, AWidth, AHeight: Integer;

begin

ALeft := 10;

ATop := 10;

AWidth := 50;

AHeight := 13;

MyLabel := TLabel.Create(Self);

MyLabel.Parent := Self;

MyLabel.Name:='LabelName';

MyLabel.SetBounds(ALeft, ATop, AWidth, AHeight);

MyLabel.OnClick := LabelClick;

end;

Code:

type

TMailClient = class(TCollectionItem)

private

FName: string;

FAddress: string;

FEnabled: boolean;

FFolders: TStringList;

public

Files: TStringList; // список файлов к рассылке. заполняется в run-time. Сохранению не подлежит

constructor Create(Collection: TCollection); override;

destructor Destroy; override;

procedure PickFiles;

published

propertyName: stringread FName write FName; // имя адресата

property Address: stringread FAddress write FAddress; // почтовый адрес

property Enabled: boolean read FEnabled write FEnabled default true;

property Folders: TStringList read FFolders write FFolders; // список папок (тем) подписки

end;

Code:

TMailList = class(TCollection)

public

function GetMailClient(Index: Integer): TMailClient;

procedure SetMailClient(Index: Integer; Value: TMailClient);

public

function Add: TMailClient;

property Items[Index: Integer]: TMailClient read GetMailClient write SetMailClient; default;

end;

Code:

TMailer = class(TComponent)

private

FMailList: TMailList;

public

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

published

property MailList: TMailList read FMailList write FMailList; // коллекция - список рассылки.

// здесь можно поместить, к примеру, данные о соединении с почтовым сервером

end;

Code:

constructor TMailClient.Create(Collection: TCollection);

begin

inherited;

Folders := TStringList.Create;

Files := TStringList.Create;

FEnabled := true;

end;

destructor TMailClient.Destroy;

begin

Folders.Free;

Files.Free;

inherited;

end;

// здесь во всех каталогах Folders ищем файлы для рассылки и помещаем их в Files.

procedure TMailClient.PickFiles;

var i: integer;

begin

for i:=0to Folders.Count-1do CreateFileList(Files, Folders[i]);

end;

// Стандартный код при наследовании от класса коллекции: переопределяем тип

function TMailList.GetMailClient(Index: Integer): TMailClient;

begin

Result := TMailClient(inherited Items[Index]);

end;

// Стандартный код при наследовании от класса коллекции

procedure TMailList.SetMailClient(Index: Integer; Value: TMailClient);

begin

Items[Index].Assign(Value);

end;

// Стандартный код при наследовании от класса коллекции: переопределяем тип

function TMailList.Add: TMailClient;

begin

Result := TMailClient(inherited Add);

end;

// создаем коллекцию адресатов рассылки TMailList

constructor TMailer.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

MailList := TMailList.Create(TMailClient);

end;

destructor TMailer.Destroy;

begin

MailList.Free;

inherited;

end;

//---------------------

Code:

procedure CreateFileList(sl: TStringList; const FilePath: string);

var

sr: TSearchRec;

procedure ProcessFile;

begin

if (sr.Name = '.')or(sr.Name = '..') then exit;

if sr.Attr <> faDirectory then

sl.Add(FilePath + '\' + sr.Name);

if sr.Attr = faDirectory then

begin

CreateFileList(sl, FilePath + '\' + sr.Name);

end;

end;

begin

ifnot DirectoryExists(FilePath) then exit;

if FindFirst(FilePath + '\' + '*.*', faAnyFile , sr) = 0then ProcessFile;

while FindNext(sr) = 0do ProcessFile;

FindClose(sr);

end;

Code:

var

Mailer: TMailer; // это наш объект для хранения данных о почтовой рассылки

// Процедура загрузки данных в объект. Может быть процедурой OnCreate() главной формы.

procedure TfMain.FormCreate(Sender: TObject);

var

sDataFile, sTmp: string;

i, j: integer;

begin

Mailer := TMailer.Create(self);

// будем считать, что данные были сохранены в файл users.dat в каталоге программы

sDataFile := ExtractFilePath(ParamStr(0)) + 'users.dat';

//...загрузка данных из файла

if FileExists(sDataFile) then

LoadComponentFromTextFile(Mailer, sDataFile);

{ здесь данные из файла загружены }

//...перебор подписчиков

for i:=0to Mailer.MailList.Count-1do

begin

sTmp := Mailer.MailList[i].Name; //...обращение к имени

sTmp := Mailer.MailList[i].Address; //...обращение к адресу

//... sTmp - фиктивная переменная. Поменяйте ее на свои.

Mailer.MailList[i].PickFiles; //... поиск файлов для отправки очередному подписчику.

//...перебор найденных файлов к отправке

for j:=0to Mailer.MailList[i].Files.Count-1do

begin

sTmp := Mailer.MailList[i].Files[j];

end;

end;

end;

Code:

// Процедура сохранения данных из объекта в файл. Может быть процедурой OnDestroy() главной формы.

procedure TfMain.OnDestroy;

begin

//...сохранение данных в файл users.dat

SaveComponentToTextFile(Mailer, ExtractFilePath(ParamStr(0)) + 'users.dat');

end;

Code:

//...процедура загружает(инициализирует) компонент из текстового файла с ресурсом

procedure LoadComponentFromTextFile(Component: TComponent; const FileName: string);

var

ms: TMemoryStream;

fs: TFileStream;

begin

fs := TFileStream.Create(FileName, fmOpenRead);

ms := TMemoryStream.Create;

try

ObjectTextToBinary(fs, ms);

ms.position := 0;

ms.ReadComponent(Component);

finally

ms.Free;

fs.free;

end;

end;

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

procedure SaveComponentToTextFile(Component: TComponent; const FileName: string);

var

ms: TMemoryStream;

fs: TFileStream;

begin

fs := TFileStream.Create(FileName, fmCreate or fmOpenWrite);

ms := TMemoryStream.Create;

try

ms.WriteComponent(Component);

ms.position := 0;

ObjectBinaryToText(ms, fs);

finally

ms.Free;

fs.free;

end;

end;

Code:

{

Здесь пpоцедypа CreateClone, котоpая кpеатит компонентy ОЧЕHЬ ПОХОЖУЮ на

входнyю. С такими же значениями свойств. Пpисваивается все, кpоме методов.

}

function CreateClone(Src: TComponent): TComponent;

var

F: TStream;

begin

F := nil;

try

F := TMemoryStream.Create;

F.WriteComponent(Src);

RegisterClass(TComponentClass(Src.ClassType));

F.Position := 0;

Result := F.ReadComponent(nil);

finally

F.Free;

end;

end;

Code:

function EnumProc(wnd: HWND; var count: DWORD): Bool; stdcall;

begin

Inc(count);

result := True;

EnumChildWindows(wnd, @EnumProc, integer(@count));

end;

procedure TForm1.Button1Click(Sender: TObject);

var

count: DWORD;

begin

count := 0;

EnumThreadWindows(GetCurrentThreadID, @EnumProc, Integer(@count));

Caption := Format('%d window handles in use', [count]);

end;

Code:

function ComponentToString(Component: TComponent): string;

var

ms: TMemoryStream;

ss: TStringStream;

begin

ss := TStringStream.Create(' ');

ms := TMemoryStream.Create;

try

ms.WriteComponent(Component);

ms.position := 0;

ObjectBinaryToText(ms, ss);

ss.position := 0;

Result := ss.DataString;

finally

ms.Free;

ss.free;

end;

end;

procedure StringToComponent(Component: TComponent; Value: string);

var

StrStream:TStringStream;

ms: TMemoryStream;

begin

StrStream := TStringStream.Create(Value);

try

ms := TMemoryStream.Create;

try

ObjectTextToBinary(StrStream, ms);

ms.position := 0;

ms.ReadComponent(Component);

finally

ms.Free;

end;

finally

StrStream.Free;

end;

end;

Code:

object Form1: TForm1

Left = 262

Top = 129

Width = 525

Height = 153

Caption = 'Form1'

Color = clBtnFace

Font.Charset = DEFAULT_CHARSET

Font.Color = clWindowText

Font.Height = -11

Font.Name = 'MS Sans Serif'

Font.Style = []

OldCreateOrder = False

Scaled = False

PixelsPerInch = 96

TextHeight = 13

object Button1: TButton

Left = 16

Top = 32

Width = 57

Height = 49

Caption = 'Caption'

TabOrder = 0

OnClick = Button1Click

end

end

procedure TForm1.Button1Click(Sender: TObject);

var

Button: TButton;

OldName: string;

begin

Button := TButton.Create(self);

//...сохраняем имя компонента

OldName := (Sender as TButton).Name;

//...стираем имя компонента, чтобы избежать конфликта имен.

//...После этого Button1 станет = nil.

(Sender as TButton).Name := '';

//...преобразуем в текст и обратно

StringToComponent( Button, ComponentToString(Sender as TButton) );

//...дадим компоненту уникальное(?) имя

Button.Name := 'Button' + IntToStr(random(1000));

//...вернем исходному компоненту имя.

//...После этого Button1 станет снова указывать на объект.

(Sender as TButton).Name := OldName;

//...размещаем новую кнопку справа от исходной

Button.parent := self;

Button1.Tag := Button1.Tag + 1;

Button.Left := Button.Left + Button.Width * Button1.Tag + 1;

end;

Code:

_COLLECTION_ = class (TOwnedCollection)

protected

function GetItem (const aIndex : Integer) : _COLLECTION_ITEM_;

procedure SetItem (const aIndex : Integer;

const aValue : _COLLECTION_ITEM_);

public

constructor Create (const aOwner : TComponent);

function Add : _COLLECTION_ITEM_;

function FindItemID (const aID : Integer) : _COLLECTION_ITEM_;

function Insert (const aIndex : Integer) : _COLLECTION_ITEM_;

property Items [const aIndex : Integer] : _COLLECTION_ITEM_ read GetItem write SetItem;

end;

Code:

constructor _COLLECTION_.Create (const aOwner : TComponent);

begin

inherited Create (aOwner, _COLLECTION_ITEM_);

end;

function _COLLECTION_.Add : _COLLECTION_ITEM_;

begin

Result := _COLLECTION_ITEM_ (inherited Add);

end;

function _COLLECTION_.FindItemID (const aID : Integer) : _COLLECTION_ITEM_;

begin

Result := _COLLECTION_ITEM_ (inherited FindItemID (aID));

end;

function _COLLECTION_.GetItem (const aIndex : Integer) : _COLLECTION_ITEM_;

begin

Result := _COLLECTION_ITEM_ (inherited GetItem (aIndex));

end;

function _COLLECTION_.Insert (const aIndex : Integer) : _COLLECTION_ITEM_;

begin

Result := _COLLECTION_ITEM_ (inherited Insert (aIndex));

end;

procedure _COLLECTION_.SetItem (const aIndex : Integer;

const aValue : _COLLECTION_ITEM_);

begin

inherited SetItem (aIndex, aValue);

end;

Code:

unit MyCollectionUnit;

interface

uses Classes;

type TMyCollectionItem = class (TCollectionItem)

private

FMyStringData : String;

FMyIntegerData : Integer;

public

procedure Assign (aSource : TPersistent); override;

published

property MyStringData : Stringread FMyStringData write FMyStringData;

property MyIntegerData : Integer read FMyIntegerData write FMyIntegerData;

end;

// !!! Указываем универсальному классу на реальный тип

_COLLECTION_ITEM_ = TMyCollectionItem;

// !!! директива добавления интерфейса универсального класса

{$INCLUDE TemplateCollectionInterface}

// !!! переименовываем универсальный класс

TMyCollection = _COLLECTION_;

implementation

uses SysUtils;

// !!! препроцессорная директива добавления универсального класса

{$INCLUDE TemplateCollectionImplementation}

procedure TMyCollectionItem.Assign (aSource : TPersistent);

begin

if aSource is TMyCollectionItem then

begin

FMyStringData := TMyCollectionItem(aSource).FMyStringData;

FMyIntegerData := TMyCollectionItem(aSource).FMyIntegerData;

end

elseinherited;

end;

end.

Code:

_VECTOR_INTERFACE_ = nterface

function GetLength : Integer;

procedure SetLength (const aLength : Integer);

function GetItems (const aIndex : Integer) : _VECTOR_DATA_TYPE_;

procedure SetItems (const aIndex : Integer;

const aValue : _VECTOR_DATA_TYPE_);

function GetFirst : _VECTOR_DATA_TYPE_;

procedure SetFirst (const aValue : _VECTOR_DATA_TYPE_);

function GetLast : _VECTOR_DATA_TYPE_;

procedure SetLast (const aValue : _VECTOR_DATA_TYPE_);

function High : Integer;

function Low : Integer;

function Clear : _VECTOR_INTERFACE_;

function Extend (const aDelta : Word = 1) : _VECTOR_INTERFACE_;

function Contract (const aDelta : Word = 1) : _VECTOR_INTERFACE_;

property Length : Integer read GetLength write SetLength;

property Items [const aIndex : Integer] : _VECTOR_DATA_TYPE_ read GetItems write SetItems; default;

property First : _VECTOR_DATA_TYPE_ read GetFirst write SetFirst;

property Last : _VECTOR_DATA_TYPE_ read GetLast write SetLast;

end;

_VECTOR_CLASS_ = class (TInterfacedObject, _VECTOR_INTERFACE_)

private

FArray : arrayof _VECTOR_DATA_TYPE_;

protected

function GetLength : Integer;

procedure SetLength (const aLength : Integer);

function GetItems (const aIndex : Integer) : _VECTOR_DATA_TYPE_;

procedure SetItems (const aIndex : Integer;

const aValue : _VECTOR_DATA_TYPE_);

function GetFirst : _VECTOR_DATA_TYPE_;

procedure SetFirst (const aValue : _VECTOR_DATA_TYPE_);

function GetLast : _VECTOR_DATA_TYPE_;

procedure SetLast (const aValue : _VECTOR_DATA_TYPE_);

public

function High : Integer;

function Low : Integer;

function Clear : _VECTOR_INTERFACE_;

function Extend (const aDelta : Word = 1) : _VECTOR_INTERFACE_;

function Contract (const aDelta : Word = 1) : _VECTOR_INTERFACE_;

constructor Create (const aLength : Integer);

end;

Code:

constructor _VECTOR_CLASS_.Create (const aLength : Integer);

begin

inherited Create;

SetLength (aLength);

end;

function _VECTOR_CLASS_.GetLength : Integer;

begin

Result := System.Length (FArray);

end;

procedure _VECTOR_CLASS_.SetLength (const aLength : Integer);

begin

System.SetLength (FArray, aLength);

end;

function _VECTOR_CLASS_.GetItems (const aIndex : Integer) : _VECTOR_DATA_TYPE_;

begin

Result := FArray [aIndex];

end;

procedure _VECTOR_CLASS_.SetItems (const aIndex : Integer;

const aValue : _VECTOR_DATA_TYPE_);

begin

FArray [aIndex] := aValue;

end;

function _VECTOR_CLASS_.High : Integer;

begin

Result := System.High (FArray);

end;

function _VECTOR_CLASS_.Low : Integer;

begin

Result := System.Low (FArray);

end;

function _VECTOR_CLASS_.GetFirst : _VECTOR_DATA_TYPE_;

begin

Result := FArray [System.Low (FArray)];

end;

procedure _VECTOR_CLASS_.SetFirst (const aValue : _VECTOR_DATA_TYPE_);

begin

FArray [System.Low (FArray)] := aValue;

end;

function _VECTOR_CLASS_.GetLast : _VECTOR_DATA_TYPE_;

begin

Result := FArray [System.High (FArray)];

end;

procedure _VECTOR_CLASS_.SetLast (const aValue : _VECTOR_DATA_TYPE_);

begin

FArray [System.High (FArray)] := aValue;

end;

function _VECTOR_CLASS_.Clear : _VECTOR_INTERFACE_;

begin

FArray := Nil;

Result := Self;

end;

function _VECTOR_CLASS_.Extend (const aDelta : Word) : _VECTOR_INTERFACE_;

begin

System.SetLength (FArray, System.Length (FArray) + aDelta);

Result := Self;

end;

function _VECTOR_CLASS_.Contract (const aDelta : Word) : _VECTOR_INTERFACE_;

begin

System.SetLength (FArray, System.Length (FArray) - aDelta);

Result := Self;

end;

Code:

unit FloatVectorUnit;

interface

uses Classes; // !!! Модуль "Classes" содержит объявление класса TInterfacedObject

type _VECTOR_DATA_TYPE_ = Double; // !!! тип данных для класса массива Double

{$INCLUDE TemplateVectorInterface}

IFloatVector = _VECTOR_INTERFACE_; // !!! give the interface a meanigful name

TFloatVector = _VECTOR_CLASS_; // !!! give the class a meanigful name

function CreateFloatVector (const aLength : Integer = 0) : IFloatVector; // !!! дополнительная функция

implementation

{$INCLUDE TemplateVectorImplementation}

function CreateFloatVector (const aLength : Integer = 0) : IFloatVector;

begin

Result := TFloatVector.Create (aLength);

end;

end.

Code:

procedure TestFloatVector;

var aFloatVector : IFloatVector;

aIndex : Integer;

begin

aFloatVector := CreateFloatVector;

aFloatVector.Extend.Last := 1;

aFloatVector.Extend.Last := 2;

for aIndex := aFloatVector.Low to aFloatVector.High do

begin

WriteLn (FloatToStr (aFloatVector [aIndex]));

end;

end.

Code:

if csDesigning in ComponentState then

begin

... код, работающий только в дизайне ...

end;