Календари, даты и летоисчисление

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

2013-09-16T14:44:46+07:00

Автор: Mark Lussier

Code:

function TtheCalendar.CalcEaster: string;

var

B, D, E, Q: Integer;

GF: string;

begin

B := 225 - 11 * (Year mod19);

D := ((B - 21) mod30) + 21;

if D > 48then

Dec(D);

E := (Year + (Year div4) + D + 1) mod7;

Q := D + 7 - E;

if Q < 32then

begin

if ShortDateFormat[1] = 'd'then

Result := IntToStr(Q) + '/3/' + IntToStr(Year)

else

Result := '3/' + IntToStr(Q) + '/' + 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 < 32then

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;

https://delphiworld.narod

DelphiWorld 6.0

Code:

function Easter(Year: Integer): TDateTime;

{----------------------------------------------------------------}

{ Вычисляет и возвращает день Пасхи определенного года. }

{ Идея принадлежит Mark Lussier, AppVision <MLussier@>. }

{ Скорректировано для предотвращения переполнения целых, если по }

{ ошибке передан год с числом 6554 или более. }

{----------------------------------------------------------------}

var

nMonth, nDay, nMoon, nEpact, nSunday,

nGold, nCent, nCorx, nCorz: Integer;

begin

{ Номер Золотого Года в 19-летнем Metonic-цикле: }

nGold := (Year mod19) + 1;

{ Вычисляем столетие: }

nCent := (Year div100) + 1;

{ Количество лет, в течение которых отслеживаются високосные года... }

{ для синхронизации с движением солнца: }

nCorx := (3 * nCent) div4 - 12;

{ Специальная коррекция для синхронизации Пасхи с орбитой луны: }

nCorz := (8 * nCent + 5) div25 - 5;

{ Находим воскресенье: }

nSunday := (Longint(5) * Year) div4 - nCorx - 10;

{ ^ Предохраняем переполнение года за отметку 6554}

{ Устанавливаем Epact - определяем момент полной луны: }

nEpact := (11 * nGold + 20 + nCorz - nCorx) mod30;

if nEpact < 0then

nEpact := nEpact + 30;

if ((nEpact = 25) and (nGold > 11)) or (nEpact = 24) then

nEpact := nEpact + 1;

{ Ищем полную луну: }

nMoon := 44 - nEpact;

if nMoon < 21then

nMoon := nMoon + 30;

{ Позиционируем на воскресенье: }

nMoon := nMoon + 7 - ((nSunday + nMoon) mod7);

if nMoon > l 31then

begin

nMonth := 4;

nDay := nMoon - 31;

end

else

begin

nMonth := 3;

nDay := nMoon;

end;

Easter := EncodeDate(Year, nMonth, nDay);

end; {Easter}

https://delphiworld.narod

DelphiWorld 6.0

Примечание от Vit: что-то настораживает меня тот факт что автор кода имеет "западную" фамилию, почти наверняка код этот вычисляет время наступления католической Пасхи или иудейского праздника Пейсах (неправильно именуемого в просторечье "еврейской пасхой"), а вовсе не православной Пасхи. Православная пасха обычно сдвинута на неделю вперёд, но бывают и исключения (доподлинно алгоритм вычисления мне неизвестен), а потому пользоваться кодом надо с оглядкой...

Дни в месяце

2013-09-16T15:56:17+07:00

Автор: РевенкоАлексей

Code:

// Колическтво дней в любом месяце любого

// года можно получить с помощью EndOfAMonth

var

YYYY, MM, DD: Word;

D: TDateTime;

begin

DecodeDate(Date, YYYY, MM, DD);

D := EndOfAMonth(YYYY, {Номер месяца});

DecodeDate(D, YYYY, MM, DD); // DD - номер последнего дня в месяце

end;

https://delphiworld.narod

DelphiWorld 6.0

Получить число дней в месяце

Code:

function DaysOfMonth(mm, yy: Integer): Integer;

