home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / DATEIT3A.ZIP / DATEDEMO.PAS next >
Encoding:
Pascal/Delphi Source File  |  1988-07-18  |  8.0 KB  |  226 lines
  1. {                   DateDemo - Date Manipulation Library v.3                  }
  2. { --------------------------------------------------------------------------- }
  3. PROGRAM DateDemo;
  4.   {$M 16384,22000,22000}
  5.   {$R-,S-,I+,D-,T-,F-,V-,B-,N-,L+}
  6.   USES
  7.     CRT,Qwik,WndwVars,Wndw,DOS,WWdateit;
  8.   TYPE
  9.     Str80 = STRING[80];
  10.   VAR
  11.     Serial: INTEGER;
  12.     j,OldCursor,DayOfWeek: WORD;
  13.     Date,Date2: dRec;
  14.     Ch: CHAR;
  15.     Hold: STRING;
  16.  
  17. const
  18.   FuncKey = #00;
  19.   RetKey = #13;
  20.   EscKey = #27;
  21.   StrA : array [1..16] of Str80 = (
  22.     '',
  23.     'Functions:',
  24.     '',
  25.     '  Julian:      - Returns a Julian Number for Given Date',
  26.     '  LeapYear     - Returns 0 for FALSE or 1 for TRUE',
  27.     '  CkDate       - Given Date TRUE or FALSE',
  28.     '  MonStr       - Returns Month number as a string',
  29.     '  DayStr       - Returns Weekday number as a string',
  30.     '  DateStr      - Returns Given Date in string format',
  31.     '  ComputeDays  - Add or Subtract Days from a Given Date',
  32.     '  Tomorrow     - Date after a Given Date',
  33.     '  Yesterday    - Date before a Given Date',
  34.     '  DiffDates    - Return Days/Months Difference between',
  35.     '                 to Dates',
  36.     '  CompareDates - Compare Date for Equality to, Greater',
  37.     '                 Than or Less Than another Date');
  38.  
  39.   PROCEDURE PressAny; BEGIN
  40.     REPEAT
  41.     UNTIL (KEYPRESSED);
  42.     Ch := READKEY;
  43.   END;{PressAny}
  44.  
  45.   PROCEDURE Start; BEGIN
  46.     Qwritec(1,1,CRTcols,-1,'WardWares DateIt Demo v.3');
  47.     TEXTCOLOR(LightBlue);
  48.     Qwritec(4,1,CRTcols,TextAttr,'For each of the following displays:');
  49.     Qwrite(5,26,TextAttr,'Press any KEY to continue.');
  50.     GETDATE(Date.y,Date.m,Date.d,Date.w);
  51.     Qwritec(2,1,CRTcols,-1,DateStr(Date,W1MONTHDY4,Slash));
  52.     PressAny;
  53.   END;{Start}
  54.  
  55.   PROCEDURE Info; BEGIN
  56.     SetWindowModes(ShadowRight);
  57.     MakeWindow(4,10,20,60,black+GreenBG,Black+GreenBG,HdoubleBrdr,aWindow);
  58.     TitleWindow(Top,Center,' FEATURES ');
  59.     WITH TopWndwStat DO BEGIN
  60.       FOR j:= 1 to 16 DO
  61.         Qwrite(WSrow+j,WScol+1,Black+GreenBG,StrA[j]);
  62.     END;{WITH}
  63.     PressAny;
  64.   END;{Info}
  65.  
  66.   PROCEDURE DoJulian; BEGIN
  67.     SetWindowModes(ShadowRight);
  68.     MakeWindow(9,13,3,55,Cyan+BlueBG,White+BlueBG,HdoubleBrdr,aWindow);
  69.     STR(Julian(Date):3,Hold);
  70.     Hold := 'Today''s Julian Date is: '+Hold;
  71.     Qwrite(10,19,Cyan+BlueBG,Hold);
  72.     PressAny;
  73.     RemoveWindow;
  74.   END;{DoJulian}
  75.  
  76.   PROCEDURE DoLeapYear; BEGIN
  77.     SetWindowModes(ShadowRight);
  78.     MakeWindow(10,13,3,55,Cyan+BlueBG,White+BlueBG,HdoubleBrdr,aWindow);
  79.     IF (LeapYear(Date.y)=1) THEN
  80.       Qwrite(11,19,Cyan+BlueBG,'This is a Leap Year.')
  81.     ELSE
  82.       Qwrite(11,19,Cyan+BlueBG,'This is NOT a Leap Year.');
  83.     PressAny;
  84.     RemoveWindow;
  85.   END;{DoLeapYear}
  86.  
  87.   PROCEDURE DoCkDate; BEGIN
  88.     SetWindowModes(ShadowRight);
  89.     MakeWindow(11,13,3,55,Cyan+BlueBG,White+BlueBG,HdoubleBrdr,aWindow);
  90.     Date2.m := 7; Date2.d := 33; Date2.y := 1988; Date2.w := 0;
  91.     IF (CkDate(Date2)) THEN
  92.       Hold := 'Is 7/33/1988 a valid day?  YES!'
  93.     ELSE
  94.       Hold := 'Is 7/33/1988 a valid day?  NO!!';
  95.     Qwrite(12,19,Cyan+BlueBG,Hold);
  96.     PressAny;
  97.     RemoveWindow;
  98.   END;{DoCkDate}
  99.  
  100.   PROCEDURE DoMonStr; BEGIN
  101.     SetWindowModes(ShadowRight);
  102.     MakeWindow(12,13,4,55,Cyan+BlueBG,White+BlueBG,HdoubleBrdr,aWindow);
  103.     TitleWindow(Top,Left,' and DayStr ');
  104.     Hold := 'Month Name Long: '+MonStr(Date.m,Month)+
  105.             ' or short: '+MonStr(Date.m,Mon);
  106.     Qwrite(13,19,Cyan+BlueBG,Hold);
  107.     Hold := 'Weekday Name Long: '+DayStr(Date.w,Long)+
  108.             ' or short: '+DayStr(Date.w,Short);
  109.     Qwrite(14,19,Cyan+BlueBG,Hold);
  110.     PressAny;
  111.     RemoveWindow;
  112.   END;{DoMonStr}
  113.  
  114.   PROCEDURE DoDateStr; BEGIN
  115.     SetWindowModes(ShadowRight);
  116.     MakeWindow(3,5,22,70,Cyan+BlueBG,White+BlueBG,HdoubleBrdr,aWindow);
  117.     TitleWindow(Top,Left,' FUNCTION: DateStr ');
  118.     Qwrite(7,9,Cyan+BlueBG,'Returns 21 Different String Date Formats');
  119.     Qwrite(8,9,Cyan+BlueBG,' with Slashes, Dashes or Periods.');
  120.     Qwrite(12,11,Cyan+BlueBG,DateStr(Date,MDY2,Slash));
  121.     Qwrite(12,25,Cyan+BlueBG,DateStr(Date,MDY4,Slash));
  122.     Qwrite(12,40,Cyan+BlueBG,DateStr(Date,DMY2,Slash));
  123.     Qwrite(12,55,Cyan+BlueBG,DateStr(Date,DMY4,Slash));
  124.     Qwrite(14,11,Cyan+BlueBG,DateStr(Date,Y2MD,Slash));
  125.     Qwrite(14,25,Cyan+BlueBG,DateStr(Date,Y4MD,Slash));
  126.     Qwrite(14,40,Cyan+BlueBG,DateStr(Date,MD,Slash));
  127.     Qwrite(14,55,Cyan+BlueBG,DateStr(Date,MY2,Slash));
  128.     Qwrite(16,11,Cyan+BlueBG,DateStr(Date,MY4,Slash));
  129.     Qwrite(16,25,Cyan+BlueBG,DateStr(Date,MONDY2,Slash));
  130.     Qwrite(16,40,Cyan+BlueBG,DateStr(Date,MONDY4,Slash));
  131.     Qwrite(16,55,Cyan+BlueBG,DateStr(Date,MONTHDY2,Slash));
  132.     Qwrite(18,11,Cyan+BlueBG,DateStr(Date,MONTHDY4,Slash));
  133.     Qwrite(18,33,Cyan+BlueBG,DateStr(Date,W1MONDY4,Slash));
  134.     Qwrite(18,55,Cyan+BlueBG,DateStr(Date,W1MONDY2,Slash));
  135.     Qwrite(20,11,Cyan+BlueBG,DateStr(Date,W1MONTHDY2,Slash));
  136.     Qwrite(20,33,Cyan+BlueBG,DateStr(Date,W1MONTHDY4,Slash));
  137.     Qwrite(20,55,Cyan+BlueBG,DateStr(Date,W2MONDY2,Slash));
  138.     Qwrite(22,11,Cyan+BlueBG,DateStr(Date,W2MONDY4,Slash));
  139.     Qwrite(22,33,Cyan+BlueBG,DateStr(Date,W2MONTHDY2,Slash));
  140.     Qwrite(22,55,Cyan+BlueBG,DateStr(Date,W2MONTHDY4,Slash));
  141.     PressAny;
  142.     RemoveWindow;
  143.   END;{DoDateStr}
  144.  
  145.   PROCEDURE DoComputeDays; BEGIN
  146.     SetWindowModes(ShadowRight);
  147.     MakeWindow(19,13,7,60,Cyan+BlueBG,White+BlueBG,HdoubleBrdr,aWindow);
  148.     TitleWindow(Top,Left,' ComputeDays/Tomorrow/Yesterday/DiffDates ');
  149.     ComputeDays(Date,100,Date2,Sub);
  150.     Hold := '100 Days before today was: '+DateStr(Date2,MDY4,Dash);
  151.     Qwrite(20,17,Cyan+BlueBG,Hold);
  152.     ComputeDays(Date,365,Date2,Add);
  153.     Hold := '365 Days after today is: '+DateStr(Date2,MDY4,Dash);
  154.     Qwrite(21,17,Cyan+BlueBG,Hold);
  155.     STR(DiffDates(Date,Date2,Months),Hold);
  156.     Hold := 'and is about '+Hold+' months Difference.';
  157.     Qwrite(22,17,Cyan+BlueBG,Hold);
  158.     Tomorrow(Date,Date2);
  159.     Hold := 'Tomorrow''s date is: '+DateStr(Date2,MDY4,Slash);
  160.     Qwrite(23,17,Cyan+BlueBG,Hold);
  161.     Yesterday(Date,Date2);
  162.     Hold := 'Yesterday''s date was: '+DateStr(Date2,MDY4,Slash);
  163.     Qwrite(24,17,Cyan+BlueBG,Hold);
  164.     PressAny;
  165.     RemoveWindow;
  166.   END;{DoComputeDays}
  167.  
  168.   PROCEDURE DoComparesDates;
  169.     PROCEDURE dWrite; BEGIN
  170.       CASE (CompareDates(Date,Date2)) OF
  171.         0: Hold := Hold+'equal to '+DateStr(Date2,MDY4,Slash);
  172.         1: Hold := Hold+'greater than '+DateStr(Date2,MDY4,Slash);
  173.         2: Hold := Hold+'less than '+DateStr(Date2,MDY4,Slash);
  174.       END;{CASE}
  175.     END;{dWrite}
  176.     BEGIN
  177.     SetWindowModes(ShadowRight);
  178.     MakeWindow(5,13,13,55,Cyan+BlueBG,White+BlueBG,HdoubleBrdr,aWindow);
  179.     Hold := 'Today: '+DateStr(Date,MDY4,Slash)+' is ';
  180.     dWrite;
  181.     Qwrite(7,17,Cyan+BlueBG,Hold);
  182.     Qwrite(9,20,Cyan+BlueBG,'Feel Free to Play with this and all of');
  183.     Qwrite(10,20,Cyan+BlueBG,'Functions of this toolkit.');
  184.     Qwrite(11,20,Cyan+BlueBG,'Registration is $10 and the first 10 people');
  185.     Qwrite(12,20,Cyan+BlueBG,'that do so will receive the source code.');
  186.     Qwrite(13,20,Cyan+BlueBG,'Thereafter it will cost $25 to receive the');
  187.     Qwrite(14,20,Cyan+BlueBG,'source code.  So send yours in TODAY!');
  188.     PressAny;
  189.     RemoveWindow;
  190.   END;{DoCompareDates}
  191.  
  192.   PROCEDURE CheckCursor;
  193.     VAR
  194.       CursorMode: INTEGER ABSOLUTE $0040:$0060;
  195.     BEGIN
  196.     IF (ActiveDispDev=MdaMono) AND (CursorMode=$0607) THEN
  197.     CursorChange($0C0D,OldCursor);
  198.   END;{CheckCursor}
  199.  
  200. BEGIN
  201.   InitWindow(Blue+LightGrayBG,TRUE);
  202.   CheckCursor;
  203.   CursorOff;
  204.   Start;
  205.   Info;
  206.   DoJulian;
  207.   DoLeapYear;
  208.   DoCkDate;
  209.   DoMonStr;
  210.   DoDateStr;
  211.   DoComputeDays;
  212.   DoComparesDates;
  213.   PressAny;
  214.   RemoveWindow;
  215.   Qfill (1,1,25,CRTcols,TextAttr,' ');
  216.   Qwritec(12,1,CRTcols,TextAttr,'Copyright 1988  WardWares');
  217.   Qwritec(13,1,CRTcols,TextAttr,'1130 NW Washington, Suite 4');
  218.   Qwritec(14,1,CRTcols,TextAttr,'Hamilton, OH  45013');
  219.   DELAY(2000);
  220.   NormVideo;
  221.   ClrScr;
  222.   CursorOn;
  223.   InitWindow(White+BlackBG,TRUE);
  224.   CLRSCR;
  225. END.
  226.