type
   TCalendarOrient = (Horz, Vert);

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

procedure CalendarCanvas(Canvas: TCanvas; Left, Top, dx, dy, MonthLeft, Year,
   Month, FontSize: integer; BrushColor, FontColor: array of TColor; D31,
   YearVis: boolean; Orient: TCalendarOrient; Now: TDateTime; Vyhodnye: string;
   Prazdniki, Sokraschennye, DopVyhodnye, DopRabochie: array of byte;
   Move: byte = 0; Sokr: byte = 0);
var x1, x2, y1, y2, PosX, PosY: integer;
    i, dn, r: byte;
    s: string;
    DT: TDateTime;
    BC, FC: TColor;

   procedure DrawRect(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 DrawTextOut(x, y: integer; s: string; bx: boolean = true);
   var Width, Height, d: integer;
   begin
      DrawRect(s, Width, Height);
      d:=(dx-Width) div 2;
      if d<1 then
         d:=1;
      if bx 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 Vyhod: boolean;
   var n: integer;
       s, s1, s2: string;
       dv: array[1..7] of boolean;
   begin
      for n:=Low(dv) to High(dv) do
         dv[n]:=n>=6; // сб и вс - выходные дни
      s:=Vyhodnye;
      while s<>'' do
      begin
         n:=Pos('|', s);
         if n>0 then
         begin
            s1:=Copy(s, 1, n-1);
            Delete(s, 1, n);
         end else
         begin
            s1:=s;
            s:='';
         end;
         n:=Pos(':', s1);
         if n>=0 then
         begin
            s2:=Copy(s1, n+1, Length(s1));
            s1:=Copy(s1, 1, n-1);
         end else
            s2:='';
         n:=StrToInt(s1);
         if n<=DT then
         begin
            for n:=Low(dv) to High(dv) do
               dv[n]:=false;
            while s2<>'' do
            begin
               n:=Pos(',', s2);
               if n>0 then
               begin
                  s1:=Copy(s2, 1, n-1);
                  Delete(s2, 1, n);
               end else
               begin
                  s1:=s2;
                  s2:='';
               end;
               n:=StrToInt(s1);
               if (n>=Low(dv)) and (n<=High(dv)) then
                  dv[n]:=true;
            end;
         end;
      end;
      Result:=dv[dn];
   end;

   function Affiliation(p: array of byte; n: 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;
      DrawRect('Пн', 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;
         dn:=DayOfWeek(DT);
         Dec(dn);
         if dn=0 then
            dn:=7;
         if (dn=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 Vyhod then
         begin
            BC:=ColorRead(BrushColor, 4, $FF66FF);
            FC:=ColorRead(FontColor, 4, clBlack);
         end;
         if Affiliation(DopRabochie, i) then
         begin
            BC:=ColorRead(BrushColor, 2, clWhite);
            FC:=ColorRead(FontColor, 2, clBlack);
         end;
         if Affiliation(DopVyhodnye, i) 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(Prazdniki, i) 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+(dn-1)*dx;
         y1:=Top+PosY*dy;
         x2:=Left+dn*dx;
         y2:=Top+(PosY+1)*dy;
         if Orient=Vert then
         begin
            x1:=Left+PosX*dx;
            y1:=Top+dn*dy;
            x2:=Left+(PosX+1)*dx;
            y2:=Top+(dn+1)*dy;
         end;
         Rectangle(x1, y1, x2+1, y2+1);
         if Affiliation(Sokraschennye, i) then
         begin
            Pen.Color:=ColorRead(BrushColor, 7, $FF66FF);
            FC:=ColorRead(FontColor, 7, clBlack);
            Brush.Color:=Pen.Color;
            case Sokr 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;
         Pen.Color:=BC;
         Font.Color:=FC;
         Brush.Color:=BC;
         Brush.Style:=bsClear;
         DrawTextOut(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;
         DrawTextOut(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]);
      DrawTextOut(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}

{ procedure CalendarCanvas копируем полностью и вставляем сюда }

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;
   CalendarCanvas(Image1.Canvas, 0, 0, dx, dy, 60, 2015, 8, 10, [], [],
      false, false, Vert, 42236, '', [], [], [], [], Move);
end;

end.