Следующая функция получает в качестве параметра Base (1..16) любую десятичную величину и возвращает результат в виде строки, содержащей точное значение BaseX. Вы можете использовать данный алгоритм для преобразования арабских чисел в римские (смотри ниже).

function DecToBase(Decimal: Longint; const Base: Byte): String;

const Symbols: String[16] = '0123456789ABCDEF';

var

scratch: String;

remainder: Byte;

begin

scratch:= '';

repeat

remainder:= Decimal mod base;

scratch:= Symbols[remainder + 1] + scratch;

Decimal:= Decimal div base;

until (decimal = 0);

Result:= scratch;

end;

Передайте данной функции любую десятичную величину (1…3999), и она возвратит строку, содержащую точное значение в римской транскрипции.

function DecToRoman(Decimal: Longint ): String;

const Romans: Array[1..13] of String = ('I', 'IV', 'V', 'IX', 'X', 'XL', 'L', 'XC', 'C', 'CD', 'D', 'CM', 'M');

Arabics: Array[1..13] of integer = (1, 4, 5, 9, 10, 40, 50, 90, 100, 400, 500, 900, 1000);

var

i: Integer;

scratch: String;

begin

scratch:= '';

for i := 13 downto 1 do

while (decimal >= arabics[i]) do begin

Decimal:= Decimal – Arabics[i];

scratch:= scratch + Romans[i];

end;

Result:= scratch;

end;

Преобразование ICO в BMP

Решение 1

Попробуйте:

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;

Решение 2

Способ преобразования изображения размером 32×32 в иконку.

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);

DeleteDC(destDC);

DeleteDC(srcDC);

