Zeitreise 1996: Datumsklasse

Zeitreise 1996: Datumsklasse

Saturday, November 24th, 2007 | Developers Corner, Pascal/Delphi | admin

Süß. Der Streifzug durch die Festplatten vergangener Tage fängt allmählich an, richtig Spass zu machen.

Ich habe eben eine Pascal-Unit gefunden, die ich 1996 schrieb, um mir Datumsberechnungen zu erleichtern. Hierin finden sich einige recht sinnvolle Umsetzungen von Klassen und Funktionen zum Thema Datum und Zeit. Außerdem habe ich noch das hier gefunden: waschechter 16bit Assembler!

1996 * 1996 * 1996 * 1996 * 1996 * 1996 * 1996 * 1996 * 1996 * 1996 * 1996 * 1996

Direkt ins Auge schossen dabei folgende Code-Segmente:

{ TDateItem }
procedure TDateItem.Assign(ADay, AMonth, AYear: word); assembler;
asm
        LES     DI,Self
        CLD
        MOV     AX,ADay
        STOSB
        MOV     AX,AMonth
        STOSB
        MOV     AX,AYear
        STOSW
end;

So wurde damals unter PASCAL der Speed erhöht. Da schlägt das alte Programmierer-Herz doch direkt wieder höher

Oder hier: der Assembler-Code wurde ausgeklammert, vielleicht weil er nicht funktionierte. Stattdessen reichte ein Move-Befehl aus. TDateItem ist zwar eine Klasse. Da aber ObjectPascal erst dann einen MFT anlegte, wenn virtuelle Methode zum Einsatz kamen, konnte man hier eine Klassen-Instanz wie einen Record behandeln und die dereferenzierte Objekt-Instanz einfach kopieren, um eine Kopie der Member-Variablen zu erreichen:

procedure TDateItem.CopyFrom(D: TDateItem);
{asm
        PUSH    DS
        LDS     SI,D
        LES     DI,Self
        CLD
        MOVSB
        MOVSB
        MOVSW
        POP     DS}
begin
  Move(D, self, SizeOf(TDateItem));
end;

Das Interface der 96er Datumsklasse wirkt auch heute noch richtig schnuckelig:

Klasse TDateItem:

 
{ Typen für zeitliche Daten }
  TDayType = 1..MaxDayInMonth;  {1..31}
  TMonthType = 1..12;
  TYearType = 1900..2060;
 
{ TDateItem }
{ Object für Speicherung von einem zeitl. Datum}
  PDateItem = ^TDateItem;
  TDateItem = object
    Day: TDayType;
    Month: TMonthType;
    Year: TYearType;
    procedure Assign(ADay, AMonth, AYear: word);
    { setzt die Felder auf  }
    procedure AssignToday;
    { setzt die Felder Day, Month, Year auf die Werte in D }
    procedure CopyFrom(D: TDateItem);
    { setzt Felder aus LongDate }
    procedure CopyFromLong(D: TLongDate);
    { belegt einen TLongDate-Record mit aktuellen Werten }
    procedure CopyToLong(var D: TLongDate);
    { gibt true zurück, wenn die Werte aus D diesen Werten entsprechen }
    function Equals(D: TDateItem): boolean;
    { berechnet den Wochentag. Result ist daySunday...daySaturday }
    function GetDayOfWeek: byte;
    { berechnet den Tag vor dem Tag in diesem Object }
    procedure GetLastDay(var D: TDateItem);
    { gibt den vollständigen Monat und das Jahr aus }
    function GetMYText: string;
    { berechnet den x. Tag ab dem Tag in diesem Object }
    procedure GetNextXDate(Days: integer; var D: TDateItem);
    { berechnet den nächsten Tag }
    procedure GetNextDay(var D: TDateItem);
    { berechnet den nächsten Monat }
    procedure GetNextMonth(var D: TDateItem);
    { gibt den Vormat zurück }
    procedure GetPreMonth(var D: TDateItem);
    { gibt das Datum in Form DAY.MONTH.YEAR }
    function GetText: string;
    { gibt das Datum in Form WEEKDAY(2 Chars), DAY.MONTH.YEAR }
    function GetW2Text: string;
    { gibt das Datum normal aus, jedoch Monat ausgeschrieben }
    function GetNMText: string;
    { prüft, ob der Tag in ADate der Vortag zu self ist }
    function IsPreDay(ADate: TDateItem): boolean;
    function IsToday: boolean;
    { zählt Tage vom akt. Datum rückwärts, bis er auf einen Sonntag stößt }
    { und speichert diesen in Date }
    { ist self bereits ein Sonntag, so wird zum Sonntag davor gesprungen }
    procedure LastWeekEnd(var Date: TDateItem);
    procedure Load(var S: TStream);
    { liefert den letzten Tag des Monats Month,Year zurück }
    function MaxDayMonth: byte;
    { speichert die entsprechenden Daten in einen Record TDateFormatRec }
    procedure PutFormatRec(var Rec: TDateFormatRec);
    procedure Reset(ADay, AMonth, AYear: word);
    procedure Store(var S: TStream);
    function Valid(const Inform: boolean): TDateError;
    end;

Kerngegenstand der Überlegungen hierfür bestand in der Entwicklung eines Programmes zur Dienstplanberechnung für Krankenhäuser. Wie bei jeder anderen Programmiersprache auch heute noch anzutreffen, stellte PASCAL nur recht rudimentäre Datums-Funktionen/Prozeduren bereit.

Bei solchen Kalkulationen reichen Datumsklassen nicht immer aus. Ein Pendant bezogen auf den “Monat” als solchen habe ich damals direkt im Anschluß angefügt:

Klasse TMonthItem:

 
TWeekItem = object
    Monday: TDateItem;
    Sunday: TDateItem;
    end;
 
  TWeeks = array[1..7] of TWeekItem;
 
  PMonthItem = ^TMonthItem;
  TMonthItem = object
    Month: word;
    Year: word;
    WeekCount: byte;
    Weeks: TWeeks;
    procedure Assign(AMonth, AYear: word);
    procedure CalcWeeks;
    function DayIsWhichWeek(const Day: word): byte;
    function FirstDayOfMonth: byte;
    function LastDay: byte;
    function LastDayOfMonth: byte;
  private
    procedure CalcFirstWeek;
    procedure CalcNextWeek(First: TWeekItem; var Next: TWeekItem);
    end;

Fragt mich nicht, warum ein Monat bei mir damals 7 Wochen aufnehmen konnte. Ich vermute den Grund darin, das die Woche vor dem Monat und die Woche nach dem Monat ebenfalls erfasst wurden, weil ein Monat nunmal nicht immer an einem Montag anfängt. Bleibt noch eine Woche (die 7.) übrig…. Wer weiss….

Datumsobjekte treten bei Dienstplanberechnungen vor allem in Listen auf und sollten chronologisch sortiert werden können. Deshalb findet sich im vorliegenden Code natürlich auch das:

Klasse TDatelist:

 
{ TDateList }
{ Object zur Speicherung von einer Liste mit zeitlichen Daten }
  PDateList = ^TDateList;
  TDateList = object(TSortCollection)
    constructor Init;
    function Compare(Key1, Key2: Pointer): integer; virtual;
    function CompareList(AList: PDateList; var FoundItem: PDateItem;
      var FoundIndex: word): boolean; virtual;
    procedure DeleteOldDates(AListDate: TListDate);
    { überprüft, ob das Item bereits in der Liste existiert und gibt }
    { den Index des gefunden Items wieder oder -1 nei nichtfinden}
    function EqualItem(Item: PDateItem; var Index: integer): boolean;
    { Error-Prozedur }
    procedure Error(Code, Info: integer); virtual;
    { gibt true zurück, wenn das DateItem bereits in der Liste existiert }
    function FoundSame(Item: PDateItem): boolean; virtual;
    procedure Insert(Item: Pointer); virtual;
    function KeyOf(Item: Pointer): Pointer; virtual;
    end;

TDateList erbt in zweiter Instanz von der in TurboVision bereits vorhandenen TSortedCollection.

Natürlich gab es auch eine Time-Klasse:

