uses

SysUtils, Windows, Messages, Classes, Graphics, Controls,
Forms, Dialogs, ExtCtrls, StdCtrls, IniFiles, TypInfo, Debug;

type

TUniqueReader = Class(TReader)
LastRead: TComponent;
procedure ComponentRead(Component: TComponent);
procedure SetNameUnique(
Reader: TReader;
Component: TComponent;
var Name: string
);
end;

implementation

procedure TUniqueReader.ComponentRead(

Component: TComponent
);
begin

LastRead := Component;
end;

procedure TUniqueReader.SetNameUnique( // Задаем уникальное имя считываемому компоненту

Reader: TReader;
Component: TComponent; // Считываемый компонент
var Name: string // Имя компонента для дальнейшей модификации
);
var

i: Integer;
tempname: string;
begin

i := 0;
tempname := Name;
while Component.Owner.FindComponent(Name) <> nil do begin
Inc(i);
Name := Format('%s%d', [tempname, i]);
end;
end;


function DuplicateComponents(

AComponent: TComponent // исходный компонент
): TComponent; // возвращаемся к созданию нового компонента

procedure RegisterComponentClasses(
AComponent: TComponent
);
var
i : integer;
begin
RegisterClass(TPersistentClass(AComponent.ClassType));
if AComponent is TWinControl then
if TWinControl(AComponent).ControlCount > 0 then
for i := 0 to
(TWinControl(AComponent).ControlCount-1) do

RegisterComponentClasses(TWinControl(AComponent).Controls[i]);

end;

var

Stream: TMemoryStream;
UniqueReader: TUniqueReader;
Writer: TWriter;
begin

result := nil;
UniqueReader := nil;
Writer := nil;


try
Stream := TMemoryStream.Create;
RegisterComponentClasses(AComponent);


try
Writer := TWriter.Create(Stream, 4096);
Writer.Root := AComponent.Owner;
Writer.WriteSignature;
Writer.WriteComponent(AComponent);
Writer.WriteListEnd;
finally
Writer.Free;
end;


Stream.Position := 0;
try
UniqueReader := TUniqueReader.Create(Stream, 4096); // создаем поток, перемещающий данные о компоненте в конструктор
UniqueReader.OnSetName := UniqueReader.SetNameUnique;
UniqueReader.LastRead := nil;


if AComponent is TWinControl then

UniqueReader.ReadComponents(
// считываем компоненты и суб-компоненты

TWinControl(AComponent).Owner,
TWinControl(AComponent).Parent,
UniqueReader.ComponentRead
)
else

UniqueReader.ReadComponents(
// читаем компоненты

AComponent.Owner,
nil,
UniqueReader.ComponentRead
);
result := UniqueReader.LastRead;
finally
UniqueReader.Free;
end;
finally
Stream.Free;
end;
end;

unit LinearSystem;

interface

{============== Тип, описывающий формат WAV ==================}
type WAVHeader = record

nChannels : Word;
nBitsPerSample : LongInt;
nSamplesPerSec : LongInt;
nAvgBytesPerSec : LongInt;
RIFFSize : LongInt;
fmtSize : LongInt;
formatTag : Word;
nBlockAlign : LongInt;
DataSize : LongInt;
end;

{============== Поток данных сэмпла ========================}
const MaxN = 300; { максимальное значение величины сэмпла }
type SampleIndex = 0 .. MaxN+3;
type DataStream = array[ SampleIndex ] of Real;

var N : SampleIndex;

{============== Переменные сопровождения ======================}
type Observation = record

Name : String[40]; {Имя данного сопровождения}
yyy : DataStream; {Массив указателей на данные}
WAV : WAVHeader; {Спецификация WAV для сопровождения}
Last : SampleIndex; {Последний доступный индекс yyy}
MinO, MaxO : Real; {Диапазон значений yyy}
end;

var K0R, K1R, K2R, K3R : Observation;

K0B, K1B, K2B, K3B : Observation;

{================== Переменные имени файла ===================}
var StandardDatabase : String[ 80 ];

BaseFileName : String[ 80 ];
StandardOutput : String[ 80 ];
StandardInput : String[ 80 ];

{=============== Объявления процедур ==================}
procedure ReadWAVFile (var Ki, Kj : Observation);
procedure WriteWAVFile (var Ki, Kj : Observation);
procedure ScaleData (var Kk : Observation);
procedure InitAllSignals;
procedure InitLinearSystem;