begin

if mm = 2then

begin

Result := 28;

if IsLeapYear(yy) then Result := 29;

end

else

begin

if mm < 8then

begin

if (mm mod2) = 0then

Result := 30

else

Result := 31;

end

else

begin

if (mm mod2) = 0then

Result := 31

else

Result := 30;

end;

procedure TForm1.Button1Click(Sender: TObject);

var

days: Integer;

begin

days := DaysOfMonth(7, 2001);

ShowMessage('July 2001 has ' + IntToStr(days) + ' days');

end;

https://delphiworld.narod

DelphiWorld 6.0

Code:

function LastDayOfCurrentMonth: TDate;

var

y, m, d: Word;

begin

DecodeDate(now, y, m, d);

m := m + 1;

if m 12then

begin

y := y + 1;

m := 1;

end;

Result := EncodeDate(y, m, 1) - 1;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

ShowMessage(DateToStr(LastDayOfCurrentMonth));

end;

https://delphiworld.narod.

Как получить по Юлианскому календарю дату?

2013-09-16T15:47:23+07:00

Code:

function julian(year, month, day: Integer): real;

var

yr, mth: Integer;

noleap, leap, days, yrs: Real;

begin

if year < 0then yr := year + 1else yr := year;

mth := month;

if (month < 3) then

begin

mth := mth + 12;

yr := yr - 1;

end;

yrs := 365.25 * yr;

if ((yrs < 0) and (frac(yrs) <> 0)) then yrs := int(yrs) - 1else yrs := int(yrs);

days := int(yrs) + int(30.6001 * (mth + 1)) + day - 723244.0;

if days < -145068.0then julian := days

else

begin

yrs := yr / 100.0;

if ((yrs < 0) and (frac(yrs) <> 0)) then yrs := int(yrs) - 1;

noleap := int(yrs);

yrs := noleap / 4.0;

if ((yrs < 0) and (frac(yrs) <> 0)) then yrs := int(yrs) - 1;

leap := 2 - noleap + int(yrs);

julian := days + leap;

end;

Взято с Delphi Knowledge Base: https://www.baltsoft.

Конвертируем Unix дату

2013-09-16T16:08:41+07:00

The value is a Unix Time, defined as seconds since 1970-01-01T00:00:00,0Z. Important is the Letter Z, you live in Sweden, in consequence you must add 1 hour for StandardDate and 2 hours for DaylightDate to the date. The infos you can get with GetTimeZoneInformation. But you must determine, which Bias (Standard or Daylight) is valid for the date (in this case -60). You can convert the date value with the function below.

The Date for 977347109 is 2000-12-20T22:18:29+01:00.

Code:

const

UnixDateDelta = 25569; { 1970-01-01T00:00:00,0 }

SecPerMin = 60;

SecPerHour = SecPerMin * 60;

SecPerDay = SecPerHour * 24;

MinDayFraction = 1 / (24 * 60);

{Convert Unix time to TDatetime}

function UnixTimeToDateTime(AUnixTime: DWord; ABias: Integer): TDateTime;

begin

Result := UnixDateDelta + (AUnixTime div SecPerDay) { Days }

+ ((AUnixTime mod SecPerDay) / SecPerDay) { Seconds }

- ABias * MinDayFraction { Bias to UTC in minutes };

end;

{Convert Unix time to String with locale settings}

function UnixTimeToStr(AUnixTime: DWord; ABias: Integer): string;

begin

Result := FormatDateTime('ddddd hh:nn:ss', UnixTimeToDateTime(AUnixTime, ABias));

end;

{Convert TDateTime to Unix time}

function DateTimeToUnixTime(ADateTime: TDateTime; ABias: Integer): DWord;

begin

Result := Trunc((ADateTime - UnixDateDelta) * SecPerDay) + ABias * SecPerMin;

end;

procedure TForm1.Button4Click(Sender: TObject);

begin