DeleteDC(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.

Unix-строки (чтение и запись Unix-файлов)

Данный модуль позволяет читать и записывать файлы формата Unix.

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;

BufferOffset:= 0;

ReadCount:= 0;

F.BufEnd:= 0; { В этом месте подразумеваем что мы достигли конца файла (eof). }

If FileHandle = -1 Then Result := -1

Else Result:= 0;

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;

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;

Status:= FileWrite(FileHandle, Buffer^, Destination);

F.BufPos:= 0;

Result:= 0;

End;

Begin

Case F.Mode Of

fmInput:

Read(TStreamFileRecord(F.UserData));

fmOutput:

Write(TStreamFileRecord(F.UserData));

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.

Преобразование BMP в JPEG в Delphi 3

Используя Delphi 3, как мне сохранить BMP-изображение в JPEG-файле?

Допустим, Image1 – компонент TImage, содержащий растровое изображение. Используйте следующий фрагмент кода для конвертации вашего изображения в JPEG-файл:

var

MyJpeg: TJpegImage;

Image1: TImage;

begin

Image1:= TImage.Create;

MyJpeg:= TJpegImage.Create;

Image1.LoadFromFile('TestImage.BMP'); // Чтение изображения из файла

MyJpeg.Assign(Image1.Picture.Bitmap); // Назначание изображения объекту MyJpeg

MyJpeg.SaveToFile('MyJPEGImage.JPG'); // Сохранение на диске изображения в формате JPEG

end;

Декомпиляция звукового файла формата Wave и получение звуковых данных

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

У меня есть программа под D1/D2, которая читает WAV-файлы и вытаскивает исходные данные, но она не может их восстанавить, используя зашитый алгоритм сжатия.

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, OutFile: 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(OutFile, 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(OutFile,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(OutFile,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<MaxN then ChunkSize.dn := trunc(Ki.yyy[N+1]+0.5);

N:= N+2;

end else begin {1..4 Помещаем в буфер одноканальный 8-битный сэмпл}

for I:=0 to 3 do ChunkSize.chrs[I]:= trunc(Ki.yyy[N+I]+0.5);

N:= N+4;

end;

2:

if nBitsPerSample=16 then begin {2 Двухканальный 16-битный сэмпл}

ChunkSize.dn:= trunc(Ki.yyy[N]+0.5);

ChunkSize.up := trunc(Kj.yyy[N]+0.5);

N:= N+1;

end else begin {4 Двухканальный 8-битный сэмпл}

ChunkSize.chrs[1]:= trunc(Ki.yyy[N]+0.5);

ChunkSize.chrs[3]:= trunc(Ki.yyy[N+1]+0.5);

ChunkSize.chrs[0]:= trunc(Kj.yyy[N]+0.5);

ChunkSize.chrs[2]:= trunc(Kj.yyy[N+1]+0.5);

N:= N+2;

end;

end; {with wav do begin..}

end; {четырехбайтовая переменная "chunksize" теперь заполнена}

ChunkSize.x:=T1;

WriteChunkSize(ChunkSize.lint);{помещаем 4 байта данных}

end; {WriteOneDataBlock}

procedure WriteWAVFile(var Ki, Kj : Observation);

var MM: Byte;

I: Integer;

OK: Boolean;

begin

{Приготовления для записи файла данных}

AssignFile(OutFile, StandardOutput); { Файл, выбранный в диалоговом окне }

ReWrite(OutFile);

With ki.wav do begin

DataSize:= nChannels*(nBitsPerSample div 8)*(Ki.Last+1);

RIFFSize:= DataSize+36;

fmtSize:= 16;

end;

{Записываем ChunkName "RIFF"}

WriteChunkName('RIFF');

{Записываем ChunkSize}

WriteChunkSize(Ki.WAV.RIFFSize);

{Записываем ChunkName "WAVE"}

WriteChunkName('WAVE');

{Записываем tag "fmt_"}

WriteChunkName('fmt ');

{Записываем ChunkSize}

Ki.WAV.fmtSize:= 16; {должно быть 16-18}

WriteChunkSize(Ki.WAV.fmtSize);

{Записываем formatTag, nChannels}

WriteChunkWord(Ki.WAV.formatTag);

WriteChunkWord(Ki.WAV.nChannels);

{Записываем nSamplesPerSec}

WriteChunkSize(Ki.WAV.nSamplesPerSec);

{Записываем nAvgBytesPerSec}

WriteChunkSize(Ki.WAV.nAvgBytesPerSec);

{Записываем nBlockAlign, nBitsPerSample}

WriteChunkWord(Ki.WAV.nBlockAlign);

WriteChunkWord(Ki.WAV.nBitsPerSample);

{Записываем метку блока данных "data"}

WriteChunkName('data');

{Записываем DataSize}

WriteChunkSize(Ki.WAV.DataSize);

N:=0; {первая запись-позиция}

while N<=Ki.Last do WriteOneDataBlock(Ki,Kj);{помещаем 4 байта и увеличиваем счетчик n}

{Освобождаем буфер файла}

CloseFile(OutFile);

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 Ki.yyy[N+1]:=1.0*ChunkSize.dn;

N:= N+2;

end else begin {1..4 Помещаем в буфер одноканальный 8-битный сэмпл}

for I:=0 to 3 do Ki.yyy[N+I]:=1.0*ChunkSize.chrs[I];

N := N+4;

end;

2:

if nBitsPerSample=16 then begin {2 Двухканальный 16-битный сэмпл}

Ki.yyy[N]:=1.0*ChunkSize.dn;

Kj.yyy[N]:=1.0*ChunkSize.up;

N:= N+1;

end else begin {4 Двухканальный 8-битный сэмпл}

Ki.yyy[N]:=1.0*ChunkSize.chrs[1];

Ki.yyy[N+1]:=1.0*ChunkSize.chrs[3];

Kj.yyy[N]:=1.0*ChunkSize.chrs[0];

Kj.yyy[N+1]:=1.0*ChunkSize.chrs[2];

N:= N+2;

end;

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; {ReadOneDataBlock}

procedure ReadWAVFile(var Ki, K : 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<MaxNumberOfDataBaseItems then begin

Seek(DataBaseFile, N);

Read(DataBaseFile, Kk);

end else InitSignals(Kk);

end; {GetDatabaseItem}

procedure PutDatabaseItem(Kk : Observation; N : LongInt);

begin

if N<MaxNumberOfDataBaseItems then 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<LastDataBaseItem do begin

if Nstg = ItemNameS[ThisOne] then begin

FindDataBaseName:= ThisOne;

Exit;

end;

ThisOne:= ThisOne+1;

end;

end; {FindDataBaseName}

{======================= Инициализация модуля ========================}

procedure InitLinearSystem;

begin

BaseFileName:= '\PROGRA~1\SIGNAL~1\';

StandardOutput:= BaseFileName + 'K0.wav';

StandardInput:= BaseFileName + 'K0.wav';

StandardDataBase:= BaseFileName + 'Radar.sdb';

InitAllSignals;

InitDataBase;

ReadWAVFile(K0R,K0B);

ScaleAllData;

end; {InitLinearSystem}

begin {инициализируемый модулем код}

InitLinearSystem;

end. {Unit LinearSystem}

Даты

Вычисление даты Пасхи

function TtheCalendar.CalcEaster:String;

var B,D,E,Q:Integer;

GF:String;

begin

B:= 225-11*(Year Mod 19);

D:= ((B-21)Mod 30)+21;

If d>48 then Dec(D);

E:= (Year+(Year Div 4)+d+1) Mod 7;

Q:= D+7-E;

If q<32 then begin

If ShortDateFormat[1]='d' then Result:= IntToStr(Q)+'/3/'+IntToStr(Year)

else Result:='4/'+IntToStr(Q-31)+'/'+IntToStr(Year);

end else begin

If ShortDateFormat[1]='d' then Result:= IntToStr(Q-31)+'/4/'+IntToStr(Year)

else Result:='4/'+IntToStr(Q-31)+'/'+IntToStr(Year);

end;

{вычисление страстной пятницы}

If Q<32 then begin

If ShortDateFormat[1]='d' then GF:= IntToStr(Q-2)+'/3/'+IntToStr(Year)

else GF:='3/'+IntToStr(Q-2)+'/'+IntToStr(Year);

end else begin

If ShortDateFormat[1]='d' then GF:= IntToStr(Q-31-2)+'/4/'+IntToStr(Year)

else GF:='4/'+IntToStr(Q-31-2)+'/'+IntToStr(Year);

end;

Дни недели

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

Моя функция как раз этим и занимается.

unit datefunc;

interface

function checkdate(date : string): boolean;

function Date2julian(date : string): longint;

function Julian2date(julian : longint): string;

function DayOfTheWeek(date: string): string;

function idag: string;

implementation

uses sysutils;

function idag() : string;

{Получает текущую дату и возвращает ее в формате YYYYMMDD для использования

другими функциями данного модуля.}

var

Year, Month, Day: Word;

begin

DecodeDate(Now, Year, Month, Day);

result:= IntToStr(year)+ IntToStr(Month) +IntToStr(day);

end;

function Date2julian(date : string) : longint;

{Получает дату в формате YYYYMMDD.

Если у вас другой формат, в первую очередь преобразуйте его.}

var

month, day, year:integer;

ta, tb, tc : longint;

begin

month:= strtoint(copy(date,5,2));

day:= strtoint(copy(date,7,2));

year:= strtoint(copy(date,1,4));

if month > 2 then month:= month – 3

else begin

month:= month + 9;

year:= year – 1;

end;

ta:= 146097 * (year div 100) div 4;

tb:= 1461 * (year MOD 100) div 4;

tc:= (153 * month + 2) div 5 + day + 1721119;

result:= ta + tb + tc

end;

function mdy2date(month, day, year : integer): string;

var

y, m, d : string;

begin

y:= '000'+inttostr(year);

y:= copy(y,length(y)-3,4);

m:= '0'+inttostr(month);

m:= copy(m,length(m)-1,2);

d:= '0'+inttostr(day);

d:= copy(d,length(d)-1,2);

result:= y+m+d;

end;

function Julian2date(julian : longint): string;

{Получает значение и возвращает дату в формате YYYYMMDD}

var

x,y,d,m : longint;

month,day,year : integer;

begin

x:= 4 * julian – 6884477;

y:= (x div 146097) * 100;

d:= (x MOD 146097) div 4;

x:= 4 * d + 3;

y:= (x div 1461) + y;

d:= (x MOD 1461) div 4 + 1;

x:= 5 * d – 3;

m:= x div 153 + 1;

d:= (x MOD 153) div 5 + 1;

if m < 11 then month:= m + 2

else month:= m – 10;

day:= d;

year:= y + m div 11;

result:= mdy2date(month, day, year);

end;

function checkdate(date : string): boolean;

{Дата должна быть в формате YYYYMMDD.}

var

julian: longint;

test: string;

begin

{Сначала преобразовываем строку в юлианский формат даты.

Это позволит получить необходимое значение.}

julian:= Date2julian(date);

{Затем преобразовываем полученную величину в дату.

Это всегда будет правильной датой. Для проверки делаем обратное преобразование.

Результат проверки передаем как выходной параметр функции.}

test:= Julian2date(julian);

if date = test then result:= true

else result:= false;

end;

function DayOfTheWeek(date : string): string;

{Получаем дату в формате YYYYMMDD и возвращаем день недели.}

var

julian: longint;

begin

julian:= (Date2julian(date)) MOD 7;

case julian of

0: result:= 'Понедельник';

1: result := 'Вторник';

2: result:= 'Среда';

3: result:= 'Четверг';

4: result:= 'Пятница';

5: result:= 'Суббота';

6: result:= 'Воскресенье';

end;

end.

Формат даты

У меня есть неотложная задача: в настоящее время я разрабатываю проект, где я должен проверять достоверность введенных дат с применением маски __/__/____, например 12/12/1997.

Некоторое время назад я делал простой шифратор/дешифратор дат, проверяющий достоверность даты. Код приведен ниже.

function CheckDateFormat(SDate: string): string;

var

IDateChar: string;

x,y: integer;

begin

IDateChar:='.,\/';

for y:=1 to length(IDateChar) do begin

x:= pos(IDateChar[y],SDate);

while x>0 do begin

Delete(SDate,x,1);

Insert('-',SDate,x);

x:= pos(IDateChar[y],SDate);

end;

CheckDateFormat:= SDate;

end;

function DateEncode(SDate:string):longint;

var

year, month, day: longint;

wy, wm, wd: longint;

Dummy: TDateTime;

Check: integer;

begin

DateEncode:= -1;

SDate:= CheckDateFormat(SDate);

Val(Copy(SDate,1,pos('-',SDate)-1),day,check);

Delete(Sdate,1,pos('-',SDate));

Val(Copy(SDate,1,pos('-',SDate)-1),month,check);

Delete(SDate,1,pos('-',SDate));

Val(SDate,year,check);

wy:= year;

wm:= month;

wd:= day;

try

Dummy:= EncodeDate(wy,wm,wd);

except

year:= 0;

month:= 0;

day:= 0;

end;

DateEncode:= (year*10000)+(month*100)+day;

end;

Функция DateSer

Привет, я хочу в качестве совета поделиться функцией DateSer, которую я написал перед этим на VB. Данная функция весьма полезна но, к сожалению, ее нет в Delphi. Применяется она так:

DecodeDate(Date,y,m,d);

NewDate:= DateSer(y-4,m+254,d+1234);

или приблизительно так….

function DateSer(y,m,d: Integer): TDateTime;

const

mj: array[1..12] of integer=(31,28,31,30,31,30,31,31,30,31,30,31);

var

add: Integer;

begin

while (true) do begin

y:=y+(m-1) div 12;

m:= (m-1) mod 12 +1;

if m<=0 then begin

Inc(m,12);

Dec(y);

end;

if ((y mod 4 = 0) and ((y mod 100<>0) or (y mod 400=0))) and (m=2) then add:=1 //дополнительный день в феврале

else add:=0;

if (d>0) and (d<=(mj[m]+add)) then break;

if d>0 then begin Dec(d,mj[m]+add); Inc(m); end

else begin Inc(d,mj[m]+add); Dec(m); end;

end;

Result:=EncodeDate(y,m,d);

end;

Разное

Ханойская башня

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

type

THanoiBin = 0..2;

THanoiLevel = 0..9;

procedure MoveDisc(FromPin, ToPin : THanoiPin; Level : THanoiLevel);

// Это Вы должны сделать сами. Переместите один диск с одного штырька на другой.

// Диск окажется наверху (естественно, выше него дисков не будет)

Вы можете каким угодно образом перемещать диски 3-х пирамид. 3 пирамиды – наиболее простая разновидность алгоритма. Таким образом процедура переноса диска (MoveDisc) аналогична операции переноса диска на верхний уровень (MoveTopDisc): переместить диск наверх с одного штырька (FromPin) на другой штырек (ToPin) и передать указатель на штырек-приемник (MoveTower) вместе с уровнем расположения перемещенного диска. Другое решение заключается в использовании трех массивов [THanoiLevel] логического типа. В этом случае триггер "Истина (True)" означает наличие на пирамиде диска с размером, соответствующим порядковому номеру элемента массива THanoiLevel.

procedure MoveTower(FromPin, ToPin : THanoiPin; Level : THanoiLevel);

begin

if HanoiLevel <= High(THanoiLevel) then begin

MoveTower(FromPin, 3 – FromPin – ToPin, Level + 1);

MoveDisc(FromPin, ToPin, Level);

MoveTower(3 – FromPin – ToPin, ToPin, Level + 1);

end;

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

MoveTower(0, 1, Low(THanoiLevel));

Алгоритм (уравнение) для определения восхода/захода солнца и луны (BASIC)

Я нашел алгоритм, написанный на BASIC и вычисляющий восход-заход солнца и восход-заход луны. Может кто-нибудь сможет перенести это на Pascal?

(в случае чего сообщите мне по адресу st_evil@mail.ru)

10 ' Восход-заход солнца

20 GOSUB 300

30 INPUT "Долгота (град)";B5,L5

40 INPUT "Часовая зона (час)";H

50 L5=L5/360: Z0=H/24

60 GOSUB 1170: T=(J-2451545)+F

70 TT=T/36525+1: ' TT = столетия,

80 ' начиная с 1900.0

90 GOSUB 410: T=T+Z0

100 '

110 ' Получаем положение солнца

120 GOSUB 910: A(1)=A5: D(1)=D5

130 T=T+1

140 GOSUB 910: A(2)=A5: D(2)=D5

150 IF A(2)<A(1) THEN A(2)=A(2)+P2

160 Z1=DR*90.833: ' Вычисление зенита

170 S=SIN(B5*DR): C=COS(B5*DR)

180 Z=COS(Z1): M8=0: W8=0: PRINT

190 A0=A(1): D0=D(1)

200 DA=A(2)-A(1): DD=D(2)-D(1)

210 FOR C0=0 TO 23

220 P=(C0+1)/24

230 A2=A(1)+P*DA: D2=D(1)+P*DD

240 GOSUB 490

250 A0=A2: D0=D2: V0=V2

260 NEXT

270 GOSUB 820: ' Вывод информации?

280 END

290 '

300 ' Константы

310 DIM A(2),D(2)

320 P1=3.14159265: P2=2*P1

330 DR=P1/180: K1=15*DR*1.0027379

340 S$="Заход солнца в "

350 R$="Восход солнца в "

360 M1$="В этот день солнце не восходит"

370 M2$="В этот день солнце не заходит"

380 M3$="Солнце заходит весь день"

390 M4$="Солнце восходит весь день"

400 RETURN

410 ' Получение часового пояса

420 T0=T/36525

430 S=24110.5+8640184.813*T0

440 S=S+86636.6*Z0+86400*L5

450 S=S/86400: S=S-INT(S)

460 T0=S*360*DR

470 RETURN

480 '

490 ' Просматриваем возможные события на полученный час

500 L0=T0+C0*K1: L2=L0+K1

510 H0=L0-A0: H2=L2-A2

520 H1=(H2+H0)/2: ' Часовой угол,

530 D1=(D2+D0)/2: ' наклон в

540 ' получасе

550 IF C0>0 THEN 570

560 V0=S*SIN(D0)+C*COS(D0)*COS(H0)-Z

570 V2=S*SIN(D2)+C*COS(D2)*COS(H2)-Z

580 IF SGN(V0)=SGN(V2) THEN 800

590 V1=S*SIN(D1)+C*COS(D1)*COS(H1)-Z

600 A=2*V2-4*V1+2*V0: B=4*V1-3*V0-V2

610 D=B*B-4*A*V0: IF D<0 THEN 800

620 D=SQR(D)

630 IF V0<0 AND V2>0 THEN PRINT R$;

640 IF V0<0 AND V2>0 THEN M8=1

650 IF V0>0 AND V2<0 THEN PRINT S$;

660 IF V0>0 AND V2<0 THEN W8=1

670 E=(-B+D)/(2*A)

680 IF E>1 OR E<0 THEN E=(-B-D)/(2*A)

690 T3=C0+E+1/120: ' Округление

700 H3=INT(T3): M3=INT((T3-H3)*60)

710 PRINT USING "##:##";H3;M3;

720 H7=H0+E*(H2-H0)

730 N7=-COS(D1)*SIN(H7)

740 D7=C*SIN(D1)-S*COS(D1)*COS(H7)

750 AZ=ATN(N7/D7)/DR

760 IF D7<0 THEN AZ=AZ+180

770 IF AZ<0 THEN AZ=AZ+360

780 IF AZ>360 THEN AZ=AZ-360

790 PRINT USING ", азимут ###.#";AZ

800 RETURN

810 '

820 ' Процедура вывода информации

830 IF M8=0 AND W8=0 THEN 870

840 IF M8=0 THEN PRINT M1$

850 IF W8=0 THEN PRINT M2$

860 GOTO 890

870 IF V2<0 THEN PRINT M3$

880 IF V2>0 THEN PRINT M4$

890 RETURN

900 '

910 ' Фундаментальные константы

920 ' (Van Flandern &

930 ' Pulkkinen, 1979)

940 L=.779072+.00273790931*T

950 G=.993126+.0027377785*T

960 L=L-INT(L): G=G-INT(G)

970 L=L*P2: G=G*P2

980 V=.39785*SIN(L)

990 V=V-.01000*SIN(L-G)

1000 V=V+.00333*SIN(L+G)

1010 V=V-.00021*TT*SIN(L)

1020 U=1-.03349*COS(G)

1030 U=U-.00014*COS(2*L)

1040 U=U+.00008*COS(L)

1050 W=-.00010-.04129*SIN(2*L)

1060 W=W+.03211*SIN(G)

1070 W=W+.00104*SIN(2*L-G)

1080 W=W-.00035*SIN(2*L+G)

1090 W=W-.00008*TT*SIN(G)

1100 '

1110 ' Вычисление солнечных координат

1120 S=W/SQR(U-V*V)

1130 A5=L+ATN(S/SQR(1-S*S))

1140 S=V/SQR(U):D5=ATN(S/SQR(1-S*S))

1150 R5=1.00021*SQR(U)

1160 RETURN

1165 '

1170 ' Календарь –> JD

1180 INPUT "Год, Месяц, День";Y,M,D

1190 G=1: IF Y<1583 THEN G=0

1200 D1=INT(D): F=D-D1-.5

1210 J=-INT(7*(INT((M+9)/12)+Y)/4)

1220 IF G=0 THEN 1260

1230 S=SGN(M-9): A=ABS(M-9)

1240 J3=INT(Y+S*INT(A/7))

1250 J3=-INT((INT(J3/100)+1)*3/4)

1260 J=J+INT(275*M/9)+D1+G*J3

1270 J=J+1721027+2*G+367*Y

1280 IF F>=0 THEN 1300

1290 F=F+1: J=J-1

1300 RETURN

1310 '

1320 ' Программа вычисляет время восхода и захода

1330 ' солнца по дате (с точностью до минуты) в пределах

1340 ' нескольких текущих столетий. Производит корректировку, если географическая

1350 ' точка находится в арктичиском или антарктическом регионе, где заход или восход солнца

1360 ' на текущую дату может не состояться. Вводимые данные: положительная северная широта и

1370 ' отрицательная западная долгота. Часовой пояс указывается относительно Гринвича

1380 ' (например, 5 для EST и 4 для EDT). Алгоритм обсуждался в

1390 ' "Sky & Telescope" за август 1994, страница 84.

Автоматический формат даты в компоненте Edit

PROCEDURE TForm1.Edit1Exit(Sender: TObject);

BEGIN

IF Edit1.Text<>'' THEN BEGIN

TRY

StrToDate(Edit1.Text);

EXCEPT

Edit1.SetFocus;

MessageBeep(0);

raise Exception.Create('"'+Edit1.Text + '&quot – некорректная дата');

END {try};

Edit1.Text:= DateToStr(StrToDate(Edit1.Text));

END{if};

END;

Оглавление