home *** CD-ROM | disk | FTP | other *** search
/ CD Shareware Magazine 1996 December / CD_shareware_12-96.iso / WIN / Programa / CALNPNL2.ZIP / CALPNL.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-08-31  |  41.7 KB  |  1,329 lines
  1. unit Calpnl;
  2.  
  3. { Posted in the hope that I can repay a little of my enormous debt to
  4.   those many unselfish people who have made my life easier with freeware
  5.   and code snippets.
  6.  
  7.                                 -o0o-
  8.  
  9.   TCalenPnl, a freeware Calendar descended from TCustomPanel. The really
  10.   hard work for this component was done by Robert Vivrette, and is adapted
  11.   from his freeware TDateEdit form.
  12.  
  13.                            ******NEW******
  14.   Roland Weinschuetz has added a considerable degree of functionality by
  15.   adding some sorely needed properties to TCalenPnl.  Roland agreed that it
  16.   would benefit from some European style date facilities, and did an excellent
  17.   job of implementing them.  The new properties are listed below.
  18.                          ******Resume******
  19.  
  20.   I needed a panel-based Calendar, and adapted the CalPop code to suit.
  21.   TCalenPnl retains all the properties of a TPanel, and adds a few more.
  22.   Some of the interesting published properties are...
  23.  
  24.   ShowDate:    Shows\Hides the buttons and 'MMMMM YYYY' display
  25.           above the abbreviated day names at the top. The Months
  26.                 or Years can then be changed programmatically by
  27.                 ScrollBars or similar.
  28.  
  29.   DayWidth:    Uses 1 to 3 characters (M, Mo, Mon) to define the day name.
  30.  
  31.   Font:        Big deal! Actually, the point is that the Font can be
  32.           changed (typically the size would be changed) when 
  33.                 TCalenPnl is Resized (OnResize).
  34.  
  35.   OnDateChange:    A centralized event that allows users to change Labels,
  36.                 ScrollBars, Graphs or ProgressBars when the CalendarDate
  37.                 property is changed, internally or externally.
  38.  
  39.   Some interesting Public properties...
  40.  
  41.   CalendarDate: A TDateTime property that you can read or write to
  42.           programmatically. The fractional part of CalendarDate,
  43.                 i.e. the time, is not stored.
  44.  
  45.   WeekNumber:     An integer representing the... Week number of the TCalenPnl.Year.
  46.  
  47.   DayOfYear:     Integer value for days that have passed, in the current
  48.           (CalendarDate) year.
  49.  
  50.   DaysInYear:    Integer, can be either 365 or 366. It could have just as
  51.           easily been Boolean (it calls the Boolean IsLeapYear protected
  52.                 Function), but it suited my project.
  53.  
  54.   .Day, .Month, .Year are all integer Public Properties.
  55.  
  56.   ***NEW, added by Roland, and marked  // RW: in the .PAS file.
  57.  
  58.   GermanDate:   Boolean switch to enable German date.
  59.   ColHoliday,
  60.   ColWeekend,
  61.   ColMarked:    TColor, to mark important dates.
  62.   Holidays,
  63.   Markdays:     TStrings, for storing holidays and special days as strings.
  64.  
  65.   There is some repetition in the code, as Robert's CalPop relies on the date
  66.   being changed only by the buttons, therefore only in increments of one. I
  67.   required TCalenPnl to be able to be set by other controls, so there is some
  68.   duplication.  A really clever programmer, over a rainy weekend, could re-do
  69.   the code to shrink it a touch.
  70.  
  71.   You may have to look closely at some of the code, as it has been written to
  72.   prevent a user entering an invalid date, which can happen with a ScrollBar.
  73.   If the date highlighted is 31 August, and the user scrolls to September, the
  74.   CalendarDate.Day is reset to the DaysInMonth (ie, 30), to prevent an error.
  75.   Shouldn't be a problem as it almost guarantees no errors, but be aware.
  76.  
  77.   If you use 'MMMM DD YYYY' format in your Win International settings, ie US
  78.   users, then the example above would use August 31. In other words, the code
  79.   is 'Internationalized', to that extent.
  80.  
  81.   While CalPnl.PAS  and the CalPnl.DCR have been produced in Delphi 2.0, there
  82.   is no reason why the .PAS would not work in 16 bit Delphi, apart from a few
  83.   // comments.
  84.  
  85.   Roland Weinschuetz has added the dynamic StartofWeek option that the earlier
  86.   TCalenPnl needed.
  87.  
  88.   If you have any criticisms or suggestions, please send them to me...
  89.  
  90.                      Peter Crain
  91.                      Brisbane, Queensland.
  92.                      AUSTRALIA.
  93.                      Compuserve 100237,2735
  94. }
  95.  
  96. interface
  97.  
  98. uses
  99.  SysUtils,
  100.   WinTypes,
  101.   WinProcs,
  102.   Messages,
  103.   Classes,
  104.   Graphics,
  105.   Controls,
  106.   Forms,
  107.   Dialogs,
  108.   extctrls,
  109.   StdCtrls,
  110.   Menus;
  111. const
  112.  BORDER = 2;
  113.  DAYS_IN_MONTH: array[1..12] of Integer = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
  114.  BUTTON_WIDTH = 16;
  115. type
  116.  TDayWidth = (dw1Char, dw2Char, dw3Char);
  117.  TPaintJob = (All, Header, Dates);
  118. type
  119.  TDateType = record
  120.   aYear, aMonth, aDay : Word;
  121. End; {Record}
  122. type
  123.  TCalenPnl = class(TCustomPanel)
  124. private
  125.  g_MouseDown : BOOL;
  126.  g_PrevYear, g_PrevMonth : Word;
  127.  g_DateArray : array[1..42] of string[2];
  128.  g_CurrDateIndex : Integer;
  129.  g_PrevDateIndex : Integer;
  130.  // RW: Changes for german date:
  131.  // index +1; Sunday is copied to last index
  132.  g_DayTitles : Array[0..7] of string[3]; {moved from const to enable Int ShortDayNames}
  133.  FOnDblClick: TNotifyEvent;
  134.  FOnDateChange: TNotifyEvent;
  135.  FButton: TMouseButton;
  136.  FButtonDown: Boolean;
  137.  FShowDate: Boolean;
  138.  FUseLongDate: Boolean;
  139.  g_RectHeight: Integer;
  140.  g_Width: Integer;
  141.  HeadingRect: TRect;
  142.  CalendarRect : TRect;
  143.  FMonth: Integer;
  144.  FDay: Integer;
  145.  FYear: Integer;
  146.  FDayWidth: TDayWidth;
  147.  FCalendarDate: TDateTime;
  148.  FWeekNumber: Integer;
  149.  FDayOfYear: Integer;
  150.  FDaysInYear: Integer;
  151.  // RW: Boolean to switch to german date
  152.  FGermanDate: Boolean;
  153.  // RW: Special colors may be chosen
  154.  FColHoliday: TColor;
  155.  FColWeekend: TColor;
  156.  FColMarked: TColor;
  157.  // RW: Properties for storing holidays and special days as strings
  158.  // format: dd.mm.
  159.  FHolidays: TStrings;
  160.  FMarkdays: TStrings;
  161.  
  162.  procedure SetCalendarDate(aDate: TDateTime);
  163.  procedure SetMonth(Value: Integer);
  164.  procedure SetDay(Value: Integer);
  165.  procedure SetYear(Value: Integer);
  166.  function GetShowDate: Boolean;
  167.  procedure SetShowDate(Value: Boolean);
  168.  procedure SetDayWidth(Value: TDayWidth);
  169.  function GetUseLongDate: Boolean;
  170.  procedure SetUseLongDate(Value: Boolean);
  171.  function JulDate1stWeek(JD : TDateTime) : TDateTime;
  172.  function WeekNo(JDate : TDateTime): Integer;
  173.  function GetWeekNumber: Integer;
  174.  function DOY (y, m, d : Word): Integer;
  175.  function GetDayOfYear: Integer;
  176.  function GetDaysInYear: integer;
  177.  // RW: this one sets the german date
  178.  procedure SetGermanDate(Value: Boolean);
  179.  // RW: adapted DayOfWeek-function to fit german date
  180.  function rDayOfWeek(vDate: TDateTime) : Integer;
  181.  // RW: set color properties
  182.  procedure SetColHoliday(Value: TColor);
  183.  procedure SetColWeekend(Value: TColor);
  184.  procedure SetColMarked(Value: TColor);
  185.  // RW: build string lists
  186.  procedure SetHolidays(Value: TStrings);
  187.  procedure SetMarkdays(Value: TStrings);
  188.  // RW: returns TRUE if parameter denotes a special day
  189.  function CheckHoliday(DateList: TStrings; sd: PChar; m: integer) : Boolean;
  190.  
  191. protected
  192.  procedure Paint; override;
  193.  procedure DateChange;
  194.  procedure DrawMonthHeader;
  195.  procedure DrawDaysHeader;
  196.  procedure DrawDates;
  197.  procedure DrawFocusFrame(nIndex : Integer);
  198.  procedure LoadDateArray;
  199.  function GetMonthBegin: Integer;
  200.  function DaysInMonth(nMonth, nYear : Integer): Integer;
  201.  function IsLeapYear(AYear: Integer): Boolean;
  202.  function SetDate(nDays : Integer): Boolean;
  203.  function GetLeftButtonRect : TRect;
  204.  function GetRightButtonRect : TRect;
  205.  function GetRectFromIndex(nIndex : Integer): TRect;
  206.  function GetIndexFromDate : Integer;
  207.  function GetIndexFromPoint(nLeft : Integer ; nTop : Integer) : Integer;
  208.  procedure DrawButtons;
  209.  procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  210.     X, Y: Integer); override;
  211.  procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
  212.      X, Y: Integer); override;
  213.  procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  214.  function ValidDate(aDate: TDateType) : Boolean;
  215.  
  216. public
  217.  constructor Create(AOwner: TComponent); override;
  218.  // RW: frees special date string lists
  219.  destructor Destroy; override;
  220.  property Day: Integer read FDay write SetDay;
  221.  property Month: Integer read FMonth write SetMonth;
  222.  property Year: Integer read FYear write SetYear;
  223.  property CalendarDate: TDateTime read FCalendarDate write SetCalendarDate;
  224.  property WeekNumber: Integer read GetWeekNumber;
  225.  property DayOfYear: Integer read GetDayOfYear;
  226.  property DaysInYear: Integer read GetDaysInYear;
  227.  
  228. published
  229.  property Align;
  230.  property BevelInner default bvLowered;
  231.  property BevelOuter default bvRaised;
  232.  property BevelWidth default 1;
  233.  property BorderStyle default bsNone;
  234.  property BorderWidth default 1;
  235.  property Color;
  236.  property Ctl3D;
  237.  property Cursor;
  238.  property DragCursor;
  239.  property DragMode;
  240.  property Enabled;
  241.  property Font;
  242.  property Height default 160;
  243.  property HelpContext;
  244.  property Hint;
  245.  property Left;
  246.  property Locked;
  247.  property Name;
  248.  property ParentColor;
  249.  property ParentCtl3D;
  250.  property ParentFont;
  251.  property ParentShowHint;
  252.  property PopupMenu;
  253.  property ShowHint;
  254.  property TabOrder;
  255.  property TabStop;
  256.  property Tag;
  257.  property Top;
  258.  property Visible;
  259.  property Width default 160;
  260.  property ShowDate: Boolean read GetShowDate write SetShowDate default False;
  261.  property UseLongDate: Boolean read GetUseLongDate write SetUseLongDate; {defaults to False}
  262.  property DayWidth: TDayWidth read FDayWidth write SetDayWidth default dw2Char;
  263.  property OnClick;
  264.  property OnDblClick;
  265.  property OnDragDrop;
  266.  property OnDragOver;
  267.  property OnEndDrag;
  268.  property OnEnter;
  269.  property OnExit;
  270.  property OnMouseDown;
  271.  property OnMouseMove;
  272.  property OnMouseUp;
  273.  property OnResize;
  274.  property OnDateChange: TNotifyEvent read FOnDateChange write FOnDateChange;
  275.  // RW: these will be visible in the object-inspector
  276.  property GermanDate: Boolean read FGermanDate write SetGermanDate;
  277.  property ColHoliday: TColor read FColHoliday write SetColHoliday;
  278.  property ColWeekend: TColor read FColWeekend write SetColWeekend default clPurple;
  279.  property ColMarked: TColor read FColMarked write SetColMarked;
  280.  property Holidays: tstrings read FHolidays write SetHolidays;
  281.  property Markdays: tstrings read FMarkdays write SetMarkdays;
  282.  
  283. end;
  284.  
  285. procedure Register;
  286.  
  287. implementation
  288.  
  289. procedure Register;
  290. begin
  291.   RegisterComponents('Samples', [TCalenPnl]);
  292. end;
  293.  
  294. function PointInRect( const rectTest: TRect; X, Y: integer ): boolean;
  295. begin
  296.   Result := ( ( X >= rectTest.Left ) and ( X <= rectTest.Right ) and
  297.      ( Y >= rectTest.Top ) and ( Y <= rectTest.Bottom ) );
  298. end;
  299.  
  300. function TCalenPnl.GetShowDate: Boolean;
  301. begin
  302.  Result := FShowDate;
  303. end;
  304.  
  305. procedure TCalenPnl.SetShowDate(Value: Boolean);
  306. begin
  307.  if Value <> FShowDate then
  308.   begin FShowDate := Value;
  309.   Refresh;
  310.  end;
  311. end;
  312.  
  313. function TCalenPnl.GetUseLongDate: Boolean;
  314. begin
  315.  Result := FUseLongDate;
  316. end;
  317.  
  318. procedure TCalenPnl.SetUseLongDate(Value: Boolean);
  319. begin
  320.  if Value <> FUseLongDate then
  321.   begin FUseLongDate := Value;
  322.   Refresh;
  323.  end;
  324. end;
  325.  
  326. procedure TCalenPnl.SetDayWidth(Value: TDayWidth);
  327. begin
  328.  if Value <> FDayWidth then
  329.   begin FDayWidth := Value;
  330.   Refresh;
  331.  end;
  332. end;
  333.  
  334. constructor TCalenPnl.Create(AOwner: TComponent);
  335. var
  336.  iCount: Integer;
  337.  aY, aM, aD: Word;
  338. begin
  339.  inherited Create(AOwner);
  340.  // RW: Create the stringlists for special days
  341.  FHolidays := TStringList.Create;
  342.  FMarkdays := TStringList.Create;
  343.  Height := 160;
  344.  Width := 160;
  345.  BevelOuter := bvRaised;
  346.  BevelInner := bvLowered;
  347.  BevelWidth := 1;
  348.  BorderStyle := bsNone;
  349.  BorderWidth := 1;
  350.  DayWidth := dw2Char;
  351.  for iCount := 0 to 6 do g_DayTitles[iCount] := ShortDayNames[iCount +1];
  352.  // RW: copy sunday to index 7 for german date
  353.  g_DayTitles[7] := ShortDayNames[1];
  354.  FCalendarDate := Date;
  355.  FShowDate := False;
  356.  DecodeDate(FCalendarDate, aY, aM, aD );
  357.  FMonth := Integer(aM);
  358.  FDay := Integer(aD);
  359.  FYear := Integer(aY);
  360.  g_PrevDateIndex := 0;
  361.  LoadDateArray;
  362.  SetDate(0);
  363.  g_MouseDown := False;
  364. end;
  365.  
  366. // RW: free special date stringlist
  367. destructor TCalenPnl.Destroy;
  368. begin
  369.   FHolidays.Free;
  370.   FMarkdays.Free;
  371.   inherited Destroy;
  372. end;
  373.  
  374. procedure TCalenPnl.Paint;
  375. var
  376.  iInnerSpace, iWBorder, iHBorder, iInnerW, innerH, iLMargin, iLinesH: Integer;
  377. begin
  378.  inherited Paint;
  379.  iInnerSpace := 0;
  380.  if BorderStyle = bsSingle then iInnerSpace := 1;
  381.  if BevelOuter <> bvNone then iInnerSpace := BevelWidth + iInnerSpace;
  382.  if BevelInner <> bvNone then iInnerSpace:= BevelWidth + iInnerSpace;  { + 1}
  383.  iInnerSpace:= BorderWidth + iInnerSpace;
  384.  {iInnerSpace = the border, including bevels, on 1 side}
  385.  iInnerW := Width - (iInnerSpace * 2);
  386.  iWBorder := iInnerW div 100;
  387.  {g_Width is a product of useable space, not all space}
  388.  {clear space less a border both sides, makes g_Width narrower}
  389.  g_Width := (iInnerW - (iWBorder * 2)) div 7;
  390.  innerH := Height - (iInnerSpace * 2);
  391.  iHBorder := innerH div 100;
  392.  if ShowDate then iLinesH := 8 else iLinesH := 7;
  393.  {take out 2 iHBorder for spacing at top}
  394.  g_RectHeight := (innerH - (iHBorder * 2) ) div iLinesH;
  395.  iLMargin := (iInnerW - (g_Width * 7)) div 2;
  396.  HeadingRect := ClientRect;
  397.  HeadingRect.Top := HeadingRect.Top + iInnerSpace + iHBorder;
  398.  HeadingRect.Left := HeadingRect.Left + iInnerSpace + iLMargin ;
  399.  HeadingRect.Right := HeadingRect.Left + (g_Width * 7) ;
  400.  if ShowDate then HeadingRect.Bottom := HeadingRect.Top + (g_RectHeight * 2)
  401.    else HeadingRect.Bottom := HeadingRect.Top + g_RectHeight;
  402.  CalendarRect := HeadingRect;
  403.  CalendarRect.Top := HeadingRect.Bottom ;
  404.  CalendarRect.Bottom := CalendarRect.Top + (g_RectHeight * 6);
  405.  Canvas.Brush.Color := clBtnFace;
  406.  Canvas.FillRect(CalendarRect);
  407.  g_CurrDateIndex := FDay + GetMonthBegin - 1;
  408.  if ShowDate then
  409.   begin
  410.    DrawButtons;
  411.    DrawMonthHeader;
  412.   end;
  413.  DrawDaysHeader;
  414.  DrawDates;
  415.  DrawFocusFrame(g_CurrDateIndex);
  416. end;
  417.  
  418. procedure TCalenPnl.DrawMonthHeader;
  419. var
  420.    iRectHt, iSpaces, iIndent: Integer;
  421.    sMonth : String;
  422.    pMonth : PChar;
  423.    TempRect : TRect;
  424. begin
  425.   with Canvas do
  426.    begin
  427.     Font.Color := clBlack;
  428.     Font.Style := [fsBold];
  429.     if UseLongDate then sMonth := FormatDateTime( 'mmmm yyyy', FCalendarDate )
  430.       else sMonth := FormatDateTime( 'mmm yyyy', FCalendarDate );
  431.     pMonth := StrAlloc( Length( sMonth ) + BORDER );
  432.     StrPCopy( pMonth, sMonth );
  433.     TempRect := HeadingRect;
  434.     iRectHt := HeadingRect.Bottom - HeadingRect.Top;
  435.     iIndent := (TempRect.Right - TempRect.Left) div 20;
  436.     iSpaces := (iRectHt div 20) * BORDER;
  437.     if iSpaces = 0 then iSpaces := 1;
  438.     TempRect.Top := TempRect.Top + iSpaces ;
  439.     TempRect.Bottom := TempRect.Top + g_RectHeight ;
  440.     TempRect.Left := TempRect.Left + iIndent + BUTTON_WIDTH + 1;
  441.     TempRect.Right := TempRect.Right - (iIndent + BUTTON_WIDTH + 1);
  442.     Brush.Color := clBtnFace;
  443.     Brush.Style := bsSolid;
  444.     FillRect( TempRect );
  445.     DrawText( Handle, pMonth, Length( sMonth ), TempRect,
  446.              ( DT_CENTER or DT_TOP or DT_SINGLELINE ) );
  447.    end;
  448.   StrDispose( pMonth );
  449. end;
  450.  
  451. procedure TCalenPnl.DrawDaysHeader;
  452. var
  453.    i, iDayWidth: Integer;
  454.    pDay: PChar;
  455.    ARect: TRect;
  456. begin
  457.   Case DayWidth of
  458.    dw1Char : iDayWidth := 1;
  459.    dw2Char : iDayWidth := 2;
  460.    dw3Char : iDayWidth := 3;
  461.    else iDayWidth := 1;
  462.   end;
  463.   pDay := StrAlloc( 3 );
  464.   ARect := HeadingRect;
  465.   ARect.Right := ARect.Left + g_Width;
  466.   if ShowDate then ARect.Top := ARect.Top + g_RectHeight ;
  467.   { Cycle through the days }
  468.   Canvas.Font.Style := [fsBold]; {make Days Bold}
  469.   for i := 0 to 6 do
  470.      begin
  471.         // RW: german date: (i=5) or (i=6)
  472.         if GermanDate = False then
  473.         begin
  474.            if (i = 0) or (i = 6) then Canvas.Font.Color := ColWeekend
  475.              else Canvas.Font.Color := clBlack;
  476.            StrPCopy( pDay, Copy(g_DayTitles[i], 1, iDayWidth));
  477.         end
  478.         else
  479.         begin
  480.            if (i = 5) or (i = 6) then Canvas.Font.Color := ColWeekend
  481.              else Canvas.Font.Color := clBlack;
  482.            StrPCopy( pDay, Copy(g_DayTitles[i+1], 1, iDayWidth));
  483.         end;
  484.  
  485.         DrawText( Canvas.Handle, pDay, iDayWidth, ARect,
  486.                 ( DT_CENTER or DT_VCENTER or DT_SINGLELINE ) ); 
  487.         ARect.Left := ARect.Right;
  488.         ARect.Right := ARect.Right + g_Width;
  489.      end;
  490.      Canvas.Font.Color := clBlack;
  491.      Canvas.Font.Style := [];  {reset Days <> Bold}
  492.      { Draw line below days }
  493.      with Canvas do
  494.         begin
  495.            ARect.Top := CalendarRect.Top - 4;
  496.            ARect.Left := HeadingRect.Left;
  497.            ARect.Right := HeadingRect.Right;
  498.            Pen.Color := clBtnHighlight;
  499.            MoveTo( ARect.Left , ARect.Top);
  500.            LineTo( ARect.Right, ARect.Top );
  501.            Pen.Color := clBtnShadow;
  502.            MoveTo( ARect.Left,  ARect.Top + 1 );
  503.            LineTo( ARect.Right, ARect.Top + 1  );
  504.         end;
  505.      StrDispose( pDay );
  506. end;
  507.  
  508. procedure TCalenPnl.DrawDates;
  509. var
  510.    nIndex, nWeek, nDay: Integer;
  511.    pDate: PChar;
  512.    TempRect: Trect;
  513. begin
  514.  pDate := StrAlloc( 3 );
  515.  With Canvas do
  516.   begin
  517.   { Define normal font }
  518.    Font.Style := [];
  519.    Pen.Color := clBlack;
  520.    { Cycle through the weeks }
  521.    for nWeek := 1 to 6 do
  522.     begin
  523.      { Cycle through the days }
  524.      for nDay := 1 to 7 Do
  525.       begin
  526.        nIndex := nDay + ( ( nWeek - 1 ) * 7 );
  527.  
  528.        StrPCopy( pDate, g_DateArray[nIndex] );
  529.        TempRect := CalendarRect; {OPTIMIZE: can it go outside loop?}
  530.        With TempRect Do
  531.         begin
  532.          Left := Left + (g_Width * (nDay - 1));
  533.          Top := Top + (g_RectHeight * (nWeek -1));
  534.          Bottom := Top +  g_RectHeight ;
  535.          Right := Left + g_Width;
  536.         end;
  537.  
  538.         if GermanDate = False then
  539.            if (nDay = 1) or (nDay = 7) then
  540.               Font.Color := ColWeekend else Font.Color := clBlack
  541.         else
  542.            if (nDay = 6) or (nDay = 7) then
  543.               Font.Color := ColWeekend else Font.Color := clBlack;
  544.  
  545.         if CheckHoliday(Holidays, pDate, FMonth) then
  546.            Font.Color := ColHoliday;
  547.         if CheckHoliday(Markdays, pDate, FMonth) then
  548.               Canvas.Font.Color := ColMarked;
  549.  
  550.         DrawText( Handle, pDate, Length( g_DateArray[nIndex] ),
  551.           TempRect, ( DT_CENTER or DT_VCENTER or DT_TOP or DT_SINGLELINE ) );
  552.         Font.Color := clBlack;
  553.        end;
  554.       end;
  555.      end;
  556.      StrDispose( pDate );
  557. end;
  558.  
  559. procedure TCalenPnl.LoadDateArray;
  560. var
  561.   nIndex : Integer;
  562.   nBeginIndex, nEndIndex : Integer;
  563. begin
  564.   nBeginIndex := GetMonthBegin;
  565.   nEndIndex := nBeginIndex + DaysInMonth(FMonth, FYear) - 1;
  566.   for nIndex := 1 to 42 do
  567.   begin
  568.      If ( nIndex < nBeginIndex ) or ( nIndex > nEndIndex ) Then
  569.         g_DateArray[nIndex] := '  '
  570.      else
  571.         g_DateArray[nIndex] := IntToStr( ( nIndex - nBeginIndex ) + 1 );
  572.   end;
  573. end;
  574.  
  575. function TCalenPnl.GetMonthBegin: Integer;
  576. var
  577.   FirstDate: TDateTime;
  578. begin
  579.   FirstDate := EncodeDate( FYear, FMonth, 1 );
  580.   // RW: took me long time to find it: central point to adapt date-format
  581.   Result := rDayOfWeek( FirstDate )
  582. end;
  583.  
  584. function TCalenPnl.DaysInMonth(nMonth, nYear : Integer): Integer;
  585. begin
  586.   Result := DAYS_IN_MONTH[nMonth]; { leap-year Feb is special }
  587.   if ( nMonth = 2 ) and IsLeapYear(nYear) then Inc( Result );
  588. end;
  589.  
  590. function TCalenPnl.IsLeapYear(AYear: Integer): Boolean;
  591. begin
  592.   Result := (AYear mod 4 = 0) and ((AYear mod 100 <> 0) or (AYear mod 400 = 0));
  593. end;
  594.  
  595. function TCalenPnl.SetDate(nDays : Integer): Boolean;
  596. var
  597.   aY, aM, aD: Word;
  598.   PrevDay: Word;
  599. begin
  600.  Result := True;
  601.  try
  602.   {Save current date information}
  603.   g_PrevDateIndex := g_CurrDateIndex;
  604.   DecodeDate(FCalendarDate, g_PrevYear, g_PrevMonth, PrevDay);
  605.   {Change the date and update member variables}
  606.   FCalendarDate := FCalendarDate + nDays;
  607.   DecodeDate(FCalendarDate, aY, aM, aD);
  608.   g_CurrDateIndex := ( aD + GetMonthBegin ) - 1;
  609.   {Reload Date Array & paint ONLY if month or year changed}
  610.   If (aM <> g_PrevMonth) or (aY <> g_PrevYear)Then
  611.    begin
  612.     FMonth := aM;
  613.     FYear := aY;
  614.     LoadDateArray;
  615.    end;
  616.   FDay := aD;
  617.  except
  618.   MessageBeep(MB_ICONEXCLAMATION);
  619.   Result := False;
  620.  end;
  621. end;
  622.  
  623. Function TCalenPnl.ValidDate(aDate: TDateType) : Boolean;
  624. Begin       {is cool as no exception is generated by invalid date}
  625.  ValidDate := True;
  626.   With aDate do
  627.    Begin
  628.     If (aMonth > 12) Or (aMonth < 1) Or (aDay < 1) or (aYear < 1) or (aYear > 9999) then
  629.      Begin
  630.       ValidDate := False;
  631.       Exit;
  632.      End;
  633.     If (aMonth = 2) And IsLeapYear(Integer(aYear)) then Dec(aDay);
  634.     If aDay > DaysInMonth(aMonth, aYear) then ValidDate := False;
  635.    End;
  636. End;
  637.  
  638. procedure TCalenPnl.SetCalendarDate(aDate: TDateTime);
  639. var
  640.  aYear, aMonth, aDay: Word;
  641. begin
  642. try
  643.  if FCalendarDate <> aDate then
  644.   begin
  645.    DecodeDate(aDate, aYear, aMonth, aDay);
  646.    FCalendarDate := aDate;
  647.    FYear := Integer(aYear);
  648.    FMonth := Integer(aMonth);
  649.    FDay := Integer(aDay);
  650.    LoadDateArray;
  651.    DateChange;
  652.    Refresh;
  653.   end;
  654. except
  655.   MessageBeep(MB_ICONEXCLAMATION);
  656.  end;
  657. end;
  658.  
  659. procedure TCalenPnl.SetMonth(Value: Integer);
  660. var
  661.  mDate : TDateType;
  662.  wValue, aY, aM, aD: Word;
  663.  iDaysInM : word;
  664. begin {no test for new <> old as that would fail at startup}
  665.  if (Value < 1) or (Value > 12) then
  666.   begin    {first test}
  667.    MessageBeep(MB_ICONEXCLAMATION);
  668.    Exit;
  669.   end;
  670.  wValue := Word(Value);
  671.  iDaysInM := DaysInMonth(wValue, FYear);
  672.  if iDaysInM < FDay then FDay := iDaysInM;
  673.  with mDate do
  674.   begin
  675.    aMonth := wValue; aDay := Word(FDay); aYear := Word(FYear);
  676.   end;
  677.  
  678.  if ValidDate(mDate) then  {2nd test}
  679.   begin
  680.    FCalendarDate := EncodeDate(Word(FYear), wValue, Word(FDay));
  681.    DecodeDate( FCalendarDate, aY, aM, aD);
  682.    g_CurrDateIndex := ( aD + GetMonthBegin ) - 1;
  683.    FYear := Integer(aY);
  684.    FMonth := Integer(aM);
  685.    FDay := Integer(aD);
  686.    DateChange;
  687.    LoadDateArray;
  688.    Refresh;
  689.   end
  690.  else MessageBeep(MB_ICONEXCLAMATION);
  691.  
  692. end;
  693.  
  694. procedure TCalenPnl.SetDay(Value: Integer);
  695. var
  696.  dDate : TDateType;
  697.  wValue, aY, aM, aD: Word;
  698. begin
  699.  if (Value < 1) or (Value > DaysInMonth(FMonth, FYear)) then
  700.   begin    {first test}
  701.    MessageBeep(MB_ICONEXCLAMATION);
  702.    Exit;
  703.   end;
  704.  wValue := Word(Value);
  705.  with dDate do
  706.   begin
  707.    aMonth := Word(FMonth); aDay := wValue; aYear := Word(FYear);
  708.   end;
  709.  if ValidDate(dDate) then  {2nd test}
  710.   begin
  711.    FCalendarDate := EncodeDate(Word(FYear), Word(FMonth), Value);
  712.    DecodeDate( FCalendarDate, aY, aM, aD);
  713.    g_CurrDateIndex := ( FDay + GetMonthBegin ) - 1;
  714.    FYear := Integer(aY);
  715.    FMonth := Integer(aM);
  716.    FDay := Integer(aD);
  717.    DateChange;
  718.    LoadDateArray;
  719.    Refresh;
  720.   end
  721.  else MessageBeep(MB_ICONEXCLAMATION);
  722. end;
  723.  
  724. procedure TCalenPnl.SetYear(Value: Integer);
  725. var
  726.  yDate : TDateType;
  727.  iDaysInM, wValue, aY, aM, aD: Word;
  728. begin
  729.  if (Value < 1) or (Value > 9999) then
  730.   begin    {first test}
  731.    MessageBeep(MB_ICONEXCLAMATION);
  732.    Exit;
  733.   end;
  734.  wValue := Word(Value);
  735.  
  736.  iDaysInM := DaysInMonth(FMonth, wValue);
  737.  if iDaysInM < FDay then FDay := iDaysInM;
  738.  
  739.  with yDate do
  740.   begin
  741.    aMonth := Word(FMonth); aDay := Word(FDay); aYear := wValue;
  742.   end;
  743.  if ValidDate(yDate) then  {2nd test}
  744.   begin
  745.    FCalendarDate := EncodeDate(wValue, Word(FMonth), Word(FDay));
  746.    DecodeDate(FCalendarDate, aY, aM, aD);
  747.    g_CurrDateIndex := ( FDay + GetMonthBegin ) - 1;
  748.    FYear := Integer(aY);
  749.    FMonth := Integer(aM);
  750.    FDay := Integer(aD);
  751.    DateChange;
  752.    LoadDateArray;
  753.    Refresh;
  754.   end
  755.  else MessageBeep(MB_ICONEXCLAMATION);
  756. end; 
  757.  
  758. procedure TCalenPnl.DrawFocusFrame( nIndex: Integer);
  759. type
  760.   ByteSet = set of Byte;
  761. var
  762.   pDate :PChar;
  763.   TempRect : TRect;
  764.   setWE : ByteSet;
  765. begin
  766.   pDate := StrAlloc( 3 );
  767.   setWE := [];
  768.  
  769.   // RW: this set is used throughout the rest of the function
  770.   // RW: so german date has to be checked but once
  771.   if GermanDate = False then
  772.      setWE := setWE + [1, 7, 8, 14, 15, 21, 22, 28, 29, 35, 36, 42]
  773.   else
  774.      setWE := setWE + [6, 7, 13, 14, 20, 21, 27, 28, 34, 35, 41, 42];
  775.  
  776.   If ( nIndex > 0 ) and ( nIndex < 42 ) then
  777.     //following line works, but may affect DblClick
  778.     //if nIndex = g_PrevDateIndex then exit;
  779.     If g_DateArray[nIndex] <> '  ' then
  780.        begin
  781.         { Erase Previous Date Focus }
  782.         If g_PrevDateIndex > 0 Then
  783.          begin
  784.            // RW: now here's the set
  785.            if g_PrevDateIndex in setWE then
  786.               Canvas.Font.Color := ColWeekend
  787.            else
  788.               Canvas.Font.Color := clBlack;
  789.  
  790.            Canvas.Font.Style := [];
  791.            StrPCopy( pDate, g_DateArray[g_PrevDateIndex] );
  792.  
  793.            // RW: Check if current day is a holiday in the list
  794.            if CheckHoliday(Holidays, pDate, FMonth) then
  795.               Canvas.Font.Color := ColHoliday;
  796.            if CheckHoliday(Markdays, pDate, FMonth) then
  797.               Canvas.Font.Color := ColMarked;
  798.  
  799.            Canvas.Brush.Color := clBtnFace;
  800.            TempRect := GetRectFromIndex(g_PrevDateIndex);
  801.            Canvas.FillRect(TempRect);
  802.            DrawText( Canvas.Handle, pDate, Length( g_DateArray[g_PrevDateIndex] ),
  803.                         TempRect, ( DT_CENTER or DT_VCENTER or DT_TOP or DT_SINGLELINE ) );
  804.           end;
  805.           {Draw the Date in Bold font}
  806.  
  807.            // RW: here again the set is used
  808.            if nIndex in setWE then
  809.               Canvas.Font.Color := ColWeekend
  810.            else
  811.               Canvas.Font.Color := clBlack;
  812.  
  813.            Canvas.Font.Style := [fsBold];
  814.            TempRect := GetRectFromIndex(nIndex);
  815.            StrPCopy( pDate, g_DateArray[nIndex] );
  816.  
  817.            // RW: check for holiday once more
  818.            if CheckHoliday(Holidays, pDate, FMonth) then
  819.               Canvas.Font.Color := ColHoliday;
  820.            if CheckHoliday(Markdays, pDate, FMonth) then
  821.               Canvas.Font.Color := ColMarked;
  822.  
  823.            DrawText( Canvas.Handle, pDate, Length( g_DateArray[nIndex] ),
  824.                      TempRect, ( DT_CENTER or DT_VCENTER or DT_TOP or DT_SINGLELINE ) );
  825.            { Frame date with Shadow }
  826.            Canvas.Pen.Color := clBtnShadow;   {clGray}
  827.            Canvas.MoveTo( TempRect.Left, TempRect.Bottom - 1 );
  828.            Canvas.LineTo( TempRect.Left, TempRect.Top );
  829.            Canvas.LineTo( TempRect.Right - 1, TempRect.Top );
  830.            { Frame date with Highlight }
  831.            Canvas.Pen.Color := clBtnHighlight;    {clWhite}
  832.            Canvas.LineTo( TempRect.Right - 1, TempRect.Bottom - 1 );
  833.            Canvas.LineTo( TempRect.Left, TempRect.Bottom - 1 );
  834.            { Restore Canvas settings}
  835.            Canvas.Pen.Color := clBlack;
  836.            Canvas.Font.Style := [];
  837.         end;
  838.   StrDispose( pDate );
  839. end;
  840.  
  841. function TCalenPnl.GetRectFromIndex(nIndex : Integer): TRect;  {1}
  842. var
  843.   TempRect: TRect;
  844.   nWeek : Integer;
  845.   nDay : Integer;
  846. begin
  847.   TempRect := CalendarRect;
  848.   with TempRect do
  849.      begin
  850.       nWeek := 1;    //if not initialized bloody Syntax checker returns cursor
  851.       case nIndex of //here after compile, losing ones place!
  852.             1..7 :  nWeek := 1;
  853.             8..14:  nWeek := 2;
  854.             15..21: nWeek := 3;
  855.             22..28: nWeek := 4;
  856.             29..35: nWeek := 5;
  857.             36..42: nWeek := 6;
  858.        end;
  859.        nDay := nIndex - ((nWeek-1) *7);
  860.        Left := Left + (g_Width * (nDay-1));
  861.        Top := Top + (g_RectHeight * (nWeek - 1) );
  862.        Bottom := Top +  g_RectHeight ;
  863.        Right := Left + g_Width;
  864.      end;
  865.   Result := TempRect;
  866. end;
  867.  
  868. function TCalenPnl.GetIndexFromDate : Integer;
  869. begin
  870.  Result := FDay + GetMonthBegin;
  871. end;
  872.  
  873. function TCalenPnl.GetIndexFromPoint(nLeft : Integer ; nTop : Integer) : Integer;
  874. var
  875.   nIndex, nWeek, nDay, iHorizontal, iTopOfCal: Integer;
  876.   TempRect: Trect;
  877. begin
  878.   TempRect := CalendarRect;
  879.   iTopOfCal := TempRect.Top;
  880.   nIndex := -1;
  881.   {Is point in the calendar rectangle?}
  882.   if ( nLeft > TempRect.Left ) and ( nTop > TempRect.Top ) and
  883.       ( nLeft < TempRect.Right ) and ( nTop < TempRect.Bottom ) then
  884.      begin
  885.         iHorizontal := (( nTop - iTopOfCal ) div g_RectHeight) + 1;
  886.         if iHorizontal <= 0 then iHorizontal := 1; {if its in the CalenRect then its valid}
  887.         nWeek := iHorizontal;
  888.         TempRect.Top := TempRect.Top + ( ( nWeek - 1 ) * g_RectHeight );
  889.         TempRect.Bottom := TempRect.Top + g_RectHeight;
  890.         TempRect.Right := TempRect.Left + g_Width;
  891.         { Determine the day number of the selected date }
  892.         for nDay := 1 to 7 do        {Cycle through the days}
  893.            begin
  894.               nIndex := nDay + ( ( nWeek - 1 ) * 7 );
  895.               if ( nLeft >= TempRect.Left ) and ( nLeft <= TempRect.Right ) then
  896.                  break
  897.               else
  898.                  begin
  899.                     TempRect.Left := TempRect.Right;
  900.                     TempRect.Right := TempRect.Left + g_Width;
  901.                  end;
  902.            end;
  903.      end;
  904.   Result := nIndex;
  905. end;
  906.  
  907. procedure TCalenPnl.MouseUp(Button: TMouseButton; Shift: TShiftState;
  908.   X, Y: Integer);
  909. begin
  910.   inherited MouseUp(Button, Shift, X, Y);
  911.   FButtonDown := False;
  912.   if FButton = mbRight then MouseCapture := False;
  913. end;
  914.  
  915. procedure TCalenPnl.DateChange;
  916. begin
  917.  if Assigned(FOnDateChange) then FOnDateChange(Self);
  918. end;
  919.  
  920. procedure TCalenPnl.MouseDown(Button: TMouseButton; Shift: TShiftState;
  921.       X, Y: Integer);
  922. var
  923.   nIndex : Integer;
  924.   Key: Word;
  925. begin
  926.   inherited MouseDown(Button, Shift, X, Y);
  927.   FButton := Button;
  928.   {Check if mouse was pressed in Left button area}
  929.   if PointInRect(GetLeftButtonRect, X, Y) then
  930.    begin
  931.     Key := Vk_Prior;
  932.     KeyDown(Key,Shift);
  933.     DateChange;
  934.    end;
  935.  
  936.   {Check if mouse was pressed in Right button area}
  937.   if PointInRect(GetRightButtonRect, X, Y) then
  938.    begin
  939.     Key := Vk_Next;
  940.     KeyDown(Key,Shift);
  941.     DateChange;
  942.    end;
  943.  
  944.   {Check if mouse was pressed in date area} // ouch!
  945.   if PointInRect(CalendarRect, X, Y) then
  946.    begin
  947.     g_MouseDown := True;
  948.     nIndex := GetIndexFromPoint( X, Y );
  949.     If (nIndex >= GetMonthBegin) and
  950.       (nIndex < (DaysInMonth(FMonth, FYear) + GetMonthBegin)) Then
  951.      begin
  952.       if Not SetDate(nIndex - g_CurrDateIndex) then exit;
  953.       DrawFocusFrame(nIndex);
  954.       DateChange;
  955.      end
  956.     else
  957.      g_MouseDown := False;
  958.    end;
  959. end;
  960.  
  961. function TCalenPnl.GetLeftButtonRect: TRect;
  962. var
  963.   TempRect: TRect;
  964.   iHt: Integer;
  965. begin
  966.    {Define Left Button Rectangle}
  967.    iHt := (HeadingRect.Bottom - HeadingRect.Top) div 15;
  968.    TempRect.Top := HeadingRect.Top + iHt;
  969.    TempRect.Bottom := TempRect.Top + BUTTON_WIDTH;
  970.    iHt := (HeadingRect.Right - HeadingRect.Left) div 30;
  971.    TempRect.Left := HeadingRect.Left + iHt;
  972.    TempRect.Right := TempRect.Left + BUTTON_WIDTH;
  973.    Result := TempRect;
  974. end;
  975.  
  976. function TCalenPnl.GetRightButtonRect: TRect;
  977. var
  978.   TempRect: TRect;
  979.   iHt: Integer;
  980. begin
  981.    {Define Right Button Rectangle}
  982.    iHt := (HeadingRect.Bottom - HeadingRect.Top) div 15;
  983.    TempRect.Top := HeadingRect.Top + iHt;
  984.    TempRect.Bottom := TempRect.Top + BUTTON_WIDTH;
  985.    iHt := (HeadingRect.Right - HeadingRect.Left) div 30;
  986.    TempRect.Left := HeadingRect.Right - (BUTTON_WIDTH + iHt);
  987.    TempRect.Right := TempRect.Left + BUTTON_WIDTH;
  988.    Result := TempRect;
  989. end;
  990.  
  991. procedure TCalenPnl.KeyDown(var Key: Word; Shift: TShiftState);
  992. var
  993.  iDaysIncrM, iDaysToAdd, iIncrM: integer;
  994. begin
  995.     Case key of
  996.      VK_Left : begin  {PrevDay;}
  997.                 if (FMonth = 1) and (FYear = 1) and (FDay = 1) then
  998.                  begin
  999.                   MessageBeep(MB_ICONEXCLAMATION);
  1000.                   exit;
  1001.                  end;
  1002.                 if Not SetDate(-1)then exit;
  1003.                 If (FMonth <> g_PrevMonth) or
  1004.                    (FYear <> g_PrevYear) Then Refresh
  1005.                     else DrawFocusFrame(g_CurrDateIndex);
  1006.                 end;
  1007.      VK_Right: begin  {NextDay;}
  1008.                 if (FMonth = 12) and (FYear = 9999) and (FDay = 31) then
  1009.                  begin
  1010.                   MessageBeep(MB_ICONEXCLAMATION);
  1011.                   exit;
  1012.                  end;
  1013.                 if Not SetDate(1) then exit;
  1014.                 If (FMonth <> g_PrevMonth) or
  1015.                    (FYear <> g_PrevYear) Then Refresh
  1016.                     else DrawFocusFrame(g_CurrDateIndex);
  1017.                 end;
  1018.      VK_Up :   begin  {PrevWeek;}
  1019.                 if (FMonth = 1) and (FYear = 1) and (FDay < 7) then
  1020.                  begin
  1021.                   MessageBeep(MB_ICONEXCLAMATION);
  1022.                   exit;
  1023.                  end;
  1024.                 if Not SetDate(-7) then exit;
  1025.                 If (FMonth <> g_PrevMonth) or
  1026.                    (FYear <> g_PrevYear) Then Refresh
  1027.                     else DrawFocusFrame(g_CurrDateIndex);
  1028.                 end;
  1029.      VK_Down : begin {NextWeek;}
  1030.                 if (FMonth = 12) and (FYear = 9999) and (FDay > 24) then
  1031.                  begin
  1032.                   MessageBeep(MB_ICONEXCLAMATION);
  1033.                   exit;
  1034.                  end;
  1035.                 if Not SetDate(7) then exit;
  1036.                 If (FMonth <> g_PrevMonth) or
  1037.                    (FYear <> g_PrevYear) Then Refresh
  1038.                     else DrawFocusFrame(g_CurrDateIndex);
  1039.                end;
  1040.      VK_Prior: begin {PrevMonth;}
  1041.                 if (FMonth = 1) and (FYear = 1) then
  1042.                  begin
  1043.                   MessageBeep(MB_ICONEXCLAMATION);
  1044.                   exit;
  1045.                  end;
  1046.                 if FMonth > 1 then iIncrM := FMonth -1 else iIncrM := 12;
  1047.                 iDaysIncrM := DaysInMonth(iIncrM, FYear);
  1048.                 if (iDaysIncrM < FDay) then
  1049.                   iDaysToAdd := DaysInMonth(FMonth, FYear)
  1050.                   else iDaysToAdd := iDaysIncrM;
  1051.                 try
  1052.                  if Not SetDate(-iDaysToAdd) then exit;
  1053.                  Refresh;
  1054.                 except
  1055.                  MessageBeep(MB_ICONEXCLAMATION);
  1056.                 end;
  1057.                end;
  1058.      Vk_Next : begin  {NextMonth;}
  1059.                 if (FMonth = 12) and (FYear = 9999) then
  1060.                  begin
  1061.                   MessageBeep(MB_ICONEXCLAMATION);
  1062.                   exit;
  1063.                  end;
  1064.                 if FMonth = 12 then iIncrM := 1 else iIncrM := FMonth + 1;
  1065.                 iDaysIncrM := DaysInMonth(iIncrM, FYear);
  1066.                 if (iDaysIncrM < FDay) then iDaysToAdd := iDaysIncrM
  1067.                   else iDaysToAdd := DaysInMonth(FMonth, FYear);
  1068.                 try
  1069.                  if Not SetDate(iDaysToAdd) then exit;
  1070.                  Refresh;
  1071.                 except
  1072.                  MessageBeep(MB_ICONEXCLAMATION);
  1073.                 end;
  1074.                end;
  1075.      VK_Home : begin {NextYear;}
  1076. {If the current year is a leap year and the date is before February 29, add 1 day}
  1077.                 if FYear = 9999 then
  1078.                  begin
  1079.                   MessageBeep(MB_ICONEXCLAMATION);
  1080.                   exit;
  1081.                  end;
  1082.                 If IsLeapYear(FYear) and
  1083.                   (FMonth < 3) Then if Not SetDate(1) then exit;
  1084.                 if Not SetDate(365) then exit;
  1085. {If the current year is a leap year and the date is after February 29, add 1 day}
  1086.                 If IsLeapYear(FYear) and
  1087.                   (FMonth > 3) Then if Not SetDate(1) then exit;
  1088.                 Refresh;
  1089.                end;
  1090.      VK_End :  begin {PrevYear;}
  1091.                 if FYear = 1 then
  1092.                  begin
  1093.                   MessageBeep(MB_ICONEXCLAMATION);
  1094.                   exit;
  1095.                  end;
  1096. {If the current year is a leap year and the date is after February 29, subtract 1 day}
  1097.                 If IsLeapYear(FYear) and
  1098.                  (FMonth > 3) Then if Not SetDate(-1) then exit;
  1099.                 if Not SetDate(-365) then exit;
  1100. {If the Previous year is a leap year and the date is before February 29, subtract 1 day}
  1101.                 If IsLeapYear(FYear) and
  1102.                  (FMonth < 3) Then if Not SetDate(-1) then exit;
  1103.                 Refresh;
  1104.                end;
  1105.     VK_Return: begin
  1106.                {TDateEdit( ctlParent ).Date := m_CurrentDateSelected; }
  1107.                {maybe you have a use for the Return or Esc keys}
  1108.                end;
  1109.   {VK_Escape : FormCancel;}
  1110.      else
  1111.  
  1112.      end;
  1113. end;
  1114.  
  1115. procedure TCalenPnl.DrawButtons;
  1116. var
  1117.   LBtnRect: TRect;
  1118.   RBtnRect : TRect;
  1119.   OldStyle : TBrushStyle;
  1120. begin
  1121.   with Canvas do
  1122.      begin
  1123.         LBtnRect := GetLeftButtonRect;
  1124.         RBtnRect := GetRightButtonRect;
  1125.  
  1126.         { Select Black Pen}
  1127.         Pen.Style := psSolid;
  1128.         Pen.Width := 1;
  1129.         Pen.Color := clBtnShadow;   {clBlack}
  1130.  
  1131.         { Draw Button Outlines }
  1132.         Rectangle(LBtnRect.Left, LBtnRect.Top, LBtnRect.Right, LBtnRect.Bottom);
  1133.         Rectangle(RBtnRect.Left, RBtnRect.Top, RBtnRect.Right, RBtnRect.Bottom);
  1134.  
  1135.         { Create Embossed effect - Outline left & upper in white}
  1136.         Pen.Color := clBtnHighlight;
  1137.         MoveTo( LBtnRect.Left + 1, LBtnRect.Bottom - 2 );
  1138.         LineTo( LBtnRect.Left + 1, LBtnRect.Top + 1 );
  1139.         LineTo( LBtnRect.Right - 2, LBtnRect.Top + 1 );
  1140.  
  1141.         MoveTo( RBtnRect.Left + 1, RBtnRect.Bottom - 2 );
  1142.         LineTo( RBtnRect.Left + 1, RBtnRect.Top + 1 );
  1143.         LineTo( RBtnRect.Right - 2, RBtnRect.Top + 1 );
  1144.  
  1145.         { Create Embossed effect - Outline right & bottom in shadow }
  1146.         Pen.Color := clBtnShadow;    {clGray}
  1147.         MoveTo( LBtnRect.Right -2, LBtnRect.Top +  1 );
  1148.         LineTo( LBtnRect.Right - 2, LBtnRect.Bottom - 2 );
  1149.         LineTo( LBtnRect.Left + 1, LBtnRect.Bottom - 2 );
  1150.  
  1151.         MoveTo( RBtnRect.Right - 2, RBtnRect.Top + 1 );
  1152.         LineTo( RBtnRect.Right - 2, RBtnRect.Bottom - 2 );
  1153.         LineTo( RBtnRect.Left + 1, RBtnRect.Bottom - 2 );
  1154.  
  1155.         {Draw Arrow}
  1156.         Brush.Color := clBtnShadow;    {clBlack clBtnShadow}
  1157.         OldStyle :=Brush.Style;
  1158.         Brush.Style := bsSolid;
  1159.         Polygon([Point(LBtnRect.Right - 5,LBtnRect.Top + 3),
  1160.                  Point(LBtnRect.Right - 5,LBtnRect.Bottom - 4),
  1161.                  Point(LBtnRect.Left + 3,LBtnRect.Top + 7)]);
  1162.         Polygon([Point(RBtnRect.Left + 4,RBtnRect.Top + 3),
  1163.                  Point(RBtnRect.Left + 4,RBtnRect.Bottom - 4),
  1164.                  Point(RBtnRect.Right - 4,RBtnRect.Top + 7)]);
  1165.  
  1166.         {my turn - white line on arrows}
  1167.         Pen.Color := clBtnHighlight;
  1168.         MoveTo( LBtnRect.Left + 3, LBtnRect.Top + 8 );
  1169.         LineTo( LBtnRect.Right - 5, LBtnRect.Bottom - 3);
  1170.         LineTo( LBtnRect.Right - 5, LBtnRect.Top + 2 );
  1171.         MoveTo( RBtnRect.Left + 4, RBtnRect.Bottom - 4 );
  1172.         LineTo( RBtnRect.Right - 2, RBtnRect.Top + 7 );
  1173.         Brush.Color :=clBtnFace;
  1174.         Brush.Style := OldStyle;
  1175.         Pen.Color := clBlack;
  1176.      end;
  1177. end;
  1178.  
  1179. function TCalenPnl.JulDate1stWeek(JD : TDateTime) : TDateTime;
  1180.   {-Return the Date of the first day in the week of Julian Year}
  1181. var
  1182.   aYear, aMonth, aDay : Word;
  1183.   n : integer;
  1184.   JDate     : TDateTime;
  1185. begin
  1186.   DecodeDate(JD, aYear, aMonth, aDay);
  1187.   JDate := EncodeDate(aYear, 1, 1);
  1188.     if rDayOfWeek(JDate) in [6, 7, 1] then n := 1 else n := -1;
  1189.   while rDayOfWeek(JDate) <> 2 do JDate := JDate+n;
  1190.   if JD >= JDate then
  1191.     Result := JDate
  1192.   else
  1193.     Result := JulDate1stWeek(JD-7);
  1194. end;
  1195.  
  1196. function TCalenPnl.WeekNo(JDate : TDateTime) : Integer;
  1197. var
  1198.   W         : TDatetime;
  1199. begin
  1200.   W := JulDate1stWeek(JDate+31);
  1201.   if JDate < W then W := JulDate1stWeek(JDate);
  1202.   Result := trunc(7+JDate-W) div 7;
  1203. end;
  1204.  
  1205. function TCalenPnl.GetWeekNumber: Integer;
  1206. begin
  1207.  Result := WeekNo(EncodeDate(FYear, FMonth, FDay));
  1208. end;
  1209.  
  1210. function TCalenPnl.DOY(y, m, d : Word) : Integer;
  1211. var
  1212.  yy, mm, dd, Tmp1 : LongInt;
  1213. begin
  1214.   yy := y;
  1215.   mm := m;
  1216.   dd := d;
  1217.   Tmp1 := (mm + 10) div 13;
  1218.   DOY :=  3055 * (mm + 2) div 100 - Tmp1 * 2 - 91 +
  1219.                   (1 - (yy - yy div 4 * 4 + 3) div 4 +
  1220.                   (yy - yy div 100 * 100 + 99) div 100 -
  1221.                   (yy - yy div 400 * 400 + 399) div 400) * Tmp1 + dd
  1222. end;  { DayOfYear }
  1223.  
  1224. function TCalenPnl.GetDayOfYear: Integer;
  1225. begin
  1226.  result := DOY(FYear, FMonth, FDay);
  1227. end;
  1228.  
  1229. function TCalenPnl.GetDaysInYear: integer;
  1230. begin
  1231.  If IsLeapYear(FYear) then Result := 366 else result := 365;
  1232. end;
  1233.  
  1234. // RW: added these functions
  1235. // Toggles start of the week (Sunday or Monday)
  1236. procedure TCalenPnl.SetGermanDate(Value: Boolean);
  1237. begin
  1238.   if Value <> FGermanDate then
  1239.   begin
  1240.     FGermanDate := Value;
  1241.     LoadDateArray;
  1242.     Refresh;
  1243.   end;
  1244. end;
  1245.  
  1246. // Corrected built-in-function to fit german date
  1247. function TCalenPnl.rDayOfWeek(vDate: TDateTime) : Integer;
  1248. begin
  1249.   Result := DayOfWeek(vDate);
  1250.   if GermanDate = True then
  1251.   begin
  1252.      Result := Result - 1;            // Sonntag abziehen / subtract Sunday
  1253.      if Result = 0 then Result := 7;  // Fehler ausgleichen / error correction
  1254.   end;
  1255. end;
  1256.  
  1257. // functions to set color values
  1258. procedure TCalenPnl.SetColHoliday(Value: TColor);
  1259. begin
  1260.   if Value <> FColHoliday then
  1261.   begin
  1262.      FColHoliday := Value;
  1263.      Refresh;
  1264.   end;
  1265. end;
  1266.  
  1267. procedure TCalenPnl.SetColWeekend(Value: TColor);
  1268. begin
  1269.   if Value <> FColWeekend then
  1270.   begin
  1271.      FColWeekend := Value;
  1272.      Refresh;
  1273.   end;
  1274. end;
  1275.  
  1276. procedure TCalenPnl.SetColMarked(Value: TColor);
  1277. begin
  1278.   if Value <> FColMarked then
  1279.   begin
  1280.      FColMarked := Value;
  1281.      Refresh;
  1282.   end;
  1283. end;
  1284.  
  1285. // build a string list for Holidays
  1286. procedure TCalenPnl.SetHolidays(Value: TStrings);
  1287. begin
  1288.   Holidays.Assign (Value);
  1289. end;
  1290.  
  1291. // build a string list for special days
  1292. procedure TCalenPnl.SetMarkdays(Value: TStrings);
  1293. begin
  1294.   Markdays.Assign (Value);
  1295. end;
  1296.  
  1297. // RW: this function compares a given day and month with the strings
  1298. // of a stringlist to find out about holidays and special days
  1299. function TCalenPnl.CheckHoliday(DateList: TStrings; sd: PChar; m: integer) : Boolean;
  1300. var
  1301.   i, z: integer;
  1302.   scmp, sm: string;
  1303. begin
  1304.   // Anzahl der ListeneintrĪ£ge bestimmen
  1305.   // Determine number of listentries
  1306.   z := Datelist.Count - 1;
  1307.   Result := False;
  1308.   scmp := '';
  1309.   if (Datelist.Count > 0) and (sd <> ' ') and (m > 0) then begin
  1310.      // Vergleichsstring basteln
  1311.      // Create compare string
  1312.      Str(m, sm);
  1313.      if GermanDate = True then
  1314.         scmp:= sd + '.' + sm + '.'
  1315.      else
  1316.         scmp:= sm + '/' + sd + '/';
  1317.      // Liste durchgehen, alle EintrĪ£ge vergleichen
  1318.      // Step through the list and compare all entries
  1319.      for i := 0 to z do begin
  1320.         if scmp = Datelist.Strings[i] then begin
  1321.            Result := True;
  1322.            break;
  1323.         end;
  1324.      end;
  1325.   end;
  1326. end;
  1327.  
  1328. end.
  1329.