Label1.Caption := UnixTimeToStr(977347109, -60);

end;

Взято с Delphi Knowledge Base: https://www.baltsoft.

Определение восхода и захода солнца и луны

2013-09-16T15:54:55+07:00

Автор: Александр Ермолаев

Code:

program sunproject;

uses

Forms,

main in'main.pas'{Sun};

{$R *.RES}

begin

Application.Initialize;

Application.Title := 'Sun';

Application.CreateForm(TSun, Sun);

Application.Run;

end.

Code:

object Sun: TSun

Left = 210

Top = 106

BorderIcons = [biSystemMenu, biMinimize]

BorderStyle = bsSingle

Caption = 'Sun'

ClientHeight = 257

ClientWidth = 299

Color = clBtnFace

Font.Charset = DEFAULT_CHARSET

Font.Color = clWindowText

Font.Height = -11

Font.Name = 'MS Sans Serif'

Font.Style = []

OldCreateOrder = False

Position = poDesktopCenter

OnCreate = CreateForm

PixelsPerInch = 96

TextHeight = 13

object GroupBoxInput: TGroupBox

Left = 4

Top = 4

Width = 173

Height = 93

Caption = ' Ввод '

TabOrder = 0

object LabelLongitude: TLabel

Left = 35

Top = 44

Width = 78

Height = 13

Alignment = taRightJustify

Caption = 'Долгота (град):'

end

object LabelTimeZone: TLabel

Left = 13

Top = 68

Width = 100

Height = 13

Alignment = taRightJustify

Caption = 'Часовая зона (час):'

end

object LabelAtitude: TLabel

Left = 40

Top = 20

Width = 73

Height = 13

Alignment = taRightJustify

Caption = 'Широта (град):'

end

object EditB5: TEdit

Tag = 1

Left = 120

Top = 16

Width = 37

Height = 21

TabOrder = 0

Text = '0'

end

object EditL5: TEdit

Tag = 2

Left = 120

Top = 40

Width = 37

Height = 21

TabOrder = 1

Text = '0'

end

object EditH: TEdit

Tag = 3

Left = 120

Top = 64

Width = 37

Height = 21

TabOrder = 2

Text = '0'

end

object GroupBoxCalendar: TGroupBox

Left = 184

Top = 4

Width = 109

Height = 93

Caption = ' Календарь '

TabOrder = 1

object LabelD: TLabel

Left = 19

Top = 20

Width = 30

Height = 13

Alignment = taRightJustify

Caption = 'День:'

end

object LabelM: TLabel

Left = 13

Top = 44

Width = 36

Height = 13

Alignment = taRightJustify

Caption = 'Месяц:'

end

object LabelY: TLabel

Left = 28

Top = 68

Width = 21

Height = 13

Alignment = taRightJustify

Caption = 'Год:'

end

object EditD: TEdit

Tag = 1

Left = 56

Top = 16

Width = 37

Height = 21

TabOrder = 0

Text = '0'

end

object EditM: TEdit

Tag = 2

Left = 56

Top = 40

Width = 37

Height = 21

TabOrder = 1

Text = '0'

end

object EditY: TEdit

Tag = 3

Left = 56

Top = 64

Width = 37

Height = 21

TabOrder = 2

Text = '0'

end

object ButtonCalc: TButton

Left = 12

Top = 227

Width = 169

Height = 25

Caption = '&Вычислить'

TabOrder = 2

OnClick = ButtonCalcClick

end

object ListBox: TListBox

Left = 4

Top = 104

Width = 289

Height = 117

ItemHeight = 13

TabOrder = 3

end

object ButtonClear: TButton

Left = 192

Top = 227

Width = 91

Height = 25

Caption = '&Очистить'

TabOrder = 4

OnClick = ButtonClearClick

end

Code:

{

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

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

нескольких текущих столетий. Производит корректировку, если

географическая

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

или восход солнца

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

северная широта и

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

Гринвича

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

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

}

