unit Kalender;
//   Copyright ©1999 Thomas Franz; 98617 Meiningen-Dreißigacker (Germany)
//   E-Mail: tf_meiningen@gmx.de

//   Diese Unit darf kostenlos und uneingeschränkt genutzt werden.

//   Es wird keinerlei Haftung für Schäden, die durch die Benutzung dieser
//   Unit entstehen übernommen. Die vollständige Funktion aller Funktionen
//   und Prozeduren kann nicht garantiert werden.

interface

uses SysUtils;

type TFeiertag = record
                       Datum: TDateTime;
                       Titel: String;
                 end;
     TFeiertagAllg = array[0..8] of TFeiertag;
     TFeiertagKath = array[0..3] of TFeiertag;
     TFeiertagEvan = TFeiertag;
var x: Word;
procedure Ostern(const Jahr: Word; var Tag, Monat: Word); overload; // ermittelt wann im angegebenen Jahr Ostersonntag (Rückgabe in Tag / Monat) war/ist (gültig für Jahre 532 - 2499)
function Ostern(const Jahr: Word): TDateTime; overload;
procedure Karfreitag(const Jahr: Word; var Tag, Monat: Word); overload;
function Karfreitag(const Jahr: Word): TDateTime; overload;
procedure Aschermittwoch(const Jahr: Word; var Tag, Monat: Word); overload;
function Aschermittwoch(const Jahr: Word): TDateTime; overload;
procedure Himmelfahrt(const Jahr: Word; var Tag, Monat: Word); overload;
function Himmelfahrt(const Jahr: Word): TDateTime; overload;
procedure Pfingsten(const Jahr: Word; var Tag, Monat: Word); overload; // ermittelt wann im angegebenen Jahr der Pfingstsonntag (Rückgabe in Tag / Monat) war/ist (gültig für Jahre 532 - 2499)
function Pfingsten(const Jahr: Word): TDateTime; overload;
procedure Fronleichnam(const Jahr: Word; var Tag, Monat: Word); overload;
function Fronleichnam(const Jahr: Word): TDateTime; overload;
function Totensonntag(const Jahr: Word): TDateTime; overload;
procedure Totensonntag(const Jahr: Word; var Tag, Monat: Word); overload;
function Advent(const Jahr: Word): TDateTime; overload;
procedure Advent(const Jahr: Word; var Tag, Monat: Word); overload;
function Sommerzeit(const Jahr: Word): TDateTime; overload;
procedure Sommerzeit(const Jahr: Word; var Tag, Monat: Word); overload;
function Winterzeit(const Jahr: Word): TDateTime; overload;
procedure Winterzeit(const Jahr: Word; var Tag, Monat: Word); overload;
function Schaltjahr(const Jahr: Word): Boolean;
procedure FAllgemein(const Jahr: Word; var DateList: TFeiertagAllg); // allgemeine Feiertage
procedure FKatholisch(const Jahr: Word; var DateList: TFeiertagKath); // katholische Feiertage
procedure FEvangelisch(const Jahr: Word; var DateList: TFeiertag); // evangelische Feiertage

// Datum / Zeit (siehe auch Unit Kalender)
function Tag(Date: TDateTime): Word;
function Monat(Date: TDateTime): Word;
function Jahr(Date: TDateTime; Stellen: Integer = 4): Integer;
function Stunde(Date: TDateTime): Word;
function Minute(Date: TDateTime): Word;
function Sekunde(Date: TDateTime): Word;
function Millisekunde(Date: TDateTime): Word;

function TagS(Date: TDateTime; Stellen: Integer = 2): String; // 1 oder 2
function MonatS(Date: TDateTime; Stellen: Integer = 2): String; // Stellen = 1: ohne führende Null; 2: führende Null; 3: Monatskürzel; 4: Monat ausgeschrieben
function JahrS(Date: TDateTime; Stellen: Integer = 4): String; // 2 oder 4
function StundeS(Date: TDateTime; Stellen: Integer = 2): String;
function MinuteS(Date: TDateTime; Stellen: Integer = 2): String;
function SekundeS(Date: TDateTime; Stellen: Integer = 2): String;
function MillisekundeS(Date: TDateTime; Stellen: Integer = 2): String;