implementation
{$R *.DFM}
uses VarGraph, SysUtils;

{================== Стандартный формат WAV-файла ===================}
const MaxDataSize : LongInt = (MaxN+1)*2*2;
const MaxRIFFSize : LongInt = (MaxN+1)*2*2+36;
const StandardWAV : WAVHeader = (

nChannels : Word(2);
nBitsPerSample : LongInt(16);
nSamplesPerSec : LongInt(8000);
nAvgBytesPerSec : LongInt(32000);
RIFFSize : LongInt((MaxN+1)*2*2+36);
fmtSize : LongInt(16);
formatTag : Word(1);
nBlockAlign : LongInt(4);
DataSize : LongInt((MaxN+1)*2*2)
);


{================== Сканирование переменных сопровождения ===================}


procedure ScaleData(var Kk : Observation);
var I : SampleIndex;
begin


{Инициализация переменных сканирования}
Kk.MaxO := Kk.yyy[0];
Kk.MinO := Kk.yyy[0];


{Сканирование для получения максимального и минимального значения}
for I := 1 to Kk.Last do
begin
if Kk.MaxO < Kk.yyy[I] then Kk.MaxO := Kk.yyy[I];
if Kk.MinO > Kk.yyy[I] then Kk.MinO := Kk.yyy[I];
end;
end; { ScaleData }

procedure ScaleAllData;
begin

ScaleData(K0R);
ScaleData(K0B);
ScaleData(K1R);
ScaleData(K1B);
ScaleData(K2R);
ScaleData(K2B);
ScaleData(K3R);
ScaleData(K3B);
end; {ScaleAllData}

{================== Считывание/запись WAV-данных ===================}

VAR InFile, : file of Byte;

type Tag = (F0, T1, M1);
type FudgeNum = record

case X:Tag of
F0 : (chrs : array[0..3] of Byte);
T1 : (lint : LongInt);
M1 : (up,dn: Integer);
end;
var ChunkSize : FudgeNum;

procedure WriteChunkName(Name:String);
var i : Integer;

MM : Byte;
begin

for i := 1 to 4 do
begin
MM := ord(Name[i]);
write(,MM);
end;
end; {WriteChunkName}

procedure WriteChunkSize(LL:Longint);
var I : integer;
begin

ChunkSize.x:=T1;
ChunkSize.lint:=LL;
ChunkSize.x:=F0;
for I := 0 to 3 do Write(,ChunkSize.chrs[I]);
end;

procedure WriteChunkWord(WW:Word);
var I : integer;
begin

ChunkSize.x:=T1;
ChunkSize.up:=WW;
ChunkSize.x:=M1;
for I := 0 to 1 do Write(,ChunkSize.chrs[I]);
end; {WriteChunkWord}

procedure WriteOneDataBlock(var Ki, Kj : Observation);
var I : Integer;
begin

ChunkSize.x:=M1;
with Ki.WAV do
begin
case nChannels of
1:if nBitsPerSample=16
then begin {1..2 Помещаем в буфер одноканальный 16-битный сэмпл}
ChunkSize.up := trunc(Ki.yyy[N]+0.5);
if N<=Ki.Last do WriteOneDataBlock(Ki,Kj); {помещаем 4 байта и увеличиваем счетчик N}


{Освобождаем буфер файла}
CloseFile( );
end; {WriteWAVFile}

procedure InitSpecs;
begin
end; { InitSpecs }

procedure InitSignals(var Kk : Observation);
var J : Integer;
begin

for J := 0 to MaxN do Kk.yyy[J] := 0.0;
Kk.MinO := 0.0;
Kk.MaxO := 0.0;
Kk.Last := MaxN;
end; {InitSignals}

procedure InitAllSignals;
begin
InitSignals(K0R);
InitSignals(K0B);
InitSignals(K1R);
InitSignals(K1B);
InitSignals(K2R);
InitSignals(K2B);
InitSignals(K3R);
InitSignals(K3B);
end; {InitAllSignals}

var ChunkName : string[4];

procedure ReadChunkName;
var I : integer;

MM : Byte;
begin

ChunkName[0]:=chr(4);
for I := 1 to 4 do
begin
Read(InFile,MM);
ChunkName[I]:=chr(MM);
end;
end; {ReadChunkName}