unit main;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,

Dialogs,

StdCtrls;

type

TSun = class(TForm)

GroupBoxInput: TGroupBox;

LabelLongitude: TLabel;

EditB5: TEdit;

EditL5: TEdit;

LabelTimeZone: TLabel;

EditH: TEdit;

GroupBoxCalendar: TGroupBox;

LabelD: TLabel;

LabelM: TLabel;

LabelY: TLabel;

EditD: TEdit;

EditM: TEdit;

EditY: TEdit;

ButtonCalc: TButton;

ListBox: TListBox;

ButtonClear: TButton;

LabelAtitude: TLabel;

procedure Calendar; // Календарь

procedure GetTimeZone; // Получение часового пояса

procedure PosOfSun; // Получаем положение солнца

procedure OutInform; // Процедура вывода информации

procedure PossibleEvents(Hour: integer); // Возможные события на

полученный час

procedure GetDate; //Получить значения даты

procedure GetInput; //Получить значения широты,...

procedure ButtonCalcClick(Sender: TObject);

procedure CreateForm(Sender: TObject);

procedure ButtonClearClick(Sender: TObject);

private

function Sgn(Value: Double): integer; // Сигнум

public

{ Public declarations }

end;

var

Sun: TSun;

st: string;

aA, aD: array[1..2] of double;

B5: integer;

L5: double;

H: integer;

Z, Z0, Z1: double;

D: double;

M, Y: integer;

A5, D5, R5: double;

J3: integer;

T, T0, TT, T3: double;

L0, L2: double;

H0, H1, H2, H7, N7, D7: double;

H3, M3: integer;

M8, W8: double;

A, B, A0, D0, A2, D1, D2, DA, DD: double;

E, F, J, S, C, P, L, G, V, U, W: double;

V0, V1, V2: double;

C0: integer;

AZ: double;

const

P2 = Pi * 2; // 2 * Pi

DR = Pi / 180; // Радиан на градус

K1 = 15 * DR * 1.0027379;

implementation

{$R *.DFM}

function TSun.Sgn(Value: Double): integer;

begin

{if Value = 0 then} Result := 0;

if Value > 0then

Result := 1;

if Value < 0then

Result := -1;

end;

procedure TSun.Calendar;

begin

G := 1;

if Y < 1583then

G := 0;

D1 := Trunc(D);

F := D - D1 - 0.5;

J := -Trunc(7 * (Trunc((M + 9) / 12) + Y) / 4);

if G = 1then

begin

S := Sgn(M - 9);

A := Abs(M - 9);

J3 := Trunc(Y + S * Trunc(A / 7));

J3 := -Trunc((Trunc(J3 / 100) + 1) * 3 / 4);

end;

J := J + Trunc(275 * M / 9) + D1 + G * J3;

J := J + 1721027 + 2 * G + 367 * Y;

if F >= 0then

Exit;

F := F + 1;

J := J - 1;

end;

procedure TSun.GetTimeZone;

begin

T0 := T / 36525;

S := 24110.5 + 8640184.813 * T0;

S := S + 86636.6 * Z0 + 86400 * L5;

S := S / 86400;

S := S - Trunc(S);

T0 := S * 360 * DR;

end;

procedure TSun.PosOfSun;

begin

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

// (Van Flandern & Pulkkinen, 1979)

L := 0.779072 + 0.00273790931 * T;

G := 0.993126 + 0.0027377785 * T;

L := L - Trunc(L);

G := G - Trunc(G);

L := L * P2;

G := G * P2;

V := 0.39785 * Sin(L);

V := V - 0.01000 * Sin(L - G);

V := V + 0.00333 * Sin(L + G);

V := V - 0.00021 * TT * Sin(L);

U := 1 - 0.03349 * Cos(G);

U := U - 0.00014 * Cos(2 * L);

U := U + 0.00008 * Cos(L);

W := -0.00010 - 0.04129 * Sin(2 * L);

