type
   TCalendarOrient = (Horz, Vert);

const
   MonthArr: array[1..12] of string = ('Январь', 'Февраль', 'Март', 'Апрель',
      'Май', 'Июнь', 'Июль', 'Август', 'Сентябрь', 'Октябрь', 'Ноябрь', 'Декабрь');
   WeekDayArr: array[1..7] of string = ('Пн', 'Вт', 'Ср', 'Чт', 'Пт', 'Сб', 'Вс');

procedure Calendar(Canvas: TCanvas; Left, Top, dx, dy, MonthLeft, Year, Month,
   FontSize: integer; BrushColor, FontColor: array of TColor; D31,
   YearVis: boolean; Orient: TCalendarOrient; Now: TDateTime; Rest: string;
   Festive, Shortened, AddRest, AddWork: array of byte; Move: byte = 0;
   Short: byte = 0);
var x1, x2, y1, y2, PosX, PosY: integer;
    i, dw, r: byte;
    s: string;
    DT: TDateTime;
    BC, FC: TColor;

   procedure Bounds(s: string; var Width, Height: integer);
   var R: TRect;
   begin
      R:=Rect(0, 0, 0, 0);
      DrawText(Canvas.Handle, PChar(s), Length(s), R, DT_EXPANDTABS or DT_CALCRECT);
      Width:=R.Right-R.Left;
      Height:=R.Bottom-R.Top;
   end;

   procedure CanvasTextOut(x, y: integer; s: string; CenterX: boolean = true);
   var Width, Height, d: integer;
   begin
      Bounds(s, Width, Height);
      d:=(dx-Width) div 2;
      if d<1 then
         d:=1;
      if CenterX then
         x:=x+d;
      d:=(dy-Height) div 2;
      if d<1 then
         d:=1;
      y:=y+d;
      Canvas.TextOut(x, y, s);
   end;

   function ColorRead(Color: array of TColor; n: byte; Color0: TColor): TColor;
   begin
      Result:=Color0;
      if n<=High(Color) then
         Result:=Color[n];
   end;

   function StrDiv(var s: string; c: char): string;
   var p: integer;
   begin
      p:=Pos(c, s);
      if p>0 then
      begin
         Result:=Copy(s, 1, p-1);
         Delete(s, 1, p);
      end else
      begin
         Result:=s;
         s:='';
      end;
   end;

   function RestDay: boolean;
   var i: integer;
       s, s1, s2: string;
       arr: array[1..7] of boolean;
   begin
      for i:=Low(arr) to High(arr) do
         arr[i]:=i>=6; // сб и вс - выходные дни
      s:=Rest;
      while s<>'' do
      begin
         s1:=StrDiv(s, '|'); //36526:3,6,7
         s2:=StrDiv(s1, ':'); //36526 (s1 = 3,6,7)
         i:=StrToInt(s2);
         if i<=DT then
         begin
            for i:=Low(arr) to High(arr) do
               arr[i]:=false;
            while s1<>'' do
            begin
               s2:=StrDiv(s1, ','); //3 (s1 = 6,7)
               i:=StrToInt(s2);
               if (i>=Low(arr)) and (i<=High(arr)) then
                  arr[i]:=true;
            end;
         end;
      end;
      Result:=arr[dw];
   end;

   function Affiliation(n: byte; p: array of byte): boolean;
   var i: integer;
   begin
      Result:=false;
      for i:=Low(p) to High(p) do
         if n=p[i] then
         begin
            Result:=true;
            Exit;
         end;
   end;