function MonatsErster(Date:TDateTime): TDateTime;
function MonatsLetzter(Date:TDateTime): TDateTime;


implementation

procedure Ostern(const Jahr: Word; var Tag, Monat: Word); // ermittelt wann im angegebenen Jahr Ostersonntag (Rückgabe in Tag / Monat) war/ist (gültig für Jahre 532 - 2499)
{ Diese Prozedur ermittelt nach der Gaußschen Osterformel von C.F. Gauss genau
  nach kirchlichen Vorschriften das Datum des Ostersonntages in einem beliebigen
  Jahr zwischen 532 und 2499.

  Im Jahr 532 traten die Ostertafeln des Dionysius Exiguus in Kraft.

  Die Osterformel galt mit Einschränkungen auch schon fast 100 Jahre früher,
  weshalb ich in den CASE-Kästen das früheste Jahr mit 325 angegeben habe.

  Ostern wurde im Jahre 325 n.Chr. durch das Konzil von Nicäa verbindlich für die
  ganze Christenheit auf den Sonntag nach dem ersten Frühjahrsvollmond festgelegt.

  Der früheste Termin kann demnach der 22. März, der späteste Termin der 25. April
  sein (26. April wird auf den 19. vorverlegt).}
var a,b,c,d,e : Integer;
    M,N : Byte;
begin
M := 1; N := 1; // Dummyaufrufe damit Meldung Variable M/N wurde wahrscheinlich nicht initialisiert nicht kommt

if not ((325 < Jahr) and (Jahr < 2499)) then // Jahr vor 325 (Konzil von Nicäa) oder nach 2499
   begin
        Tag := 0;
        Monat := 0;
        exit;
   end;
case Jahr of // Zahlen stammen aus der sog. Epaktenrechnung
      325   .. 1582 : M := 15;
     1583 .. 1699 : M := 22;
     1700 .. 1899 : M := 23;
     1900 .. 2199 : M := 24;
     2200 .. 2299 : M := 25;
     2300 .. 2399 : M := 26;
     2400 .. 2499 : M := 25;
end; //case
case Jahr of // Zahlen stammen aus der sog. Epaktenrechnung
        0 .. 1582 : N := 6;
     1583 .. 1699 : N := 2;
     1700 .. 1799 : N := 3;
     1800 .. 1899 : N := 4;
     1900 .. 2099 : N := 5;
     2100 .. 2199 : N := 6;
     2200 .. 2299 : N := 0;
     2300 .. 2499 : N := 1;
end; //case
b := (Jahr mod 4);
a := (Jahr Mod 19);
c := (Jahr mod 7);
d := ((19 * a + M) mod 30);
e := ((2 * b + 4 * c + 6 * d + N) mod 7);
Tag := d + e + 22;
Monat := 3; // März
if Tag > 31 then
   begin
        Tag := d + e - 9;
        Monat := 4; // April
   end;
if (Tag = 26) and (Monat = 4) then Tag := 19; // Sonderregelung des Konzils von Nicäa (z.B. 1981 und 2076)
if (Tag = 25) and (Monat = 4) and (a > 10) and (d = 28) and (Jahr >= 1583 {Gregorianischer Kalender})
   then Tag := 18; // z. B. 1954 und 2049
end;

function Ostern(const Jahr: Word): TDateTime;
var Monat, Tag : Word;
begin
Ostern(Jahr, Tag, Monat);
Result := EncodeDate(Jahr, Monat, Tag);
end;

procedure Karfreitag(const Jahr: Word; var Tag, Monat: Word);
begin
DecodeDate(Karfreitag(Jahr), x, Monat, Tag);
end;

function Karfreitag(const Jahr: Word): TDateTime;
begin Result := Ostern(Jahr) -2; end;

procedure Aschermittwoch(const Jahr: Word; var Tag, Monat: Word);
begin
DecodeDate(Aschermittwoch(Jahr), x, Monat, Tag);
end;

function Aschermittwoch(const Jahr: Word): TDateTime;
begin Result := Ostern(Jahr) -46; end;

procedure Himmelfahrt(const Jahr: Word; var Tag, Monat: Word);
begin
DecodeDate(Himmelfahrt(Jahr), x, Monat, Tag);
end;