W := W + 0.03211 * Sin(G);

W := W + 0.00104 * Sin(2 * L - G);

W := W - 0.00035 * Sin(2 * L + G);

W := W - 0.00008 * TT * Sin(G);

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

S := W / Sqrt(U - V * V);

A5 := L + ArcTan(S / Sqrt(1 - S * S));

S := V / Sqrt(U);

D5 := ArcTan(S / Sqrt(1 - S * S));

R5 := 1.00021 * Sqrt(U);

end;

procedure TSun.PossibleEvents(Hour: integer);

var

num: string;

begin

st := '';

L0 := T0 + Hour * K1;

L2 := L0 + K1;

H0 := L0 - A0;

H2 := L2 - A2;

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

D1 := (D2 + D0) / 2; // наклон в получасе

if Hour <= 0then

V0 := S * Sin(D0) + C * Cos(D0) * Cos(H0) - Z;

V2 := S * Sin(D2) + C * Cos(D2) * Cos(H2) - Z;

if Sgn(V0) = Sgn(V2) then

Exit;

V1 := S * Sin(D1) + C * Cos(D1) * Cos(H1) - Z;

A := 2 * V2 - 4 * V1 + 2 * V0;

B := 4 * V1 - 3 * V0 - V2;

D := B * B - 4 * A * V0;

if D < 0then

Exit;

D := Sqrt(D);

if (V0 < 0) and (V2 > 0) then

st := st + 'Восход солнца в ';

if (V0 < 0) and (V2 > 0) then

M8 := 1;

if (V0 > 0) and (V2 < 0) then

st := st + 'Заход солнца в ';

if (V0 > 0) and (V2 < 0) then

W8 := 1;

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

if (E > 1) or (E < 0) then

E := (-B - D) / (2 * A);

T3 := Hour + E + 1 / 120; // Округление

H3 := Trunc(T3);

M3 := Trunc((T3 - H3) * 60);

Str(H3: 2, num);

st := st + num + ':';

Str(M3: 2, num);

st := st + num;

H7 := H0 + E * (H2 - H0);

N7 := -Cos(D1) * Sin(H7);

D7 := C * Sin(D1) - S * Cos(D1) * COS(H7);

AZ := ArcTan(N7 / D7) / DR;

if (D7 < 0) then

AZ := AZ + 180;

if (AZ < 0) then

AZ := AZ + 360;

if (AZ > 360) then

AZ := AZ - 360;

Str(AZ: 4: 1, num);

st := st + ', азимут ' + num;

end;

procedure TSun.OutInform;

begin

if (M8 = 0) and (W8 = 0) then

begin

if V2 < 0then

ListBox.Items.Add('Солнце заходит весь день ');

if V2 > 0then

ListBox.Items.Add('Солнце восходит весь день ');

end

else

begin

if M8 = 0then

ListBox.Items.Add('В этот день солнце не восходит ');

if W8 = 0then

ListBox.Items.Add('В этот день солнце не заходит ');

end;

procedure TSun.GetDate;

begin

D := StrToInt(EditD.text);

M := StrToInt(EditM.text);

Y := StrToInt(EditY.text);

end;

procedure TSun.GetInput;

begin

B5 := StrToInt(EditB5.Text);

L5 := StrToInt(EditL5.Text);

H := StrToInt(EditH.Text);

end;

procedure TSun.ButtonCalcClick(Sender: TObject);

var

C0: integer;

begin

GetDate;

GetInput;

ListBox.Items.Add('Широта: ' + EditB5.Text +

' Долгота: ' + EditL5.Text +

' Зона: ' + EditH.Text +

' Дата: ' + EditD.Text +

'/' + EditM.Text +

'/' + EditY.Text);

L5 := L5 / 360;

Z0 := H / 24;

Calendar;

T := (J - 2451545) + F;

TT := T / 36525 + 1; // TT - столетия, начиная с 1900.0

GetTimeZone; // Получение часового пояса