Klasse TTimeItem:

 { TimeItem }
 
  PTimeItem = ^TTimeItem;
  TTimeItem = object
    S, M, H: byte;
    procedure Assign(const AHour, AMin, ASec: byte);
    procedure AssignWord(const AHour, AMin, ASec: word);
    { setzt Werte auf aktuelle Zeit }
    procedure AssignNow;
    procedure CopyFrom(const Time: TTimeItem);
    function Equals(const Time: TTimeItem): boolean;
    procedure Load(var Stream: TStream);
    procedure Store(var Stream: TStream);
    end;

Noch ein wenig Lust auf Assembler bekommen?

Ich auch:

Stringoperationen waren in PASCAL sehr teuer und je nach Anwendung recht unperformant. Somit musste ich die Methode, die ein Datum als String formatiert, in Assembler schreiben. Dieser Schritt erhöhte die Performance deutlich.

Klasse TDateItem:GetText():

 
{ For GetText }
 
procedure AXtoString; assembler;
const
  Zehn: word = 10;
  Ausgabe: array[0..5] of char = '';
asm
     PUSH AX
     PUSH BX
     PUSH DX
     PUSH DI
@@1: xor dx,dx
     div zehn
     or dl,30h
     MOV DS:[BX+(OFFSET Ausgabe-1)],DL
     dec bx
     jnz @@1
     POP DI
     POP DX
     POP BX
     PUSH BX
     MOV CX,BX
     MOV BX,1
@@2: MOV DL,DS:[BX+(OFFSET Ausgabe-1)]
     MOV AL,DL
     STOSB
     INC BX
     LOOP @@2
     POP BX
     POP AX
end;
 
procedure GetDateText(Day, Month, Year: word; var Rslt: string);
begin
  asm
    LES  DI,DWORD PTR Rslt
    CLD
    INC  DI
    { Tag }
    MOV  AX,Day
    MOV  BX,2
    CALL AXToString
    { Punkt }
    MOV AL,'.'
    STOSB
    { Monat }
    MOV  AX,Month
    MOV  BX,2
    CALL AXtoString
    { Punkt }
    MOV AL,'.'
    STOSB
    JMP @@4
@@4:{ Jahr }
    MOV  AX,Year
    MOV  BX,4
    CALL AXtoString
    { Gesamtlänge bestimmen }
    MOV  AX,DI
    LES  DI,DWORD PTR Rslt
    SUB  AX,DI
    DEC  AL
    STOSB
  end;
end;
 
function GetDateTextF(Day, Month, Year: word): string;
begin
  asm
    LES  DI,@Result
    CLD
    INC  DI
    { Tag }
    MOV  AX,Day
    MOV  BX,2
    CALL AXToString
    { Punkt }
    MOV AL,'.'
    STOSB
    { Monat }
    MOV  AX,Month
    MOV  BX,2
    CALL AXtoString
    { Punkt }
    MOV AL,'.'
    STOSB
    JMP @@4
@@4:{ Jahr }
    MOV  AX,Year
    MOV  BX,4
    CALL AXtoString
    { Gesamtlänge bestimmen }
    MOV  AX,DI
    LES  DI,@Result
    SUB  AX,DI
    DEC  AL
    STOSB
  end;
end;

Anschließend der gesamte Code. Man möge beachten, das das ganze bereits 12 Jahre her ist.

Dies ist Programmcode von 1996. Er dient an dieser Stelle rein dokumentarischen Zwecken und gehört zu diesem Artikel. Allerdings gibt es eine gesundheitliche Einrichtung in diesem Land, die noch heute mit Programmen (ebenfalls von 1995-1997) arbeitet, die diesen Code verwenden .

:released under BSD Licence:

(**************************************************************************)
(*                                                                        *)
(*   Unit Dates (urspr�nglich f�r Klinik.EXE)                             *)
(*                                                                        *)
(*   - written by H. H�bel 04/1996 -                                      *)
(*                                                                        *)
(*   (C), (P) 1996 S.O.L.Productions/ruLe_eXcess & H. H�bel               *)
(*                                                                        *)
(**************************************************************************)
(*                                                                        *)
(*  Diese Unit enth�lt Konstanten, Typen, Objekte und Methoden f�r        *)
(*  numerische Datumsberechnungen.                                        *)
(*                                                                        *)
(**************************************************************************)
(*                                                                        *)
(*  Stream registration records:  ObjType $1005 - $1006                   *)
(*                                                                        *)
(**************************************************************************)
 
unit Dates;
 
{$F+,O+,I-,X+,S-,V-,A-}
{$C Fixed Preload Permanent}
 
interface
 
{$IFNDEF Windows}
uses Dos, Drivers, Objects, Memory;
{$ELSE}
uses WinDos, Objects;
{$ENDIF}
 
{$IFDEF Windows}
 
Type
 
  TByteSet = set of byte;
 
{$ENDIF}
 
{ Konstanten }
 
const
 
{maximale Anzahl der Tage eines Monats}
  MaxDayInMonth = 31;
 
{maximile Anzahl der Tage einer Zeitspanne (TDateDelta) }
  MaxDayDelta = 365;
 
{ Sortier-Konstanten f�r TDateCollection }
  DaySort = 0;
  MonthSort = 1;
  YearSort = 2;
 