begin
   with Canvas do
   begin
      Inc(Left);
      Inc(Top);
      if FontSize<8 then
         FontSize:=8;
      Font.Size:=FontSize;
      Bounds('Пн', x1, y1);
      y1:=y1+3;
      if dx<x1 then
         dx:=x1;
      if dy<y1 then
         dy:=y1;
      if dx<dy+2 then
         dx:=dy+2;
      Pen.Width:=1;
      Pen.Color:=clWhite;
      Brush.Color:=clWhite;
      Rectangle(Left-1, Top-1, Left+8*dx+2, Top+8*dy+2);
      { рисование чисел }
      PosX:=1; // для Vert
      PosY:=2; // для Horz
      for i:=1 to 31 do
      begin
         if not TryEncodeDate(Year, Month, i, DT) then
            Break;
         dw:=DayOfWeek(DT);
         Dec(dw);
         if dw=0 then
            dw:=7;
         if (dw=1) and (i>1) then
         begin
            Inc(PosX);
            Inc(PosY);
         end;
         if (PosX=6) and D31 { перенести "31" в первый (левый) ряд } then
            PosX:=1;
         if (PosY=7) and D31 { перенести "31" в первый (верхний) ряд } then
            PosY:=2;
         BC:=ColorRead(BrushColor, 2, clWhite);
         FC:=ColorRead(FontColor, 2, clBlack);
         if RestDay then
         begin
            BC:=ColorRead(BrushColor, 4, $FF66FF);
            FC:=ColorRead(FontColor, 4, clBlack);
         end;
         if Affiliation(i, AddWork) then
         begin
            BC:=ColorRead(BrushColor, 2, clWhite);
            FC:=ColorRead(FontColor, 2, clBlack);
         end;
         if Affiliation(i, AddRest) then
         begin
            BC:=ColorRead(BrushColor, 4, $FF66FF);
            FC:=ColorRead(FontColor, 4, clBlack);
         end;
         if Trunc(DT)=Trunc(Now) then
         begin
            BC:=ColorRead(BrushColor, 3, clLime);
            FC:=ColorRead(FontColor, 3, clBlack);
         end;
         if Affiliation(i, Festive) then
         begin
            BC:=ColorRead(BrushColor, 5, clRed);
            FC:=ColorRead(FontColor, 5, clBlack);
         end;
         if i=Move then
         begin
            BC:=ColorRead(BrushColor, 6, clYellow);
            FC:=ColorRead(FontColor, 6, clBlack);
         end;
         Pen.Color:=BC;
         Brush.Color:=BC;
         x1:=Left+(dw-1)*dx;
         y1:=Top+PosY*dy;
         x2:=Left+dw*dx;
         y2:=Top+(PosY+1)*dy;
         if Orient=Vert then
         begin
            x1:=Left+PosX*dx;
            y1:=Top+dw*dy;
            x2:=Left+(PosX+1)*dx;
            y2:=Top+(dw+1)*dy;
         end;
         Rectangle(x1, y1, x2+1, y2+1);
         if Affiliation(i, Shortened) then
         begin
            BC:=ColorRead(BrushColor, 7, $FF66FF);
            FC:=ColorRead(FontColor, 7, clBlack);
            Pen.Color:=BC;
            Brush.Color:=BC;
            case Short of
            0: // треугольник
            begin
               r:=dx div 3;
               Polygon([Point(x2-r, y1), Point(x2, y1), Point(x2, y1+r)]);
            end;
            1: // кружок
            begin
               r:=dx div 8;
               x2:=x2-r-1;
               y2:=y1+r+2;
               Ellipse(x2-r, y2-r, x2+r, y2+r);
            end;
            end;
         end;
         Font.Color:=FC;
         Brush.Style:=bsClear;
         CanvasTextOut(x1, y1+1, IntToStr(i));
      end;
      { границы календаря }
      Inc(PosX);
      if D31 then
         PosX:=6;
      if Orient=Horz then
         PosX:=7;
      Inc(PosY);
      if D31 then
         PosY:=7;
      if Orient=Vert then
         PosY:=8;
      Pen.Color:=1;
      Pen.Width:=2;
      x2:=Left+PosX*dx+1;
      y2:=Top+PosY*dy+1;
      MoveTo(Left, Top);
      LineTo(x2, Top);
      LineTo(x2, y2);
      LineTo(Left, y2);
      LineTo(Left, Top-1);
      { названия дней недели }
      Brush.Color:=ColorRead(BrushColor, 1, clYellow);
      Font.Color:=ColorRead(FontColor, 1, clBlack);
      x2:=PosX*dx;
      y2:=2*dy;
      if Orient=Vert then
      begin
         x2:=dx;
         y2:=PosY*dy+1;
      end;
      Rectangle(Left, Top+dy, Left+x2+2, Top+y2+1);
      for i:=0 to 6 do
      begin
         x1:=Left+i*dx;
         y1:=Top+dy;
         if Orient=Vert then
         begin
            x1:=Left;
            y1:=Top+(i+1)*dy+1;
         end;
         CanvasTextOut(x1, y1, WeekDayArr[i+1]);
      end;
      { название месяца (и года) }
      Brush.Color:=ColorRead(BrushColor, 0, clWhite);
      Font.Color:=ColorRead(FontColor, 0, clBlack);
      Rectangle(Left, Top, Left+PosX*dx+2, Top+dy+1);
      s:='';
      if (Month>=1) and (Month<=12) then
         s:=MonthArr[Month];
      if YearVis then
         s:=Format('%s - %d год', [s, Year]);
      CanvasTextOut(Left+MonthLeft, Top, s, false);
      { сетка }
      Pen.Width:=1;
      x1:=1;
      x2:=6;
      y1:=3;
      y2:=PosY-1;
      if Orient=Vert then
      begin
         x1:=2;
         x2:=PosX-1;
         y1:=2;
         y2:=7;
      end;
      for i:=x1 to x2 do
      begin
         MoveTo(Left+i*dx, Top+dy);
         LineTo(Left+i*dx, Top+PosY*dy);
      end;
      for i:=y1 to y2 do
      begin
         MoveTo(Left, Top+i*dy);
         LineTo(Left+PosX*dx, Top+i*dy);
      end;
   end;
end;

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls;

type
  TForm1 = class(TForm)
    Image1: TImage;
    procedure FormCreate(Sender: TObject);
    procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

{ Копируем полностью type TCalendarOrient, const MonthArr,
  WeekDayArr и procedure Calendar и вставляем сюда }

procedure TForm1.FormCreate(Sender: TObject);
begin
   Image1.Width:=200;
   Image1.Height:=200;
   Image1.OnMouseMove:=Image1MouseMove;
end;

procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
const dx = 25;
      dy = 20; { размер клетки }
var Move: byte;
begin
   Move:=0;
   X:=(X-1) div dx - 1;
   Y:=(Y-1) div dy - 1;
   if (X>=0) and (X<7) and (Y>=0) and (Y<7) then
   begin
      { Определение дня недели 01.08.2015 }
      Move:=DayOfWeek(EncodeDate(2015, 8, 1))-1;
      if Move=0 then
         Move:=7;
      { Выделенный день недели }
      Move:=7*X + Y - Move + 2;
   end;
   Calendar(Image1.Canvas, 0, 0, dx, dy, 60, 2015, 8, 10, [], [],
      false, false, Vert, 42236, '', [], [], [], [], Move);
end;

end.