T := T + Z0;

PosOfSun; // Получаем положение солнца

aA[1] := A5;

aD[1] := D5;

T := T + 1;

PosOfSun;

aA[2] := A5;

aD[2] := D5;

if aA[2] < aA[1] then

aA[2] := aA[2] + P2;

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

S := Sin(B5 * DR);

C := Cos(B5 * DR);

Z := Cos(Z1);

M8 := 0;

W8 := 0;

A0 := aA[1];

D0 := aD[1];

DA := aA[2] - aA[1];

DD := aD[2] - aD[1];

for C0 := 0to23do

begin

P := (C0 + 1) / 24;

A2 := aA[1] + P * DA;

D2 := aD[1] + P * DD;

PossibleEvents(C0);

if st <> ''then

ListBox.Items.Add(st);

A0 := A2;

D0 := D2;

V0 := V2;

end;

OutInform;

ListBox.Items.Add(''); // Разделяем данные

end;

procedure TSun.CreateForm(Sender: TObject);

begin

EditD.Text := FormatDateTime('d', Date);

EditM.Text := FormatDateTime('m', Date);

EditY.Text := FormatDateTime('yyyy', Date);

end;

procedure TSun.ButtonClearClick(Sender: TObject);

begin

ListBox.Clear;

end;

end.

https://delphiworld.narod

Получить даты с понедельника по пятницу текущей недели

2013-09-16T16:09:40+07:00

Code:

{

Data sometimes have to be filtered regarding to working

days (Mo.-Fri.) of the current Week. Following procs set

your TDateTimePicker automatically.

}

function GetMonday(RefDay: TDate): TDate;

var

DoW: Integer;

DateOffset: Integer;

begin

DoW := DayOfWeek(RefDay);

// Montag der Woche

if DoW = 1then DateOffset := -6

else

DateOffset := Dow - 2;

Result := RefDay - DateOffset;

end;

function GetFriday(RefDay: TDate): TDate;

var

DoW: Integer;

DateOffset: Integer;

begin

DoW := DayOfWeek(RefDay);

{

Friday of current week

Freitag der Woche

}

if DoW = 1then DateOffset := -2

else

DateOffset := Dow - 6;

Result := RefDay - DateOffset;

end;

procedure SetWorkingDaysFilter(S, E: TDateTimePicker);

var

N: TDate;

begin

N := Now;

S.Date := GetMonday(N);

E.Date := GetFriday(N);

end;

{Just as short as simple}

{Einfach und kurz}

type

TForm1 = class(TForm)

DStart: TDateTimePicker;

DEnd: TDateTimePicker;

btSetFilter: TButton;

procedure btSetFilterClick(Sender: TObject);

end;

procedure TForm1.btSetFilterClick(Sender: TObject);

begin

SetWorkingDaysFilter(DStart, DEnd);

end;

https://delphiworld.narod

Получить номер дня в году

2013-09-16T16:10:42+07:00

Code:

function GetDays(ADate: TDate): Extended;

var

FirstOfYear: TDateTime;

begin

FirstOfYear := EncodeDate(StrToInt(FormatDateTime('yyyy', now)) - 1, 12, 31);

Result := ADate - FirstOfYear;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

label1.Caption := 'Today is the ' + FloatToStr(GetDays(Date)) + '. day of the year';

end;

Взято с сайта: https://www.swissdelphicenter

Преобразовать Персидскую дату в дату по Грегорианскому календарю

2013-09-16T14:54:04+07:00

Code:

function Persia_to_Ger_date(aa: ShortString; ResultKind: Byte = 0): ShortString;

function TrueTo1(co: Boolean): Integer;

begin

if co then TrueTo1 := 1

else

TrueTo1 := 0;

end;

const

Conm_mons: array[0..11] of Byte = (31,28,31,30,31,30,31,31,30,31,30,31);

LeapYearSh: array[0..4] of Integer = (1375,1379,1383,1387,1391);

