home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / PASCAL / MISCPAS.ZIP / SHOWDATE.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-06-23  |  2.9 KB  |  120 lines
  1. PROGRAM showdate;  {For Turbo Pascal}
  2.  
  3. TYPE 
  4.   Datetimestr = STRING[26];
  5.  
  6. VAR 
  7.   datetimestamp : datetimestr;
  8. {$V-}
  9.  
  10. {Library Function to get current date and time from clock}
  11.  
  12. FUNCTION DateTime: DateTimeStr;
  13.  
  14. TYPE 
  15.   regpack = RECORD
  16.               ax,bx,cx,dx,bp,si,ds,es,flags: integer;
  17.             END;
  18.   dayname = STRING[3];
  19.  
  20.   TYPE monthname = ARRAY[1..12] OF STRING[3];
  21.  
  22.     CONST mon: monthname = ('Jan','Feb','Mar','Apr','May','Jun',
  23.                             'Jul','Aug','Sep','Oct','Nov','Dec');
  24.  
  25. VAR 
  26.   recpack:       regpack;                {record for MsDos call}
  27.   day,hours,minutes,seconds,ampm:     STRING[2];
  28.   year:          STRING[4];
  29.   month,dx,cx,daynumber,yearnumber,time:         integer;
  30.   dayoftheweek : dayname;
  31.  
  32. FUNCTION DayofWeek(juliandate:real): dayname;
  33. {finds day of week for 10 feb 1985 or later}
  34.  
  35. TYPE  daynames = ARRAY[1..7] OF STRING[3];
  36.  
  37.   CONST day: daynames = ('Sun','Mon','Tue','Wed','Thu','Fri','Sat');
  38.  
  39. VAR   daynumber : real;
  40. BEGIN
  41.   daynumber := (juliandate + 1.5)/7;
  42.   daynumber := daynumber -349444.0;   {sun 10 feb 1985}
  43.   WHILE daynumber > 32000 DO
  44.     daynumber := daynumber - 32000;
  45.   daynumber := (daynumber - trunc(daynumber))*7;
  46.   dayofweek := day[round(daynumber)+1];
  47. END;
  48.  
  49. FUNCTION juliandate(daynumber, monthnumber, yearnumber:integer): real;
  50.  
  51. VAR  a,b,c,d : real;
  52. BEGIN
  53.   IF monthnumber < 3
  54.     THEN
  55.       BEGIN
  56.         yearnumber := yearnumber -1;
  57.         monthnumber := monthnumber + 12;
  58.       END;
  59.   a := trunc(yearnumber/100)*1.0;
  60.   b := 2-a+trunc(a/4)*1.0;
  61.   c := 365.0 * yearnumber+trunc(yearnumber/4);
  62.   d := trunc(30.6001*(monthnumber+1));
  63.   juliandate := b+c+d+1720994.5+daynumber;
  64. {  writeln('julian date ',b+c+d+1720994.5+daynumber:10:1);}
  65. END;
  66.  
  67. BEGIN
  68.   WITH recpack DO
  69.     BEGIN
  70.       ax := $2a shl 8;
  71.     END;
  72.   MsDos(recpack);                        { call function }
  73.   WITH recpack DO
  74.     BEGIN
  75.       str(cx,year);                        {convert to string}
  76.       yearnumber := cx;
  77.       daynumber := dx MOD 256;
  78.       str(daynumber,day);                     { " }
  79.       month := dx shr 8;
  80.     END;
  81.   WITH recpack DO
  82.     BEGIN
  83.       ax := $2c shl 8;
  84.     END;
  85.   MsDos(recpack);
  86.   WITH recpack DO
  87.     BEGIN
  88.       time := cx shr 8;
  89.       IF time = 0
  90.         THEN time := 12;
  91.       IF time>12
  92.         THEN BEGIN
  93.                ampm := 'PM';
  94.                time := time -12;
  95.           END
  96.         ELSE ampm := 'AM';
  97.       str(time,hours);
  98.       str(cx MOD 256,minutes);
  99.       IF (cx MOD 256)<10
  100.         THEN minutes := '0'+minutes;
  101.       str(dx shr 8,seconds);
  102.       IF (dx shr 8)<10
  103.         THEN seconds := '0'+seconds;
  104.     END;
  105.   dayoftheweek := (dayofweek(juliandate(daynumber,month,yearnumber)));
  106.  
  107.   IF daynumber > 9
  108.     THEN
  109.       datetime := dayoftheweek+' '+day+' '+mon[month]+' '+year
  110.                   +'   '+hours+':'+minutes+' '+ampm
  111.     ELSE
  112.       datetime := dayoftheweek+' '+' '+day+' '+mon[month]+' '+year+'   '
  113.                   +hours+':'+minutes+' '+ampm;
  114. END;
  115.  
  116. BEGIN
  117.   datetimestamp := datetime;
  118.   writeln(datetimestamp);
  119. END.
  120.