function Himmelfahrt(const Jahr: Word): TDateTime;
begin Result := Ostern(Jahr) +39; end;

procedure Pfingsten(const Jahr: Word; var Tag, Monat: Word);
begin
DecodeDate(Pfingsten(Jahr), x, Monat, Tag);
end;

function Pfingsten(const Jahr: Word): TDateTime;
begin Result := Ostern(Jahr) + 49; end;

procedure Fronleichnam(const Jahr: Word; var Tag, Monat: Word);
begin
DecodeDate(Fronleichnam(Jahr), x, Monat, Tag);
end;

function Fronleichnam(const Jahr: Word): TDateTime;
begin Result := Ostern(Jahr) +60; end;

function Schaltjahr(const Jahr: Word): Boolean;
begin
Result := False;
if (Jahr mod 4) = 0 then Result := True;
if (Jahr mod 100 = 0) and (Jahr mod 400 <> 0) then Result := False;
end;

function Totensonntag(const Jahr: Word): TDateTime; overload;
begin
Result := Advent(Jahr) - 7;
end;

procedure Totensonntag(const Jahr: Word; var Tag, Monat: Word); overload;
begin
DecodeDate(Totensonntag(Jahr), x, Monat, Tag);
end;

function Advent(const Jahr: Word): TDateTime; overload;
begin
Result := EncodeDate(Jahr, 12, 24) - DayOfWeek(EncodeDate(Jahr, 12, 24)) - 20;
end;

procedure Advent(const Jahr: Word; var Tag, Monat: Word); overload;
begin
DecodeDate(Advent(Jahr), x, Monat, Tag);
end;


function Sommerzeit(const Jahr: Word): TDateTime; overload;
begin
Result := EncodeDate(Jahr, 03, 31) - DayOfWeek(EncodeDate(Jahr, 03, 31)) + 1;
end;

procedure Sommerzeit(const Jahr: Word; var Tag, Monat: Word); overload;
begin
DecodeDate(Sommerzeit(Jahr), x, Monat, Tag);
end;

function Winterzeit(const Jahr: Word): TDateTime; overload;
begin
if Jahr > 1995 then
   Result := EncodeDate(Jahr, 10, 31) - DayOfWeek(EncodeDate(Jahr, 10, 31)) + 1
else
   Result := EncodeDate(Jahr, 09, 30) - DayOfWeek(EncodeDate(Jahr, 09, 30)) + 1
end;

procedure Winterzeit(const Jahr: Word; var Tag, Monat: Word); overload;
begin
DecodeDate(Winterzeit(Jahr), x, Monat, Tag);
end;

procedure FAllgemein(const Jahr: Word; var DateList: TFeiertagAllg); // allgemeine Feiertage
begin
DateList[0].Datum := EncodeDate(Jahr, 1, 1); DateList[0].Titel := 'Neujahr';
DateList[1].Datum := Karfreitag(Jahr); DateList[1].Titel := 'Karfreitag';
DateList[2].Datum := Ostern(Jahr) + 1; DateList[2].Titel := 'Ostermontag';
DateList[3].Datum := EncodeDate(Jahr, 5, 1); DateList[3].Titel := '1. Maifeiertag';
DateList[4].Datum := Himmelfahrt(Jahr); DateList[4].Titel := 'Christi Himmelfahrt';
DateList[5].Datum := Pfingsten(Jahr) + 1; DateList[5].Titel := 'Pfingsten';
DateList[6].Datum := EncodeDate(Jahr, 10, 3); DateList[6].Titel := 'Tag der deutschen Einheit';
DateList[7].Datum := EncodeDate(Jahr, 12, 25); DateList[7].Titel := 'Erster Weihnachtsfeiertag';
DateList[8].Datum := EncodeDate(Jahr, 12, 26); DateList[8].Titel := 'Zweiter Weihnachtsfeiertag';
end;

