1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:

private 
    { Private declarations } 
     OldGridProc3, OldGridProc4: TWndMethod; 
   [...] 
   procedure Grid3WindowProc(var Message: TMessage); 
   procedure Grid4WindowProc(var Message: TMessage); 
   [...] 

procedure TForm1.FormCreate(Sender: TObject); 
[...] 
//Für das Scrollen beider Grids
  OldGridProc3 := StringGrid1.WindowProc;
  OldGridProc4 := StringGrid3.WindowProc;
  StringGrid3.WindowProc := Grid3WindowProc;
  StringGrid4.WindowProc := Grid4WindowProc;
[...] 
procedure TForm1.Grid3WindowProc(var Message: TMessage);
begin
  OldGridProc3(Message);
  if ((Message.Msg = WM_VSCROLL) or (Message.Msg = WM_HSCROLL) or
      (Message.msg = WM_Mousewheel)) then
  begin
    OldGridProc4(Message);
  end;
end;

procedure TForm1.Grid2WindowProc(var Message: TMessage);
begin
  OldGridProc4(Message);
  if ((Message.Msg = WM_VSCROLL) or (Message.Msg = WM_HSCROLL) or
     (Message.msg = WM_Mousewheel)) then
  begin
    OldGridProc3(Message);
  end;
end;					

1:
2:
3:
4:
5:

procedure TForm1.ScrollBar1Scroll(Sender: TObject; ScrollCode: TScrollCode;
  var ScrollPos: Integer);
begin
 StringGrid1.ScrollBy(ScrollBar1.Left,  ScrollBar2.Top);
end;					

1:
2:
3:
4:
5:
6:
7:

procedure TForm1.StringGrid2DrawCell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);
begin
  StringGrid1.LeftCol := StringGrid2.LeftCol;
  StringGrid3.LeftCol := StringGrid2.LeftCol;
  StringGrid4.LeftCol := StringGrid2.LeftCol;
end;					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:

procedure TForm1.StringGrid2TopLeftChanged(Sender: TObject);
  var Monat : integer;
      strTag : string;
begin
  StringGrid1.LeftCol := StringGrid2.LeftCol;
  strTag := StringGrid4.Cells[StringGrid2.leftcol, 0];
  Monat := strtoint(copy(strtag, 4, 2));
  StringGrid3.LeftCol := Monat - 1;
  StringGrid4.LeftCol := StringGrid2.LeftCol;
end;					

1:
2:
3:
4:
5:
6:
7:
8:
9:

1  1  1
2  1  2
3  1  3
4  1  4
5  1  5
6  1  6
7  1  7
8  1  1
...					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Grids;

const C_CLFIXED = $00CEBCA2;
      C_CLFIXEDHELL = $00EDE7DC;
      C_CLNOWORK = $00F4F1EA;
      C_CLWORK = clWhite;
      //damit Code lesbarer ist
      C_TAG = 1;
      C_MONAT = 2;
      C_WTAG = 3;
type
  TForm1 = class(TForm)
    StringGrid1: TStringGrid;
    procedure FormCreate(Sender: TObject);
    procedure StringGrid1DrawCell(Sender: TObject; aCol, aRow: Integer;
      Rect: TRect; State: TGridDrawState);
  private
    FJahr : Word;
    FJahrArr : Array [1..366,C_TAG..C_WTAG] of Word;//ev. erweitern
    { Private-Deklarationen }
  public
    { Public-Deklarationen }
  end;

var
  Form1: TForm1;
implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
var z : Integer;
    aDateTime : TDateTime;
    dammy : Word;
begin
  FJahr := StrToInt(FormatDateTime('yyyy',now));
  aDateTime := EncodeDate(FJahr,1,1)-1;//-1 damit ab 31.12 hochgezählt wird
  //Jahres-Array füllen
  for z := 1 to 366 do
    begin
    DecodeDate(aDateTime+z,dammy,FJahrArr[z,C_MONAT],FJahrArr[z,C_TAG]);
    FJahrArr[z,C_WTAG] := DayOfWeek(aDateTime+z);//Wochentag 1 bis 7 ermitteln
    end;
  with StringGrid1 do
    begin
    Ctl3D := False;
    FixedCols := 1;
    FixedRows := 2;
    RowCount := 100;
    DefaultColWidth := 16;
    DefaultRowHeight := 16;
    ColWidths[0] := 50;
    Cells[0,2] := 'Meier';
    Cells[0,3] := 'Hinz';
    Cells[0,4] := 'Kunz';
    Cells[0,5] := 'Müller';
    if FJahrArr[366,C_TAG] <> 31 then
      ColCount := 366// 28 Tg
      else
        ColCount := 367;// 29 Tg
    DefaultDrawing:=false;//im Grid alles selber zeichnen
    end;
end;

procedure TForm1.StringGrid1DrawCell(Sender: TObject; aCol, aRow: Integer;
  Rect: TRect; State: TGridDrawState);
var aTag, aMonat : Integer;
    R : TRect;
begin
  aTag   := FJahrArr[ACol,C_TAG];
  aMonat := FJahrArr[ACol,C_MONAT];
  R := Rect;
  with StringGrid1 do
    begin
    if (aRow = 0) and (ACol >= FixedCols) then
      begin
      if aMonat mod 2 = 0 then
        Canvas.Brush.Color := C_CLFIXED
        else
          Canvas.Brush.Color := C_CLFIXEDHELL;
      Canvas.FillRect(Classes.Rect(R.Left,R.Top,R.Right+1,R.Bottom));
      if aTag = 1 then
        begin
        Canvas.Pen.Color := clBlack;
        Canvas.MoveTo(R.Left-1,R.Top);
        Canvas.LineTo(R.Left-1,R.Bottom);
        end;
      if aTag in [15..20] then
        Canvas.TextOut(R.Left+2-((aTag-15)*17),R.Top+2,LongMonthNames[aMonat]);
      end
      else
        begin
        if (ACol < FixedCols) or (ARow = 1) then
          Canvas.Brush.Color := C_CLFIXED
          else
            if FJahrArr[ACol,C_WTAG] in [1,7] then
              Canvas.Brush.Color := C_CLNOWORK
              else
                Canvas.Brush.Color := C_CLWORK;
        if (ACol < FixedCols) and (ARow < FixedRows) then
          Canvas.FillRect(Classes.Rect(R.Left,0,R.Right,R.Bottom))
          else
            Canvas.FillRect(R);
        if (aRow = 1) and (ACol >= FixedCols)  then
          Canvas.TextOut(R.Left+2,R.Top+2,Format('%.2d',[aTag]))
          else
            if (aRow = FixedRows-1) and (ACol = FixedCols-1) then
              Canvas.TextOut(R.Left+10,R.Top-8,IntToStr(FJahr))
              else
                Canvas.TextOut(R.Left+2,R.Top+2,Cells[aCol,aRow]);
        end;
    end;
end;

end.