procedure ReadChunkSize;
var I : integer;

MM : Byte;
begin

ChunkSize.x := F0;
ChunkSize.lint := 0;
for I := 0 to 3 do
begin
Read(InFile,MM);
ChunkSize.chrs[I]:=MM;
end;
ChunkSize.x := T1;
end; {ReadChunkSize}

procedure ReadOneDataBlock(var Ki,Kj:Observation);
var I : Integer;
begin

if N<=MaxN then
begin
ReadChunkSize; {получаем 4 байта данных}
ChunkSize.x:=M1;
with Ki.WAV do
case nChannels of
1:if nBitsPerSample=16
then begin {1..2 Помещаем в буфер одноканальный 16-битный сэмпл}
Ki.yyy[N] :=1.0*ChunkSize.up;
if N<=MaxN then begin {LastN := N;}
Ki.Last := N;
if Ki.WAV.nChannels=2 then Kj.Last := N;
end
else begin {LastN := MaxN;}
Ki.Last := MaxN;
if Ki.WAV.nChannels=2 then Kj.Last := MaxN;

end;
end;
end; {ReadOneDataBlock}

procedure ReadWAVFile(var Ki, Kj :Observation);
var MM : Byte;

I : Integer;
OK : Boolean;
NoDataYet : Boolean;
DataYet : Boolean;
nDataBytes : LongInt;
begin

if FileExists(StandardInput)
then
with Ki.WAV do
begin { Вызов диалога открытия файла }
OK := True; {если не изменится где-нибудь ниже}
{Приготовления для чтения файла данных}
AssignFile(InFile, StandardInput); { Файл, выбранный в диалоговом окне }
Reset( InFile );


{Считываем ChunkName "RIFF"}
ReadChunkName;
if ChunkName<>'RIFF' then OK := False;


{Считываем ChunkSize}
ReadChunkSize;
RIFFSize := ChunkSize.lint; {должно быть 18,678}


{Считываем ChunkName "WAVE"}
ReadChunkName;
if ChunkName<>'WAVE' then OK := False;


{Считываем ChunkName "fmt_"}
ReadChunkName;
if ChunkName<>'fmt ' then OK := False;


{Считываем ChunkSize}
ReadChunkSize;
fmtSize := ChunkSize.lint; {должно быть 18}


{Считываем formatTag, nChannels}
ReadChunkSize;
ChunkSize.x := M1;
formatTag := ChunkSize.up;
nChannels := ChunkSize.dn;


{Считываем nSamplesPerSec}
ReadChunkSize;
nSamplesPerSec := ChunkSize.lint;


{Считываем nAvgBytesPerSec}
ReadChunkSize;
nAvgBytesPerSec := ChunkSize.lint;


{Считываем nBlockAlign}
ChunkSize.x := F0;
ChunkSize.lint := 0;
for I := 0 to 3 do
begin Read(InFile,MM);
ChunkSize.chrs[I]:=MM;
end;
ChunkSize.x := M1;
nBlockAlign := ChunkSize.up;


{Считываем nBitsPerSample}
nBitsPerSample := ChunkSize.dn;
for I := 17 to fmtSize do Read(InFile,MM);


NoDataYet := True;
while NoDataYet do
begin
{Считываем метку блока данных "data"}
ReadChunkName;


{Считываем DataSize}
ReadChunkSize;
DataSize := ChunkSize.lint;


if ChunkName<>'data' then
begin
for I := 1 to DataSize do {пропуск данных, не относящихся к набору звуковых данных}
Read(InFile,MM);
end
else NoDataYet := False;
end;


nDataBytes := DataSize;
{Наконец, начинаем считывать данные для байтов nDataBytes}
if nDataBytes>0 then DataYet := True;
N:=0; {чтение с первой позиции}
while DataYet do
begin
ReadOneDataBlock(Ki,Kj); {получаем 4 байта}
nDataBytes := nDataBytes-4;
if nDataBytes<=4 then DataYet := False;
end;


ScaleData(Ki);
if Ki.WAV.nChannels=2
then begin Kj.WAV := Ki.WAV;
ScaleData(Kj);
end;
{Освобождаем буфер файла}
CloseFile( InFile );
end
else begin
InitSpecs;{файл не существует}
InitSignals(Ki);{обнуляем массив "Ki"}
InitSignals(Kj);{обнуляем массив "Kj"}
end;
end; { ReadWAVFile }



