home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / TVTOOL.ZIP / TVTYPE.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-10-08  |  3.1 KB  |  35 lines
  1. {*
  2. *
  3. *   Copyright (c) 1992 by Richard W. Hansen
  4. *
  5. *   This source code will compile.
  6. *   Unpacked source is available to registered users.
  7. *
  8. *}
  9. UNIT TvType;{$X+}{$V-}{$I TVDEFS.INC}INTERFACE USES Dos,Objects;CONST DateSlash='/';TYPE FrameArray=Array[1..8]of Char;
  10. PostEditFunc=Function(P:Pointer;ID:Word):Boolean;TCharBuf=Array[0..$FFE0]of Char;PCharBuf=^TCharBuf;
  11. TByteBuf=Array[0..$FFE0]of Byte;PByteBuf=^TByteBuf;TCharSet=Set of Char;THexLong=record Low,High:Word;end;TDateSt=String[15];
  12. PDate=^TDate;TDate=Object(TObject)Day:Byte;Month:Byte;Year:Word;Procedure SetDate(D:Byte;M:Byte;Y:Word);
  13. Procedure SetDay(D:Byte);Procedure SetMonth(M:Byte);Procedure SetYear(Y:Word);Procedure SetToday;Function ValidDate:Boolean;
  14. Function DateString(Picture:TDateSt):TDateSt;Procedure ExtractDate(Picture:TDateSt;ADateSt:TDateSt);
  15. Function Compare(var ADate:PDate):Integer;end;IMPLEMENTATION Procedure TDate.SetDate(D:Byte;M:Byte;Y:Word);begin Day:=D;
  16. Month:=M;Year:=Y;end;Procedure TDate.SetDay(D:Byte);begin Day:=D;end;Procedure TDate.SetMonth(M:Byte);begin Month:=M;end;
  17. Procedure TDate.SetYear(Y:Word);begin Year:=Y;end;Procedure TDate.SetToday;var D,M,Y,DW:Word;begin Dos.GetDate(Y,M,D,DW);
  18. Day:=D;Month:=M;Year:=Y;end;Function TDate.ValidDate:Boolean;var LeapYear:Byte;begin
  19. if(Year mod 4=0)and((Year mod 100<>0)or(Year mod 400=0))then LeapYear:=1 else LeapYear:=0;if(Day<1)or(Year<1)then
  20. ValidDate:=False else Case Month of 1,3,5,7,8,10,12:ValidDate:=(Day<=31);4,6,9,11:ValidDate:=(Day<=30);2:
  21. ValidDate:=(Day<=28+LeapYear);else ValidDate:=False;end;end;Function TDate.DateString(Picture:TDateSt):TDateSt;
  22. Procedure Merge(Ch:Char;N:Word;var Pic:String);var i,j:Byte;S:String[4];begin i:=Pos(Ch,Pic);Ch:=UpCase(Ch);if(i=0)then begin
  23. i:=Pos(Ch,Pic);if(i=0)then EXIT;end;While(i<Length(Pic))and(UpCase(Pic[i+1])=Ch)do Inc(i);Str(N:4,S);j:=4;
  24. While(i>0)and(UpCase(Pic[i])=Ch)do begin if(j>0)and(S[j]<>' ')then begin Pic[i]:=S[j];Dec(j);end else if(Pic[i]<'a')then begin
  25. Pic[i]:=' ';end else begin Pic[i]:='0';end;Dec(i);end;end;var i:Byte;begin Merge('d',Day,Picture);Merge('m',Month,Picture);
  26. Merge('y',Year,Picture);for i:=1 to Length(Picture)do if Picture[i]='/'then Picture[i]:=DateSlash;DateString:=Picture;end;
  27. Procedure TDate.ExtractDate(Picture:TDateSt;ADateSt:TDateSt);Procedure Extract(Ch:Char;var Pic:String;var St:String;
  28. var N:Word);var i,j:Integer;Temp:TDateSt;Code:Word;begin N:=0;i:=Pos(Ch,Pic);Ch:=Upcase(Ch);j:=Pos(Ch,Pic);
  29. if(i=0)or((j<>0)and(j<i))then i:=j;if(i=0)then EXIT;j:=0;While(Upcase(Pic[i])=Ch)and(i<=Length(St))do begin if St[i]<>' 'then
  30. begin Inc(j);Temp[j]:=St[i];end;Inc(i);end;Byte(Temp[0]):=j;Val(Temp,N,Code);if(Code<>0)then N:=0;end;var D,M,Y:Word;begin
  31. Extract('m',Picture,ADateSt,M);Extract('d',Picture,ADateSt,D);Extract('y',Picture,ADateSt,Y);SetDate(D,M,Y);end;
  32. Function TDate.Compare(var ADate:PDate):Integer;begin if(Year<ADate^.Year)then Compare:=-1 else if(Year>ADate^.Year)then
  33. Compare:=1 else if(Month<ADate^.Month)then Compare:=-1 else if(Month>ADate^.Month)then Compare:=1 else if(Day<ADate^.Day)then
  34. Compare:=-1 else if(Day>ADate^.Day)then Compare:=1 else Compare:=0;end;END.
  35.