procedure FKatholisch(const Jahr: Word; var DateList: TFeiertagKath); // katholische Feiertage
begin
DateList[0].Datum := EncodeDate(Jahr, 1, 6); DateList[0].Titel := 'Heilige Drei Könige';
DateList[1].Datum := Fronleichnam(Jahr) + 1; DateList[1].Titel := 'Fronleichnam';
DateList[2].Datum := EncodeDate(Jahr, 8, 15); DateList[2].Titel := 'Mariä Himmelfahrt';
DateList[3].Datum := EncodeDate(Jahr, 11, 1); DateList[3].Titel := 'Allerheiligen';
end;

procedure FEvangelisch(const Jahr: Word; var DateList: TFeiertag); // evangelische Feiertage
begin
DateList.Datum := EncodeDate(Jahr, 10, 31);  DateList.Titel := 'Reformationstag';
end;



//****************
//* Datum / Zeit *
//****************
function Tag(Date: TDateTime): Word; var d, m, y: Word; begin DecodeDate(Date, y, m, d); Result := d; end;
function Monat(Date: TDateTime): Word; var d, m, y: Word; begin DecodeDate(Date, y, m, d); Result := m; end;
function Jahr(Date: TDateTime; Stellen: Integer = 4): Integer;
         var d, m, y: Word;
         begin
              DecodeDate(Date, y, m, d);
              Result := y;
              if Stellen = 2 then Result := Trunc(Result - Int(Result / 100) * 100);
         end;
function Stunde(Date: TDateTime): Word; var h, m, s, ms: Word; begin DecodeTime(Date, h, m, s, ms); Result := h; end;
function Minute(Date: TDateTime): Word; var h, m, s, ms: Word; begin DecodeTime(Date, h, m, s, ms); Result := m; end;
function Sekunde(Date: TDateTime): Word; var h, m, s, ms: Word; begin DecodeTime(Date, h, m, s, ms); Result := s; end;
function Millisekunde(Date: TDateTime): Word; var h, m, s, ms: Word; begin DecodeTime(Date, h, m, s, ms); Result := ms; end;

function MonatsErster(Date:TDateTime): TDateTime;
begin
Result := Date - Tag(Date) + 1;
end;

function MonatsLetzter(Date:TDateTime): TDateTime;
begin
Result := IncMonth(Date, 1) - Tag(Date);
end;


function TagS(Date: TDateTime; Stellen: Integer = 2): String;
begin
Result := IntToStr(Tag(Date));
if (Stellen = 2) and (Length(Result) = 1) then Result := '0' + Result;
end;

function MonatS(Date: TDateTime; Stellen: Integer = 2): String;
const MK : array[1..12] of String = ('Jan', 'Feb', 'Mär', 'Apr', 'Mai', 'Jun', 'Jul', 'Aug', 'Sep', 'Okt', 'Nov', 'Dez');
      ML : array[1..12] of String = ('Januar', 'Februar', 'März', 'April', 'Mai', 'Juni', 'Juli', 'August', 'September', 'Oktober', 'November', 'Dezember');
begin
Result := IntToStr(Monat(Date));
if (Stellen = 2) and (Length(Result) = 1) then Result := '0' + Result;
if Stellen = 3 then Result := MK[Monat(Date)];
if Stellen > 3 then Result := ML[Monat(Date)];
end;

function JahrS(Date: TDateTime; Stellen: Integer = 4): String;
begin
Result := IntToStr(Jahr(Date, Stellen));
if (Stellen = 2) and (Length(Result) = 1) then Result := '0' + Result;
end;

function StundeS(Date: TDateTime; Stellen: Integer = 2): String;
begin
Result := IntToStr(Stunde(Date));
if (Stellen = 2) and (Length(Result) = 1) then Result := '0' + Result;
end;

function MinuteS(Date: TDateTime; Stellen: Integer = 2): String;
begin
Result := IntToStr(Minute(Date));
if (Stellen = 2) and (Length(Result) = 1) then Result := '0' + Result;
end;

function SekundeS(Date: TDateTime; Stellen: Integer = 2): String;
begin
Result := IntToStr(Sekunde(Date));
if (Stellen = 2) and (Length(Result) = 1) then Result := '0' + Result;
end;

function MillisekundeS(Date: TDateTime; Stellen: Integer = 2): String;
begin
Result := IntToStr(Millisekunde(Date));
if (Stellen = 2) and (Length(Result) = 1) then Result := '0' + Result;
end;

end.