{================= Операции с набором данных ====================}

const MaxNumberOfDataBaseItems = 360;
type SignalDirectoryIndex = 0 .. MaxNumberOfDataBaseItems;

VAR DataBaseFile : file of Observation;

LastDataBaseItem : LongInt; {Номер текущего элемента набора данных}
ItemNameS : array[SignalDirectoryIndex] of String[40];

procedure GetDatabaseItem( Kk : Observation; N : LongInt );
begin

if N<=LastDataBaseItem
then begin
Seek(DataBaseFile, N);
Read(DataBaseFile, Kk);
end
else InitSignals(Kk);
end; {GetDatabaseItem}
procedure PutDatabaseItem( Kk : Observation; N : LongInt );
begin

if N<=LastDataBaseItem
then begin
Seek(DataBaseFile, N);
Write(DataBaseFile, Kk);
LastDataBaseItem := LastDataBaseItem+1;
end
else while LastDataBaseItem<=N do
begin
Seek(DataBaseFile, LastDataBaseItem);
Write(DataBaseFile, Kk);
LastDataBaseItem := LastDataBaseItem+1;
end
else ReportError(1); {Попытка чтения MaxNumberOfDataBaseItems}
end; {PutDatabaseItem}

procedure InitDataBase;
begin

LastDataBaseItem := 0;
if FileExists(StandardDataBase)
then
begin
Assign(DataBaseFile,StandardDataBase);
Reset(DataBaseFile);
while not EOF(DataBaseFile) do
begin
GetDataBaseItem(K0R, LastDataBaseItem);
ItemNameS[LastDataBaseItem] := K0R.Name;
LastDataBaseItem := LastDataBaseItem+1;
end;
if EOF(DataBaseFile)
then if LastDataBaseItem>0
then LastDataBaseItem := LastDataBaseItem-1;
end;
end; {InitDataBase}

function FindDataBaseName( Nstg : String ):LongInt;
var ThisOne : LongInt;
begin

ThisOne := 0;
FindDataBaseName := -1;
while ThisOne

var

MyJpeg: TJpegImage;
Image1: TImage;
begin

Image1:= TImage.Create;
MyJpeg:= TJpegImage.Create;
Image1.LoadFile('TestImage.BMP'); // Чтение изображения из файла
MyJpeg.Assign(Image1.Picture.Bitmap); // Назначание изображения объекту MyJpeg
MyJpeg.SaveToFile('MyJPEGImage.JPG'); // Сохранение на диске изображения в формате JPEG
end;

unit StreamFile;

interface

Uses

SysUtils;

Procedure AssignStreamFile (var F : Text ; Filename : String);

implementation

Const

BufferSize = 128;

Type

TStreamBuffer = Array [1..High (Integer)] of Char;
TStreamBufferPointer = ^TStreamBuffer;


TStreamFileRecord = Record
Case Integer Of
1:
(
Filehandle : Integer;
Buffer : TStreamBufferPointer;
BufferOffset : Integer;
ReadCount : Integer;
);
2:
(
Dummy : Array [1 .. 32] Of Char
)
End;


Function StreamFileOpen (var F : TTextRec) : Integer;

Var
Status : Integer;
Begin
With TStreamFileRecord (F.UserData) Do
Begin
GetMem (Buffer, BufferSize);
Case F.Mode Of
fmInput:
FileHandle := FileOpen (StrPas (F.Name), fmShareDenyNone);
fmOutput:
FileHandle := FileCreate (StrPas (F.Name));
fmInOut:
Begin
FileHandle := FileOpen (StrPas (F.Name), fmShareDenyNone Or
fmOpenWrite or fmOpenRead);

If FileHandle <> -1 Then
status := FileSeek (FileHandle, 0, 2); { Перемещаемся в конец файла. }
F.Mode := fmOutput;
End;
End;
BufferOffset := 0;
ReadCount := 0;
F.BufEnd := 0; { В этом месте подразумеваем что мы достигли конца файла (eof). }
If FileHandle = -1 Then
Result := -1
Else
Result := 0;
End;
End;

Function StreamFileInOut (var F : TTextRec) : Integer;

