Валентин Озеров - Советы по Delphi. Версия 1.0.6 Страница 5

   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;

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;

end.

Формат даты

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

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

function CheckDateFormat(SDate: string): string;

var

 IDateChar: string;

 x,y: integer;

begin