LeapYearMi: array[0..4] of Integer = (1996,2000,2004,2008,2012);

monthes: array[0..11] of ShortString = ('Jan', 'Feb', 'Mar', 'Apr',

'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');

type

date = record

da_day, da_mon, da_year: Integer;

end;

var

m_mons: array[0..11] of BYTE;

LastDayCountSh, LastDayCountMi: integer;

a, b: date;

sYY, sMM, sDD: ShortString;

I: Integer;

begin

for I := Low(Conm_mons) to High(Conm_mons) do

m_mons[I] := Conm_mons[I];

a.da_day := StrToNum(Copy(aa, DayPosInDate, DayLen));

a.da_mon := StrToNum(Copy(aa, MonthPosInDate, MonthLen));

a.da_year := StrToNum(Copy(aa, YearPosInDate, YearLen));

b.da_year := a.da_year + 621;

Inc(b.da_year, TrueTo1(((a.da_mon > 10) or ((a.da_mon = 10) and (a.da_day >= 12)))

or ((LeapYearSh[(a.da_year - 1374) div4] <> a.da_year) and

((a.da_mon = 10) and (a.da_day = 11)))));

Inc(m_mons[1], TrueTo1(LeapYearMi[(b.da_year - 1996) div4] = b.da_year));

if (a.da_mon <= 7) then LastDayCountSh := ((a.da_mon - 1) * 31 + a.da_day)

else

LastDayCountSh := (186 + (a.da_mon - 7) * 30 + a.da_day);

if (b.da_year = (a.da_year + 622)) then LastDayCountMi :=

LastDayCountSh - 286 - TrueTo1(LeapYearSh[(a.da_year - 1375) div4] = a.da_year)

else

LastDayCountMi := (LastDayCountSh + 79);

b.da_day := LastDayCountMi;

b.da_mon := 0;

while (LastDayCountMi > m_mons[b.da_mon]) do

begin

Dec(LastDayCountMi, m_mons[b.da_mon]);

Inc(b.da_mon);

b.da_day := LastDayCountMi;

end;

Inc(b.da_mon);

if b.da_year < 1000then sYY := sYY + '0';

if b.da_year < 100then sYY := sYY + '0';

if b.da_year < 10then sYY := sYY + '0';

sYY := sYY + IntToStr(b.da_year);

if b.da_mon < 10then sMM := sMM + '0';

sMM := sMM + IntToStr(b.da_mon);

if b.da_day < 10then sDD := sDD + '0';

sDD := sDD + IntToStr(b.da_day);

case ResultKind of

0: Persia_to_Ger_date := sYY + '/' + sMM + '/' + sDD;

1: Persia_to_Ger_date := sYY + ' ' + monthes[b.da_mon - 1] + ' ' + sDD;

end;

Взято с сайта: https://www.swissdelphicenter

Проверка правильности даты

2013-09-16T15:57:32+07:00

Code:

function DateExists(Date: string; Separator: char): Boolean;

var

OldDateSeparator: Char;

begin

Result := True;

OldDateSeparator := DateSeparator;

DateSeparator := Separator;

try

StrToDate(Date);

except

Result := False;

end;

finally

DateSeparator := OldDateSeparator;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

if DateExists('35.3.2001', '.') then

begin

{your code}

end;

Взято с Delphi Knowledge Base: https://www.baltsoft

Code:

function ValidDate(const S: String): Boolean;

BEGIN

Result := True;

try

StrToDate(S);

except

ON EConvertError DO

Result := False;

end;

END

https://delphiworld.narod

DelphiWorld 6.0

Программа рисует на форме календарь на 2002 год

2013-09-16T16:11:38+07:00