Procedure Read (var Data : TStreamFileRecord);
Procedure CopyData;
Begin
While (F.BufEnd < Sizeof (F.Buffer) - 2)
And (Data.BufferOffset <= Data.ReadCount)
And (Data.Buffer [Data.BufferOffset] <> #10) Do
Begin
F.Buffer [F.BufEnd] := Data.Buffer^ [Data.BufferOffset];
Inc (Data.BufferOffset);
Inc (F.BufEnd);
End;
If Data.Buffer [Data.BufferOffset] = #10 Then
Begin
F.Buffer [F.BufEnd] := #13;
Inc (F.BufEnd);
F.Buffer [F.BufEnd] := #10;
Inc (F.BufEnd);
Inc (Data.BufferOffset);
End;
End;


Begin


F.BufEnd := 0;
F.BufPos := 0;
F.Buffer := '';
Repeat
Begin
If (Data.ReadCount = 0) Or (Data.BufferOffset > Data.ReadCount) Then
Begin
Data.BufferOffset := 1;
Data.ReadCount := FileRead (Data.FileHandle, Data.Buffer^, BufferSize);
End;
CopyData;
End Until (Data.ReadCount = 0)
Or (F.BufEnd >= Sizeof (F.Buffer) - 2);
Result := 0;
End;


Procedure Write (var Data : TStreamFileRecord);
Var
Status : Integer;
Destination : Integer;
II : Integer;
Begin
With TStreamFileRecord (F.UserData) Do
Begin
Destination := 0;
For II := 0 To F.BufPos - 1 Do
Begin
If F.Buffer [II] <> #13 Then
Begin
Inc (Destination);
Buffer^[Destination] := F.Buffer [II];
End;
End;
Status := FileWrite (FileHandle, Buffer^, Destination);
F.BufPos := 0;
Result := 0;
End;
End;
Begin
Case F.Mode Of
fmInput:
Read (TStreamFileRecord (F.UserData));
fmOutput:
Write (TStreamFileRecord (F.UserData));
End;
End;

Function StreamFileFlush (var F : TTextRec) : Integer;

Begin
Result := 0;
End;

Function StreamFileClose (var F : TTextRec) : Integer;

Begin
With TStreamFileRecord (F.UserData) Do
Begin
FreeMem (Buffer);
FileClose (FileHandle);
End;
Result := 0;
End;

Procedure AssignStreamFile (var F : Text ; Filename : String);

Begin
With TTextRec (F) Do
Begin
Mode := fmClosed;
BufPtr := @Buffer;
BufSize := Sizeof (Buffer);
OpenFunc := @StreamFileOpen;
InOutFunc := @StreamFileInOut;
FlushFunc := @StreamFileFlush;
CloseFunc := @StreamFileClose;
StrPLCopy (Name, FileName, Sizeof(Name) - 1);
End;
End;
end.

var
Icon : TIcon;
Bitmap : TBitmap;
begin
Icon := TIcon.Create;
Bitmap := TBitmap.Create;
Icon.LoadFromFile('c:picture.ico');
Bitmap.Width := Icon.Width;
Bitmap.Height := Icon.Height;
Bitmap.Canvas.Draw(0, 0, Icon);
Bitmap.SaveToFile('c:picture.bmp');
Icon.Free;
Bitmap.Free;
end;

unit main;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms,Dialogs,ExtCtrls, StdCtrls;

type

TForm1 = class(TForm)
Button1: TButton;
Image1: TImage;
Image2: TImage;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var winDC, srcdc, destdc : HDC;

oldBitmap : HBitmap;
iinfo : TICONINFO;
begin

GetIconInfo(Image1.Picture.Icon.Handle, iinfo);


WinDC := getDC(handle);
srcDC := CreateCompatibleDC(WinDC);
destDC := CreateCompatibleDC(WinDC);
oldBitmap := SelectObject(destDC, iinfo.hbmColor);
oldBitmap := SelectObject(srcDC, iinfo.hbmMask);


BitBlt(destdc, 0, 0, Image1.picture.icon.width,
Image1.picture.icon.height,
srcdc, 0, 0, SRCPAINT);
Image2.picture.bitmap.handle := SelectObject(destDC, oldBitmap);
DC(destDC);
DC(srcDC);
DC(WinDC);


image2.Picture.Bitmap.savetofile(ExtractFilePath(Application.ExeName)
+ 'myfile.bmp');
end;

procedure TForm1.FormCreate(Sender: TObject);
begin

image1.picture.icon.loadfromfile('c:myicon.ico');
end;

end.