{ Maximale Anzahl der Tage eines Monats - ohne Schaltjahr }
 
  MaxDayOfMonth: array[1..12] of byte =
    (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
 
  DayStr: array[0..6] of String[10] = (
    'Sonntag',
    'Montag',
    'Dienstag',
    'Mittwoch',
    'Donnerstag',
    'Freitag',
    'Samstag');
 
 
  Day2Str: array[0..6] of string[2] = (
    'So', 'Mo', 'Di', 'Mi', 'Do', 'Fr', 'Sa');
 
  MonthStr: array[1..12] of string[9] = (
    'Januar',
    'Februar',
    'M�rz',
    'April',
    'Mai',
    'Juni',
    'Juli',
    'August',
    'September',
    'Oktober',
    'November',
    'Dezember');
 
  Month3Str: array[1..12] of string[3] = (
    'Jan',
    'Feb',
    'M�r',
    'Apr',
    'Mai',
    'Jun',
    'Jul',
    'Aug',
    'Sep',
    'Okt',
    'Nov',
    'Dez');
 
  daySunday = 0;
  dayMonday = 1;
  dayTuesday = 2;
  dayWednesday = 3;
  dayThursday = 4;
  dayFriday = 5;
  daySaturday = 6;
 
  dayWeekEnd = [daySaturday, daySunday];
 
type
  TMon = (monCurrent, monJan, monFeb, monMar, monApr, monMai, monJun,
    monJul, monAug, monSep, monOct, monNov, monDec);
 
{ Typen }
 
type
 
{ Result:Valid-Methode von TDateItem, je nach dem welches Feld ung�ltig ist}
  TDateError = (dtsOK, dtsDay, dtsMonth, dtsYear);
 
{ Typen f�r zeitliche Daten }
  TDayType = 1..MaxDayInMonth;  {1..31}
  TMonthType = 1..12;
  TYearType = 1900..2060;
 
  PLongDate = ^TLongDate;
  TLongDate = object
    Day, Month, Year: LongInt;
    procedure AssignToday;
    function Equals(ADate: TLongDate): boolean;
    procedure GetNextDay(var ADate: TLongDate);
    { gibt den Vormat zur�ck }
    procedure GetPreMonth(var D: TLongDate);
    function GetText: string;
    end;
 
  PLongWeekDayDate = ^TLongWeekDayDate;
  TLongWeekDayDate = object
    WeekDay: PString;
    Day, Month, Year: LongInt;
    end;
 
{ record f�r einen Monat und ein Jahr }
  TListDate = record
    Month: byte;
    Year: word;
    end;
 
  {TDateFormatRec }
  {f�r FormatStr-Anweisungen }
  TDateFormatRec = record
    DOW: PString;
    Day, Month, Year: longint;
    end;
 
{ TDateItem }
{ Object f�r Speicherung von einem zeitl. Datum}
  PDateItem = ^TDateItem;
  TDateItem = object
    Day: TDayType;
    Month: TMonthType;
    Year: TYearType;
    procedure Assign(ADay, AMonth, AYear: word);
    { setzt die Felder auf <heute> }
    procedure AssignToday;
    { setzt die Felder Day, Month, Year auf die Werte in D }
    procedure CopyFrom(D: TDateItem);
    { setzt Felder aus LongDate }
    procedure CopyFromLong(D: TLongDate);
    { belegt einen TLongDate-Record mit aktuellen Werten }
    procedure CopyToLong(var D: TLongDate);
    { gibt true zur�ck, wenn die Werte aus D diesen Werten entsprechen }
    function Equals(D: TDateItem): boolean;
    { berechnet den Wochentag. Result ist daySunday...daySaturday }
    function GetDayOfWeek: byte;
    { berechnet den Tag vor dem Tag in diesem Object }
    procedure GetLastDay(var D: TDateItem);
    { gibt den vollst�ndigen Monat und das Jahr aus }
    function GetMYText: string;
    { berechnet den x. Tag ab dem Tag in diesem Object }
    procedure GetNextXDate(Days: integer; var D: TDateItem);
    { berechnet den n�chsten Tag }
    procedure GetNextDay(var D: TDateItem);
    { berechnet den n�chsten Monat }
    procedure GetNextMonth(var D: TDateItem);
    { gibt den Vormat zur�ck }
    procedure GetPreMonth(var D: TDateItem);
    { gibt das Datum in Form DAY.MONTH.YEAR }
    function GetText: string;
    { gibt das Datum in Form WEEKDAY(2 Chars), DAY.MONTH.YEAR }
    function GetW2Text: string;
    { gibt das Datum normal aus, jedoch Monat ausgeschrieben }
    function GetNMText: string;
    { pr�ft, ob der Tag in ADate der Vortag zu self ist }
    function IsPreDay(ADate: TDateItem): boolean;
    function IsToday: boolean;
    { z�hlt Tage vom akt. Datum r�ckw�rts, bis er auf einen Sonntag st��t }
    { und speichert diesen in Date }
    { ist self bereits ein Sonntag, so wird zum Sonntag davor gesprungen }
    procedure LastWeekEnd(var Date: TDateItem);
    procedure Load(var S: TStream);
    { liefert den letzten Tag des Monats Month,Year zur�ck }
    function MaxDayMonth: byte;
    { speichert die entsprechenden Daten in einen Record TDateFormatRec }
    procedure PutFormatRec(var Rec: TDateFormatRec);
    procedure Reset(ADay, AMonth, AYear: word);
    procedure Store(var S: TStream);
    function Valid(const Inform: boolean): TDateError;
    end;
 
type
  TWeekItem = object
    Monday: TDateItem;
    Sunday: TDateItem;
    end;
 
  TWeeks = array[1..7] of TWeekItem;
 
  PMonthItem = ^TMonthItem;
  TMonthItem = object
    Month: word;
    Year: word;
    WeekCount: byte;
    Weeks: TWeeks;
    procedure Assign(AMonth, AYear: word);
    procedure CalcWeeks;
    function DayIsWhichWeek(const Day: word): byte;
    function FirstDayOfMonth: byte;
    function LastDay: byte;
    function LastDayOfMonth: byte;
  private
    procedure CalcFirstWeek;
    procedure CalcNextWeek(First: TWeekItem; var Next: TWeekItem);
    end;
 
 
  { sortierte und zu sortierende Collection }
 
  PSortCollection = ^TSortCollection;
  TSortCollection = object(TSortedCollection)
    TypeOfSort: byte;
    constructor Init(ALimit, ADelta: integer; SortType: byte);
    constructor Load(var S: TStream);
    procedure SortFor(ATypeOfSort: byte); virtual;
    procedure Store(var S: TStream);
    end;
 
 
{ TDateList }
{ Object zur Speicherung von einer Liste mit zeitlichen Daten }
  PDateList = ^TDateList;
  TDateList = object(TSortCollection)
    constructor Init;
    function Compare(Key1, Key2: Pointer): integer; virtual;
    function CompareList(AList: PDateList; var FoundItem: PDateItem;
      var FoundIndex: word): boolean; virtual;
    procedure DeleteOldDates(AListDate: TListDate);
    { �berpr�ft, ob das Item bereits in der Liste existiert und gibt }
    { den Index des gefunden Items wieder oder -1 nei nichtfinden}
    function EqualItem(Item: PDateItem; var Index: integer): boolean;
    { Error-Prozedur }
    procedure Error(Code, Info: integer); virtual;
    { gibt true zur�ck, wenn das DateItem bereits in der Liste existiert }
    function FoundSame(Item: PDateItem): boolean; virtual;
    procedure Insert(Item: Pointer); virtual;
    function KeyOf(Item: Pointer): Pointer; virtual;
    end;
 
{ ---- TDateDelta --------------------------------------------------------- }
{ - Datenrecord f�r TDateDeltaInput-Dialog.                               - }
{ - Enth�lt ein Anfangs- und ein End-Datum eines Zeit-Bereiches.          - }
{ ------------------------------------------------------------------------- }
 
  PDateDelta = ^TDateDelta;
  TDateDelta = record
    { Anfangs- und Enddatum }
    Min, Max: TDateItem;
    { MaxUse: true, wenn eine Zeitspanne vorliegt. }
    {         false, wenn nur ein einzelnes Datum. }
    MaxUse: boolean;
    end;
 
{ ----- TDateDeltaList ----------------------------------------------------- }
{ - Collection der TDateDelta-Records                                      - }
{ - Diese List wird innerhalb des TDateConsiderDialogs verwaltet und       - }
{ - aus einer DateList heraus erstellt und anschlie�end darin zur�ckverwandelt
{ -------------------------------------------------------------------------- }
 
  PDateDeltaList = ^TDateDeltaList;
  TDateDeltaList = object(TCollection)
    { gibt true zur�ck, wenn einige der Daten in DateDelta bereits }
    { vorhanden sind. Control ist der Zeiger auf eine Routine, die }
    { eine Nachricht auf dem Bildschirm ausgibt, da� dieses Datum  }
    { bereits existiert. Diese Prozedur mu� folgendes Format haben:}
    { procedure(Info: Pointer; Delta: WordBool                     }
    { Info ist ein Pointer auf ein DateDelta-Record, insofern      }
    { Delta true ist, andernfalls ein Pointer auf ein DateItem-    }
    { Record. }
    function DateDeltaExists(DateDelta: PDateDelta; Control: Pointer): boolean;
    { gibt den Speicherplatz eines DateDelta-Records wieder frei }
    procedure FreeItem(Item: Pointer); virtual;
    end;
 
 
  { TimeItem }
 
  PTimeItem = ^TTimeItem;
  TTimeItem = object
    S, M, H: byte;
    procedure Assign(const AHour, AMin, ASec: byte);
    procedure AssignWord(const AHour, AMin, ASec: word);
    { setzt Werte auf aktuelle Zeit }
    procedure AssignNow;
    procedure CopyFrom(const Time: TTimeItem);
    function Equals(const Time: TTimeItem): boolean;
    procedure Load(var Stream: TStream);
    procedure Store(var Stream: TStream);
    end;
 
  TDateLoopProc = function(var CurDate: TDateItem; Data: Pointer): boolean;
 
  { TDateLoop }
  { Ein Object zum Durchlaufen steigender oder fallender Daten }
  { mit gezieltem Abbruch der Schleife }
  PDateLoop = ^TDateLoop;
  TDateLoop = object
    Start: TDateItem;
    { Setzt das Startdatum }
    procedure Assign(AStart: TDateItem);
    procedure AssignLong(AStart: TLongDate);
    { function Loop }
    { Durchl�uft alle Daten von Start in Richtung Step
      (-1 = ein Tag abw�rts, +2 = zwei tage vorw�rts
      Hierzu wird eine Funktion vom Typ TDateLoopProc aufgerufen.
      Dieser Funktion wird der Daten-Record in Data �bergeben und das akt.
      Datum. Gibt diese Funktion true zur�ck, wird die Loop abgebrochen.
      Ansonsten wird die Schleife solange durchlaufen, bis Ende erreicht ist.
      Ende enth�lt in jedem Fall das zuletzt gepr�fte Datum.
      Das Erbegnis von Loop_Date ist das letzte Erbegnis der Funktion Proc.
      D.h. wird die Loop vorzeitig abgebrochen, gibt Loop_Date true zur�ck.
      Ist First true, so wird das erste Datum in Start mitgez�hlt. }
    function Loop(var Ende: TDateItem; Proc: TDateLoopProc; Data: Pointer;
      Step: longint; First: boolean): boolean;
    { Loop_WE }
    { Wie Loop, jedoch wird Proc nur bei den in WeekDays befindlichen }
    { Wochentagen aufgerufen }
    function Loop_WE(var Ende: TDateItem; Proc: TDateLoopProc; Data: Pointer;
      Step: longint; First: boolean; Weekdays: TByteSet): boolean;
    end;
 
  { Geburtsdatum }
  PBirthday = ^TBirthday;
  TBirthday = object
    private
      FData: word;
    public
      procedure Assign(ADay, AMonth: word);
      procedure AssignDate(ADate: TDateItem);
      function Day: word;
      function Equals(ADay, AMonth: word): boolean;
      function EqualsDate(ADate: TDateItem): boolean;
      function EqualsLong(ADate: TLongDate): boolean;
      function Month: word;
      procedure Load(var S: TStream);
      procedure Store(var S: TStream);
      end;
 
{ berechnet Wochentag eines Datums }
function DayOfWeek(Day, Month, Year: Integer) : Integer;
 
{ liefert die maximale Anzahl von Tagen eines Monats incl. Schaltjahr }
function GetMaxDayOfMonth(Month, Year: word): byte;
 
{ ----- CompareDateItem -------------------------------------------------- }
{ - vergleicht ein Anfangs- und ein Enddatum. R�ckgabewerte:             - }
{     if Min < Max then C := -1                                          - }
{     if Min = Max then C := 0                                           - }
{     if Min > Max then C := 1                                           - }
{ ------------------------------------------------------------------------ }
function CompareDateItem(Min, Max: TDateItem): integer;
 
{ errechnet den n�chsten Tag des gegebenen Datums }
procedure GetNextDateItem(Date: TDateItem; var Next: TDateItem);
 
{ berechnet die Anzahl Tage zwischen zwei Daten }
function CalcDayDelta(Min, Max: TDateItem): LongInt;
 
{ berechnet die Anzahl ganzer Wochen zwischen zwei Daten }
function CalcWeeks(Min, Max: TDateItem): integer;
 
{$IFNDEF Windows}
{ true, wenn Date zwischen einschl. Test1 und einschl. Test2 liegt }
function DateItem_In_TwoDates(Date, Test1, Test2: PDateItem): boolean;
{$ENDIF}
 
{ Bestimmt die Anzahl der L�cken in Datums-Liste }
{ Als L�cke gilt mindestens ein fehlender Tag in der zeitl. Reihenfolge }
function CalcDeltaDateItems(List: PDateList): integer;
 
{ Initialisiert leere TDateDeltaList anhand der Anzahl der Datums-L�cken }
{ der �bergebenen DateList. }
procedure InitDateDeltaList(DateList: PDateList; var Delta: PDateDeltaList);
 
{$IFNDEF Windows}
{ f�llt die DateDeltaList anhand der Daten in DateList }
procedure FillDateDeltaList(DateList: PDateList; var Delta: PDateDeltaList);
{$ENDIF}
 
{ f�llt eine DateList von den Daten einer DateDeltaList }
procedure ConvertDeltaToDateList(Delta: PDateDeltaList; var DateList: PDateList);
 
{$IFNDEF Windows}
{ Erzeugt neues DateDeltaItem auf dem Heap und gibt Pointer zur�ck }
function NewDateDeltaItem(Anfang, Ende: TDateItem): PDateDelta;
{$ENDIF}
 
{ Gibt den Speicher eines DateDeltaItems frei }
procedure DisposeDateDeltaItem(var Item: PDateDelta);
 
{$IFNDEF Windows}
{�berpr�ft, ob �bergebenes DateItem in einer DateDelta-Zeitspanne enthalten}
function DateItemInDeltaExists(DateItem: PDateItem; Delta: PDateDelta): boolean;
{$ENDIF}
 
{ Date-Error }
 
type
  TDatesErrorFunc = function(Code: integer; Info: Pointer): word;
 
function DefDatesErrorFunc(Code: integer; Info: Pointer): word; far;
function StdDatesErrorFunc(Code: integer; Info: Pointer): word; far;
 
const
  DatesError: TDatesErrorFunc = DefDatesErrorFunc;
 
{ stream registration }
 
procedure RegisterDates;
 
{ stream registration records }
 
const
 
  RDateList: TStreamRec = (
    ObjType: $0FFF;
    VmtLink: Ofs(TypeOf(TDateList)^);
    Load: @TDateList.Load;
    Store: @TDateList.Store);
 
implementation
 
{$IFDEF WithTVTools}
uses App, Views, GmMsgBox, AppTools;
{$ENDIF}
 
function DayOfWeek(Day, Month, Year: Integer) : Integer;
var
  century, yr, dw: Integer;
begin
  if Month < 3 then
  begin
    Inc(Month, 10);
    Dec(Year);
  end
  else
     Dec(Month, 2);
  century := Year div 100;
  yr := year mod 100;
  dw := (((26 * month - 2) div 10) + day + yr + (yr shr 2) +
    (century shr 2) - (2 * century)) mod 7;
  if dw < 0 then DayOfWeek := dw + 7
  else DayOfWeek := dw;
end;
 
{ TLongDate }
 
procedure TLongDate.AssignToday;
var
  DOW: word;
begin
  Day := 0;
  Month := 0;
  Year := 0;
  GetDate(word(Year), word(Month), word(day), DOW);
end;
 
function TLongDate.Equals(ADate: TLongDate): boolean;
begin
  Equals := (ADate.Day = Day) and (ADate.Month = Month) and
    (ADate.Year = Year);
end;
 
procedure TLongDate.GetNextDay(var ADate: TLongDate);
begin
  ADate := self;
  with ADate do
  begin
    if Day = GetMaxDayOfMonth(Month, Year) then
    begin
      Day := 1;
      if Month < 12 then Inc(Month) else
      begin
        Month := 1;
        Inc(Year);
      end;
    end
     else Inc(Day);
  end;
end;
 
procedure TLongDate.GetPreMonth(var D: TLongDate);
begin
  Move(self, D, SizeOf(TLongDate));
  if D.Month > 1 then Dec(D.Month) else
  begin
    Dec(D.Year);
    D.Month := 12;
  end;
end;
 
function TLongDate.GetText: string;
const
  F = '%02d.%02d.%d';
var
  S: string;
begin
  {$IFNDEF Windows}
  FormatStr(S, F, Day);
  {$ELSE}
  S := '';
  {$ENDIF}
  GetText := S;
end;
 
{ TDateItem }
procedure TDateItem.Assign(ADay, AMonth, AYear: word); assembler;
asm
        LES     DI,Self
        CLD
        MOV     AX,ADay
        STOSB
        MOV     AX,AMonth
        STOSB
        MOV     AX,AYear
        STOSW
end;
 
procedure TDateItem.AssignToday;
var
  D, M, Y, DOW: word;
begin
  GetDate(Y, M, D, DOW);
  Assign(D, M, Y);
end;
 
procedure TDateItem.CopyFrom(D: TDateItem);
{asm
        PUSH    DS
        LDS     SI,D
        LES     DI,Self
        CLD
        MOVSB
        MOVSB
        MOVSW
        POP     DS}
begin
  Move(D, self, SizeOf(TDateItem));
end;
 
procedure TDateItem.CopyFromLong(D: TLongDate);
begin
  Assign(D.Day, D.Month, D.Year);
end;
 
procedure TDateItem.CopyToLong(var D: TLongDate);
begin
  D.Day := Day;
  D.Month := Month;
  D.Year := Year;
end;
 
function TDateItem.Equals(D: TDateItem): boolean;
begin
  Equals := ((Day = D.Day) and (Month = D.Month) and (Year = D.Year));
end;
 
function TDateItem.GetDayOfWeek: byte; assembler;
asm
        PUSH    DS
        LDS     SI,Self
        MOV     AH,0
        LODSB
        PUSH    AX
        LODSB
        PUSH    AX
        LODSW
        PUSH    AX
        CALL    DayOfWeek
        POP     DS
end;
 
procedure TDateItem.GetLastDay(var D: TDateItem);
begin
  D.Reset(Day, Month, Year);
  with D do
  begin
    if Day > 1 then Dec(Day) else
    begin
      if Month > 1 then
      begin
        Dec(Month);
        Day := GetMaxDayOfMonth(Month, Year);
      end
       else
      begin
        Dec(Year);
        Month := 12;
        Day := GetMaxDayOfMonth(Month, Year);
      end;
    end;
  end;
end;
 
{ OLD-ASM GetLastDay }
{procedure TDateItem.GetLastDay(var D: TDateItem);
begin
  D.Reset(Day, Month, Year);
  with D do
  begin
    if Day > 1 then Dec(Day) else
    begin
      if Month > 1 then
      asm
        DEC     Byte Ptr Month
        PUSH    Word Ptr Year
        MOV     AH, Month
        MOV     AL, 0
        PUSH    AX
        CALL    GetMaxDayOfMonth
        MOV     Byte Ptr Day,AL
      end
       else
      begin
        asm
          DEC   Word Ptr Year
          MOV   Byte Ptr Month,12;
          PUSH  Word Ptr Year
          MOV     AL, Month
          MOV     AH, 0
          PUSH    AX
          CALL  GetMaxDayOfMonth
          MOV   Byte Ptr Day,AL
          end;
      end;
    end;
  end;
end;}
 
function TDateItem.GetMYText: string;
var
  W: string[4];
begin
  Str(Year, W);
  GetMYText := concat(MonthStr[Month], #32, W);
end;
 
procedure TDateItem.GetNextXDate(Days: integer; var D: TDateItem);
begin
  D.CopyFrom(self);
  if Days > 0 then
  repeat
    D.GetNextDay(D);
    Dec(Days);
  until Days = 0;
  if Days < 0 then
  repeat
    D.GetLastDay(D);
    Inc(Days);
  until Days = 0;
end;
 
procedure TDateItem.GetNextDay(var D: TDateItem);
begin
  GetNextDateItem(self, D);
end;
 
procedure TDateItem.GetNextMonth(var D: TDateItem);
begin
  D.CopyFrom(self);
  if D.Month < 12 then Inc(D.Month) else
  begin
    Inc(D.Year);
    D.Month := 1;
  end;
end;
 
procedure TDateItem.GetPreMonth(var D: TDateItem);
begin
  D.CopyFrom(self);
  if D.Month > 1 then Dec(D.Month) else
  begin
    Dec(D.Year);
    D.Month := 12;
  end;
end;
 
{ For GetText }
 
procedure AXtoString; assembler;
const
  Zehn: word = 10;
  Ausgabe: array[0..5] of char = '';
asm
     PUSH AX
     PUSH BX
     PUSH DX
     PUSH DI
@@1: xor dx,dx
     div zehn
     or dl,30h
     MOV DS:[BX+(OFFSET Ausgabe-1)],DL
     dec bx
     jnz @@1
     POP DI
     POP DX
     POP BX
     PUSH BX
     MOV CX,BX
     MOV BX,1
@@2: MOV DL,DS:[BX+(OFFSET Ausgabe-1)]
     MOV AL,DL
     STOSB
     INC BX
     LOOP @@2
     POP BX
     POP AX
end;
 
procedure GetDateText(Day, Month, Year: word; var Rslt: string);
begin
  asm
    LES  DI,DWORD PTR Rslt
    CLD
    INC  DI
    { Tag }
    MOV  AX,Day
    MOV  BX,2
    CALL AXToString
    { Punkt }
    MOV AL,'.'
    STOSB
    { Monat }
    MOV  AX,Month
    MOV  BX,2
    CALL AXtoString
    { Punkt }
    MOV AL,'.'
    STOSB
    JMP @@4
@@4:{ Jahr }
    MOV  AX,Year
    MOV  BX,4
    CALL AXtoString
    { Gesamtl�nge bestimmen }
    MOV  AX,DI
    LES  DI,DWORD PTR Rslt
    SUB  AX,DI
    DEC  AL
    STOSB
  end;
end;
 
function GetDateTextF(Day, Month, Year: word): string;
begin
  asm
    LES  DI,@Result
    CLD
    INC  DI
    { Tag }
    MOV  AX,Day
    MOV  BX,2
    CALL AXToString
    { Punkt }
    MOV AL,'.'
    STOSB
    { Monat }
    MOV  AX,Month
    MOV  BX,2
    CALL AXtoString
    { Punkt }
    MOV AL,'.'
    STOSB
    JMP @@4
@@4:{ Jahr }
    MOV  AX,Year
    MOV  BX,4
    CALL AXtoString
    { Gesamtl�nge bestimmen }
    MOV  AX,DI
    LES  DI,@Result
    SUB  AX,DI
    DEC  AL
    STOSB
  end;
end;
 
function TDateItem.GetText: string;
begin
  GetText := GetDateTextF(Day, Month, Year);
end;
 
function TDateItem.GetW2Text: string;
begin
  GetW2Text := concat(Day2Str[GetDayOfWeek], ', ',
    GetDateTextF(Day, Month, Year));
end;
 
function TDateItem.GetNMText: string;
const
  F = '%02d. %s %d';
var
  Data: record
    Day: longint;
    Month: PString;
    Year: longint;
    end;
  R: string;
begin
  Data.Day := Day;
  Data.Month := @MonthStr[Month];
  Data.Year := Year;
  {$IFNDEF Windows}
  FormatStr(R, F, Data);
  {$ELSE}
  R := '';
  {$ENDIF}
  GetNMText := R;
end;
 
function TDateItem.IsPreDay(ADate: TDateItem): boolean;
var
  V: TDateItem;
begin
  GetLastDay(V);
  IsPreDay := ADate.Equals(V);
end;
 
function TDateItem.IsToday: boolean;
var
  D, M, Y, DOW: word;
begin
  GetDate(Y, M, D, DOW);
  IsToday := (D = Day) and (M = Month) and (Y = Year)
end;
 
procedure TDateItem.LastWeekEnd(var Date: TDateItem);
begin
  Date.CopyFrom(self);
  if Date.GetDayOfWeek = daySunday then Date.GetLastDay(Date);
  while not (Date.GetDayOfWeek = daySunday) do
    Date.GetLastDay(Date);
end;
 
procedure TDateItem.Load(var S: TStream);
begin
  S.Read(Day, SizeOf(TDayType)*2 + SizeOf(TYearType));
end;
 
function TDateItem.MaxDayMonth: byte;
begin
  MaxDayMonth := GetMaxDayOfMonth(Month, Year);
end;
 
procedure TDateItem.PutFormatRec(var Rec: TDateFormatRec);
begin
  Rec.DOW := @Day2Str[GetDayOfWeek];
  Rec.Day := Day;
  Rec.Month := Month;
  Rec.Year := Year;
end;
 
procedure TDateItem.Reset(ADay, AMonth, AYear: word); assembler;
asm
        LES     DI,Self
        CLD
        MOV     AX,ADay
        STOSB
        MOV     AX,AMonth
        STOSB
        MOV     AX,AYear
        STOSW
        JMP     @@1
        db  ' ***** '
        db  '    copyright and written by hagen huebel in 1995,1996,1997    '
        db  ' ***** '
        @@1:
end;
 
procedure TDateItem.Store(var S: TStream);
begin
  S.Write(Day, SizeOf(TDayType)*2 + SizeOf(TYearType));
end;
 
function TDateItem.Valid(const Inform: boolean): TDateError;
 
 procedure DoInf(const Art: TDateError; const Min, Max: word);
 const
   Msg = 'Die Eingabe f�r %s mu� sich im Bereich zwischen %d und %d befinden';
   FeldName: array[dtsDay..dtsYear] of string[6] =
      ('Tag', 'Monat', 'Jahr');
 var
   Str: PString;
   AMin, AMax: longint;
 begin
   {$IFDEF WithTVTools}
   Str := @FeldName[Art];
   AMin := Min;
   AMax := Max;
   MessageBox(Msg, @Str, mfError or mfOKButton);
   {$ENDIF}
 end;
 
var
  V: TDateError;
begin
  V := dtsOK;
  if not (Day in [1..MaxDayInMonth]) then V := dtsDay
  else
    if not (Month in [1..12]) then V := dtsMonth
    else
      if (Year < low(TYearType)) or (Year > high(TYearType)) then
         V := dtsYear;
  Valid := V;
  if Inform then
  case V of
    dtsDay: DoInf(dtsDay, 1, MaxDayInMonth);
    dtsMonth: DoInf(dtsMonth, 1, 12);
    dtsYear: DoInf(dtsYear, low(TYearType), high(TYearType))
    end;
end;
 
{ TMonthItem }
 
procedure TMonthItem.Assign(AMonth, AYear: word);
begin
  Month := AMonth;
  Year := AYear;
  CalcWeeks;
end;
 
procedure TMonthItem.CalcFirstWeek;
var
  FirstWeekDate: TDateItem;
  LastWeekDate: TDateItem;
begin
  { erster Wochentag }
  FirstWeekDate.Month := Month;
  FirstWeekDate.Year := Year;
  FirstWeekDate.Day := 1;
  if FirstDayOfMonth <> dayMonday then
  repeat
    FirstWeekDate.GetLastDay(FirstWeekDate);
  until FirstWeekDate.GetDayOfWeek = dayMonday;
  Weeks[1].Monday.CopyFrom(FirstWeekDate);
  { letzter Wochentag }
  LastWeekDate.Month := Month;
  LastWeekDate.Year := Year;
  LastWeekDate.Day := 1;
  if LastWeekDate.GetDayOfWeek <> daySunday then
  repeat
    LastWeekDate.GetNextDay(LastWeekDate);
  until LastWeekDate.GetDayOfWeek = daySunday;
  Weeks[1].Sunday.CopyFrom(LastWeekDate);
  { erste Woche }
  WeekCount := 1;
end;
 
procedure TMonthItem.CalcNextWeek(First: TWeekItem; var Next: TWeekItem);
begin
  First.Monday.GetNextXDate(7, Next.Monday);
  First.Sunday.GetNextXDate(7, Next.Sunday);
  Inc(WeekCount);
end;
 
procedure TMonthItem.CalcWeeks;
var
  W: byte;
  Last: boolean;
begin
  { Wochen l�schen }
  WeekCount := 0;
  FillChar(Weeks, SizeOf(Weeks), #0);
  { erste Woche berechnen }
  CalcFirstWeek;
  { n�chste Wochen berechnen }
  W := 2;
  repeat
    CalcNextWeek(Weeks[W-1], Weeks[W]);
    Inc(W);
    with Weeks[WeekCount] do
    Last := (Sunday.Month <> Self.Month) or
      (Sunday.Day = Sunday.MaxDayMonth);
  until Last;
end;
 
function TMonthItem.DayIsWhichWeek(const Day: word): byte;
var
  I: byte;
  Date: TDateItem;
begin
  {$IFNDEF Windows}
  Date.Assign(Day, Month, Year);
  DayIsWhichWeek := 255;
  For I := Low(Weeks) to WeekCount do
    if DateItem_In_TwoDates(@Date, @Weeks[I].Monday, @Weeks[I].Sunday) then
    begin
      DayIsWhichWeek := I;
      Break;
    end;
  {$ENDIF}
end;
 
function TMonthItem.FirstDayOfMonth: byte;
begin
  FirstDayOfMonth := DayOfWeek(1, Month, Year);
end;
 
function TMonthItem.LastDay: byte;
begin
  LastDay := GetMaxDayOfMonth(Month, Year);
end;
 
function TMonthItem.LastDayOfMonth: byte;
begin
  LastDayOfMonth := DayOfWeek(LastDay, Month, Year);
end;
 
{ - TSortCollectionn - }
 
constructor TSortCollection.Init(ALimit, ADelta: integer; SortType: byte);
begin
  Inherited Init(ALimit, ADelta);
  TypeOfSort := SortType;
end;
 
constructor TSortCollection.Load(var S: TStream);
begin
  inherited Load(S);
  S.Read(TypeOfSort, 1);
end;
 
procedure TSortCollection.SortFor(ATypeOfSort: byte);
var
  N, C, Index1, Index2: integer;
  Dump: Pointer;
begin
  TypeOfSort := ATypeOfSort;
  N := 2;
  if Count < = 1 then exit;
  For Index2 := 0 to Count - 1 do
  begin
    for Index1 := 0 to Count - N do
    begin
      C := Compare(KeyOf(Items^[Index1]), KeyOf(Items^[Index1 + 1]));
      if C = 1 then
      begin
        Dump := Items^[Index1];
        Items^[Index1] := Items^[Index1 + 1];
        Items^[Index1 + 1] := Dump;
      end;
    end;
    inc(N);
  end;
end;
 
procedure TSortCollection.Store(var S: TStream);
begin
  inherited Store(S);
  S.Write(TypeOfSort, 1);
end;
 
 
{ TDateList }
constructor TDateList.Init;
begin
  inherited Init(1, 2, YearSort);
  Duplicates := true;
end;
 
function TDateList.Compare(Key1, Key2: Pointer): integer;
 
 function WComp(const W1, W2: word): integer;
 begin
   if W1 < W2 then WComp := -1
   else
     if W1 > W2 then WComp := 1
     else
       WComp := 0;
 end;
 
var
  C: integer;
  Item1, Item2: PDateItem;
  D1, D2, M1, M2: byte;
  J1, J2: word;
begin
  Item1 := PDateItem(Key1);
  Item2 := PDateItem(Key2);
  D1 := Item1^.Day;    D2 := Item2^.Day;
  M1 := Item1^.Month;  M2 := Item2^.Month;
  J1 := Item1^.Year;   J2 := Item2^.Year;
  case TypeOfSort of
    YearSort:
      begin
        C := WComp(J1, J2);
        if C = 0 then
        begin
          C := WComp(M1, M2);
          if C = 0 then C := WComp(D1, D2);
        end;
      end;
    MonthSort:
      begin
        C := WComp(M1, M2);
        if C = 0 then
        begin
          C := WComp(J1, J2);
          if C = 0 then C := WComp(D1, D2);
        end;
      end;
   DaySort:
      begin
        C := WComp(D1, D2);
        if C = 0 then
        begin
          C := WComp(J1, J2);
          if C = 0 then C := WComp(M1, M2);
        end;
      end;
    end;
  Compare := C;
end;
 
function TDateList.CompareList(AList: PDateList; var FoundItem: PDateItem;
  var FoundIndex: word): boolean;
 
 function DoFind(Item: PDateItem): boolean; far;
 begin
   DoFind := AList^.FoundSame(Item);
 end;
 
var
  Found: boolean;
begin
  FoundIndex := $FFFF;
  FoundItem := FirstThat(@DoFind);
  Found := FoundItem <> nil;
  if Found then FoundIndex := IndexOf(FoundItem);
  CompareList := Found;
end;
 
procedure TDateList.DeleteOldDates(AListDate: TListDate);
 
 function GetLowDate: PDateItem;
 
   function IsLow(P: PDateItem): boolean; far;
   begin
     IsLow := (P^.Year < = AListDate.Year) and (P^.Month < AListDate.Month);
   end;
 
 begin
   GetLowDate := FirstThat(@IsLow);
 end;
 
var
  LowDate: PDateItem;
begin
  repeat
    LowDate := GetLowDate;
    if LowDate <> nil then Free(LowDate);
  until LowDate = nil;
end;
 
{ TDateList.EqualItem }
function TDateList.EqualItem(Item: PDateItem; var Index: integer): boolean;
 
function Find(Date: PDateItem): boolean; far;
begin
  Find := Date^.Equals(Item^);
end;
 
var
  FoundItem: PDateItem;
begin
  FoundItem := FirstThat(@Find);
  Index := IndexOf(FoundItem);
  EqualItem := Index > -1;
end;
 
{ TDateList.Error }
procedure TDateList.Error(Code, Info: integer);
begin
  DatesError(coOverFlow, nil);
end;
 
{ TDateList.FoundSame }
function TDateList.FoundSame(Item: PDateItem): boolean;
 
 function DoFind(Test: PDateItem): boolean; far;
 begin
   DoFind := (Test^.Day = Item^.Day) and (Test^.Month = Item^.Month) and
      (Test^.Year = Item^.Year);
 end;
 
begin
  FoundSame := FirstThat(@DoFind) <> nil;
end;
 
procedure TDateList.Insert(Item: Pointer);
var
  Index: integer;
begin
  if Not EqualItem(Item, Index) then inherited Insert(Item)
  else FreeItem(Item);
end;
 
function TDateList.KeyOf(Item: Pointer): Pointer;
var
  Date: PDateItem;
begin
{  Date := PDateItem(Item);
  case TypeOfSort of
    DaySort: KeyOf := @Date^.Day;
    MonthSort: KeyOf := @Date^.Month;
    YearSort: KeyOf := @Date^.Year;
    end;}
  KeyOf := PDateItem(Item);
end;
 
{ TDateDeltaList }
 
function TDateDeltaList.DateDeltaExists(DateDelta: PDateDelta;
  Control: Pointer): boolean;
type
  TInfoProc = procedure(Info: Pointer; Delta: WordBool);
var
  Current: TDateItem;
  SearchItem: TDateItem;
  Found: boolean;
begin
  Found := false;
  if DateDelta <> nil then
  begin
    Current.Assign(0, 0, 0);
    SearchItem.Assign(0, 0, 0);
 
    Current.CopyFrom(DateDelta^.Min);
 
  end;
  DateDeltaExists := Found;
end;
 
procedure TDateDeltaList.FreeItem(Item: Pointer);
begin
  DisposeDateDeltaItem(PDateDelta(Item));
end;
 
{ TTimeItem }
 
procedure TTimeItem.Assign(const AHour, AMin, ASec: byte);
begin
  H := AHour;
  M := AMin;
  S := ASec;
end;
 
procedure TTimeItem.AssignWord(const AHour, AMin, ASec: word);
begin
  H := AHour;
  M := AMin;
  S := ASec;
end;
 
procedure TTimeItem.AssignNow;
var
  _h, _m, _s, s100: word;
begin
  GetTime(_H, _M, _S, S100);
  Assign(_H, _M, _S);
end;
 
procedure TTimeItem.CopyFrom(const Time: TTimeItem);
begin
  Assign(Time.H, Time.M, Time.S);
end;
 
function TTimeItem.Equals(const Time: TTimeItem): boolean;
begin
  Equals := (H = Time.H) and (M = Time.M) and (S = Time.S);
end;
 
procedure TTimeItem.Load(var Stream: TStream);
begin
  Stream.Read(S, 3);
end;
 
procedure TTimeItem.Store(var Stream: TStream);
begin
  Stream.Write(S, 3);
end;
 
 
{ TDateLoop }
 
procedure TDateLoop.Assign(AStart: TDateItem);
begin
  Start.CopyFrom(AStart);
end;
 
procedure TDateLoop.AssignLong(AStart: TLongDate);
begin
  Start.CopyFromLong(AStart);
end;
 
    { Durchl�uft alle Daten von Start in Richtung Step
      (-1 = ein Tag abw�rts, +2 = zwei tage vorw�rts
      Hierzu wird eine Funktion vom Typ TDateLoopProc aufgerufen.
      Dieser Funktion wird der Daten-Record in Data �bergeben und das akt.
      Datum. Gibt diese Funktion true zur�ck, wird die Loop abgebrochen.
      Ende enth�lt in jedem Fall das zuletzt gepr�fte Datum.
      Das Erbegnis von Loop_Date ist das letzte Erbegnis der Funktion Proc.
      D.h. wird die Loop vorzeitig abgebrochen, gibt Loop_Date true zur�ck }
function TDateLoop.Loop(var Ende: TDateItem; Proc: TDateLoopProc; Data: Pointer;
      Step: longint; First: boolean): boolean;
var
  Cur: TDateItem;
 
procedure GetNext;
begin
  if Step = 1 then Cur.GetNextDay(Cur) else
  if Step = -1 then Cur.GetLastDay(Cur) else
    Cur.GetNextXDate(Step, Cur);
end;
 
var
  Rslt: boolean;
  Max, Count: longint;
begin
  Cur.CopyFrom(Start);
  Max := CalcDayDelta(Start, Ende) div abs(Step) + 1;
  Count := 0;
  if not First then GetNext;
  repeat
    Rslt := Proc(Cur, Data);
    GetNext;
    Inc(Count);
  until Rslt or (Count >= Max);
  Ende := Cur;
  Loop := Rslt;
end;
 
function TDateLoop.Loop_WE(var Ende: TDateItem; Proc: TDateLoopProc; Data: Pointer;
      Step: longint; First: boolean; Weekdays: TByteSet): boolean;
var
  Cur: TDateItem;
 
procedure GetNext;
begin
  if Step = 1 then Cur.GetNextDay(Cur) else
  if Step = -1 then Cur.GetLastDay(Cur) else
    Cur.GetNextXDate(Step, Cur);
end;
 
var
  Rslt: boolean;
  Max, Count: longint;
begin
  Cur.CopyFrom(Start);
  Max := CalcDayDelta(Start, Ende) div abs(Step) + 1;
  Count := 0;
  Rslt := false;
  if not First then GetNext;
  repeat
    if Cur.GetDayOfWeek in WeekDays then
       Rslt := Proc(Cur, Data);
    GetNext;
    Inc(Count);
  until Rslt or (Count >= Max);
  Ende := Cur;
  Loop_WE := Rslt;
end;
 
{ TBirthday }
 
procedure TBirthday.Assign(ADay, AMonth: word);
begin
  WordRec(FData).Lo := ADay;
  WordRec(FData).Hi := AMonth;
end;
 
procedure TBirthday.AssignDate(ADate: TDateItem);
begin
  WordRec(FData).Lo := ADate.Day;
  WordRec(FData).Hi := ADate.Month;
end;
 
function TBirthday.Day: word;
begin
  Day := WordRec(FData).Lo;
end;
 
function TBirthday.Equals(ADay, AMonth: word): boolean;
begin
  Equals := (Day = ADay) and (Month = AMonth);
end;
 
function TBirthday.EqualsDate(ADate: TDateItem): boolean;
begin
  EqualsDate := (ADate.Day = Day) and (ADate.Month = Month);
end;
 
function TBirthday.EqualsLong(ADate: TLongDate): boolean;
begin
  EqualsLong := (ADate.Day = Day) and (ADate.Month = Month);
end;
 
function TBirthday.Month: word;
begin
  Month := WordRec(FData).Hi;
end;
 
procedure TBirthday.Load(var S: TStream);
begin
  S.Read(FData, 2);
end;
 
procedure TBirthday.Store(var S: TStream);
begin
  S.Write(FData, 2);
end;
 
{ GetMaxDayOfMonth }
 
function GetMaxDayOfMonth(Month, Year: word): byte;
var
  D: byte;
begin
  D := MaxDayOfMonth[Month];
  if Month = 2 then
    if Year mod 4 = 0 then D := 29;
  GetMaxDayOfMonth := D;
end;
 
{ CompareDateItem }
 
function CompareDateItem(Min, Max: TDateItem): integer;
var
  C: integer;
begin
  C := -1;
  if (Max.Year = Min.Year) and (Max.Month = Min.Month) and (Max.Day = Min.Day)
  then C := 0 else
  begin
    if Max.Year < Min.Year then C := 1 else
    begin
      if Max.Year = Min.Year then
      begin
        if Max.Month < Min.Month then C := 1;
        if Max.Month = Min.Month then
          if Max.Day < Min.Day then C := 1;
      end;
    end;
  end;
  CompareDateItem := C;
end;
 
{ GetNextDateItem }
 
procedure GetNextDateItem(Date: TDateItem; var Next: TDateItem);
begin
  Next.Reset(Date.Day, Date.Month, Date.Year);
  with Next do
  begin
    if Day = GetMaxDayOfMonth(Month, Year) then
    begin
      Day := 1;
      if Month < 12 then Inc(Month) else
      begin
        Month := 1;
        Inc(Year);
      end;
    end
     else Inc(Day);
  end;
end;
 
{$IFNDEF Windows}
function DateItem_In_TwoDates(Date, Test1, Test2: PDateItem): boolean;
var
  Delta: PDateDelta;
begin
  DateItem_In_TwoDates := false;
  Delta := NewDateDeltaItem(Test1^, Test2^);
  if Delta <> nil then
  begin
    DateItem_In_TwoDates := DateItemInDeltaExists(Date, Delta);
    DisposeDateDeltaItem(Delta);
  end;
end;
{$ENDIF Windows}
 
{ CalcDayDelta }
 
function CalcDayDelta(Min, Max: TDateItem): LongInt;
var
  C: LongInt;
  Ready: boolean;
  Comp: integer;
begin
  Comp := CompareDateItem(Min, Max);
  case Comp of
  -1:
  begin
    C := 0;
    repeat
      GetNextDateItem(Min, Min);
      Ready := Min.Equals(Max);
      Inc(C);
    until Ready;
    CalcDayDelta := C;
  end;
  0: CalcDayDelta := 0;
  1:
  begin
    C := 0;
    repeat
      Min.GetLastDay(Min);
      Ready := Min.Equals(Max);
      Inc(C);
    until Ready;
    CalcDayDelta := C;
  end;
  end;
end;
 
function CalcWeeks(Min, Max: TDateItem): integer;
var
  Days: longint;
begin
  Days := CalcDayDelta(Min, Max);
  CalcWeeks := LongDiv(Days, 7);
end;
 
{ Bestimmt die Anzahl der Lücken in Datums-Liste }
{ Als Lücke gilt mindestens ein fehlender Tag in der zeitl. Reihenfolge }
 
function CalcDeltaDateItems(List: PDateList): integer;
var
  Rslt: integer;
  LastDate: TDateItem;
  NextDate: TDateItem;
 
procedure Proof(P: PDateItem); far;
begin
  GetNextDateItem(LastDate, NextDate);
  if not P^.Equals(NextDate) then Inc(Rslt);
  LastDate.CopyFrom(P^);
end;
 
begin
  Rslt := 0;
  LastDate.Assign(0, 0, 0);
  NextDate.Assign(0, 0, 0);
  List^.ForEach(@Proof);
  CalcDeltaDateItems := Rslt;
end;
 
{ Initialisiert leere TDateDeltaList anhand der Anzahl der Datums-L�cken }
{ der �bergebenen DateList. }
 
procedure InitDateDeltaList(DateList: PDateList; var Delta: PDateDeltaList);
var
  Max: integer;
begin
  Max := CalcDeltaDateItems(DateList);
  if Max < = 0 then Max := 1;
  New(Delta, Init(Max, 1));
end;
 
{ FillDateDeltaList }
 
{$IFNDEF Windows}
procedure FillDateDeltaList(DateList: PDateList; var Delta: PDateDeltaList);
var
  First, Last, Next: TDateItem;
 
procedure InsertDeltaItem(F, L: TDateItem);
var
  DeltaItem: PDateDelta;
begin
  if L.Year = 0 then exit;
  DeltaItem := NewDateDeltaItem(F, L);
  if DeltaItem <> nil then Delta^.Insert(DeltaItem);
end;
 
procedure Fill(DateItem: PDateItem); far;
begin
  GetNextDateItem(Last, Next);
  if not DateItem^.Equals(Next) then
  begin
    InsertDeltaItem(First, Last);
    First.CopyFrom(DateItem^);
  end;
  Last.CopyFrom(DateItem^);
end;
 
begin
  if (Delta = nil) or (DateList = nil) then exit;
  First.Assign(0, 0, 0);
  Last.Assign(0, 0, 0);
  Next.Assign(0, 0, 0);
  if DateList^.Count > 0 then First.CopyFrom(PDateItem(DateList^.At(0))^);
  DateList^.ForEach(@Fill);
  InsertDeltaItem(First, Last);
  Delta^.Pack;
end;
{$ENDIF Windows}
 
{ ConvertDeltaToDateList }
 
procedure ConvertDeltaToDateList(Delta: PDateDeltaList; var DateList: PDateList);
var
  Cancel: boolean;
  First, Last: TDateItem;
 
procedure InsertDateItem(DateItem: TDateItem);
var
  Item: PDateItem;
begin
  {$IFNDEF Windows}
  Item := MemAlloc(SizeOf(TDateItem));
  if Item <> nil then
  begin
    Item^.Assign(DateItem.Day, DateItem.Month, DateItem.Year);
    DateList^.Insert(Item)
  end
  else
  begin
    Cancel := true;
    {$IFDEF WithTVTools}
    if Application <> nil then Application^.OutOfMemory;
    {$ENDIF WithTVTools}
  end;
  {$ENDIF Windows}
end;
 
procedure Fill(Item: PDateDelta); far;
begin
  {$IFDEF WithTVTools}
  Application^.Idle;
  {$ENDIF WithTVTools}
  if not Cancel then
  with Item^ do
  begin
    InsertDateItem(Min);
    While not Min.Equals(Max) do
    begin
      GetNextDateItem(Min, Min);
      InsertDateItem(Min);
    end;
  end;
end;
 
begin
  Cancel := false;
  if (Delta = nil) or (DateList = nil) then exit;
  {$IFDEF WithTVTools}
  if StatusLine <> nil then StatusLineMessage('Bitte einen Moment warten...');
  {$ENDIF WithTVTools}
  First.Assign(0, 0, 0);
  Last.Assign(0, 0, 0);
  Delta^.ForEach(@Fill);
  DateList^.Pack;
  {$IFDEF WithTVTools}
  if StatusLine <> nil then StatusLine^.DrawView;
  {$ENDIF WithTVTools}
end;
 
 
{ NewDateDeltaItem }
{$IFNDEF Windows}
function NewDateDeltaItem(Anfang, Ende: TDateItem): PDateDelta;
var
  Item: PDateDelta;
begin
  Item := MemAlloc(SizeOf(TDateDelta));
  if Item <> nil then
  begin
    with Anfang do Item^.Min.Assign(Day, Month, Year);
    with Ende do Item^.Max.Assign(Day, Month, Year);
    Item^.MaxUse := not Ende.Equals(Anfang);
  end
  {$IFDEF WithTVTools}
    else
      if Application <> nil then Application^.OutOfMemory;
  {$ELSE WithTVTools} ;
  {$ENDIF WithTVTools}
  NewDateDeltaItem := Item;
end;
{$ENDIF Windows}
 
{ DisposeDateDeltaItem }
procedure DisposeDateDeltaItem(var Item: PDateDelta);
begin
  if Item <> nil then
  begin
    Dispose(Item);
    Item := nil;
  end;
end;
 
{ DateItemInDeltaExists }
function DateItemInDeltaExists(DateItem: PDateItem; Delta: PDateDelta): boolean;
var
  Found: boolean;
  Min, max: integer;
begin
  Min := CompareDateItem(DateItem^, Delta^.Min);
  Max := CompareDateItem(DateItem^, Delta^.Max);
  Found := (Min >= 0) and (Max < =0);
  DateItemInDeltaExists := Found;
end;
 
{ DefDateErrorFunc }
function DefDatesErrorFunc(Code: integer; Info: Pointer): word;
begin
  DefDatesErrorFunc := 11 {cmCancel};
end;
 
function StdDatesErrorFunc(Code: integer; Info: Pointer): word;
begin
  {$IFDEF WithTVTools}
  StdDatesErrorFunc := cmCancel;
  case Code of
    coOverFlow:
      MessageBox('Die Liste kann keine weiteren Einträge aufnehmen!', nil,
        mfError or mfOKButton);
    end;
  {$ENDIF}
end;
 
procedure RegisterDates;
begin
  RegisterType(RDateList);
end;
 
end.

Tags: DateClass, OOP, Pascal, Turbo Pascal

HagensTechiBlog

DeVelOPerS CrnR/LinuXUsrBloG