В связи с наступающим Новым годом я решил посвятить выпуск календарю. Ниже приведенная программа рисует на форме календарь на 2002 год. Для каждого месяца сначала выводится его название (используется глобальная переменная LongMonthNames модуля SysUtils), далее выводятся сокращенные названия дней недели (глобальная переменная ShortDayNames модуля SysUtils) и, наконец, выводятся сами числа. Количество дней в месяце записано в массиве months. Чтобы определить, високосный это год или нет, используется функция IsLeapYear.

Code:

const year = 2002; // Год календаря

var months: array [1..12] of byte;

procedure TForm1.FormCreate(Sender: TObject);

begin

Form1.Caption := 'Календарь на ' + IntToStr(year) + ' год';

Form1.Color := clWhite;

// Длины месяцев:

months[1] := 31;

months[2] := 28 + ord(IsLeapYear(year));

months[3] := 31;

months[4] := 30;

months[5] := 31;

months[6] := 30;

months[7] := 31;

months[8] := 31;

months[9] := 30;

months[10] := 31;

months[11] := 30;

months[12] := 31;

end;

procedure TForm1.FormPaint(Sender: TObject);

const// Настройки размеров календаря:

MonthDX = 150;

MonthDY = 135;

DayDX = 20;

DayDY = 15;

MonthH = 20;

var

month, i: integer;

day: integer;

s: string[2];

begin

with Form1.Canvas dofor month := 1to12dobegin

// Вывод названия месяца:

Font.Name := 'Times';

Font.Size := 13;

TextOut((month - 1) mod3 * MonthDX, (month - 1) div3 * MonthDY,

LongMonthNames[month]);

Font.Name := 'Courier';

Font.Size := 8;

// Вывод названий дней недели:

for day := 1to7do

TextOut((month - 1) mod3 * MonthDX,

day mod7 * DayDY + (month - 1) div3 * MonthDY + MonthH,

ShortDayNames[(day + 1) mod7 + 1]);

// Определение дня недели первого числа месяца:

day := DayOfWeek(EncodeDate(year, month, 1)) - 2;

if day < 0then inc(day, 7);

// Вывод чисел:

for i := 1to months[month] dobegin

str(i: 2, s);

TextOut(day div7 * DayDX + (month - 1) mod3 * MonthDX + DayDX,

day mod7 * DayDY + (month - 1) div3 * MonthDY + MonthH, s);

inc(day);

end;

https://delphiworld.narod

Число текущей недели

2013-09-16T16:12:46+07:00

Code:

function WeekOfYear(ADate: TDateTime): word;

var

day: word;

month: word;

year: word;

FirstOfYear: TDateTime;

begin

DecodeDate(ADate, year, month, day);

FirstOfYear := EncodeDate(year, 1, 1);

Result := Trunc(ADate - FirstOfYear) div7 + 1;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

ShowMessage(IntToStr(WeekOfYear(Date)));

end;

https://delphiworld.narod

DelphiWorld 6.0

Code:

function WeekNum(const ADate: TDateTime): word;

var

Year: word;

Month: word;

Day: word;

begin

DecodeDate(ADate + 4 - DayOfWeek(ADate + 6), Year, Month, Day);

result := 1 + trunc((ADate - EncodeDate(Year, 1, 5) +

DayOfWeek(EncodeDate(Year, 1, 3))) / 7);

end;

https://delphiworld.narod

DelphiWorld 6.0

Code:

function WeekOfYear(Dat: TDateTime): Word;

// Интерпретация номеров дней:

// ISO: 1 = Понедельник, 7 = Воскресенье

// Delphi SysUtils: 1 = Воскресенье, 7 = Суббота

var

Day, Month, Year: Word;

FirstDate: TDateTime;

DateDiff: Integer;

begin

day := SysUtils.DayOfWeek(Dat) - 1;

Dat := Dat + 3 - ((6 + day) mod7);

DecodeDate(Dat, Year, Month, Day);

FirstDate := EncodeDate(Year, 1, 1);

DateDiff := Trunc(Dat - FirstDate);

Result := 1 + (DateDiff div7);

end;

©Drkb::00742

https://delphiworld.narod