var 
  Zeilen, Reihen, ZellHoehe, ZellBreite: Byte; 
 
function Waben(bm: TBitmap; komplett: Boolean; Grund, Stift, Fuellung: TColor; 
  Abstand: Byte = 255): Byte; 
var 
  wdt, hgt, x, y, i, j, r, h, m, z, o: Integer; 
 
  procedure Sechseck(cnv: TCanvas; x6, y6: Integer); 
  var 
    points: array [0 .. 5] of TPoint; 
    xm, yh, xw, ya, ym: Integer; 
  begin 
    xm := x6 + m; 
    yh := y6 + hgt; 
    xw := x6 + wdt; 
    ya := y6 + Abstand; 
    ym := yh - Abstand; 
    points[0] := point(xm, y6); 
    points[1] := point(x6, ya); 
    points[2] := point(x6, ym); 
    points[3] := point(xm, yh); 
    points[4] := point(xw, ym); 
    points[5] := point(xw, ya); 
    cnv.Polygon(points); 
  end; 
 
begin 
  if not odd(Zeilen) then 
  begin 
    Result := 1; 
    exit; 
  end; 
  if not komplett and (Reihen < Zeilen div 2 + 1) then 
  begin 
    Result := 2; 
    exit; 
  end; 
  if not odd(ZellBreite) then 
  begin 
    Result := 3; 
    exit; 
  end; 
  if ZellHoehe < 7 then 
  begin 
    Result := 4; 
    exit; 
  end; 
  if ZellBreite < 7 then 
  begin 
    Result := 5; 
    exit; 
  end; 
  wdt := ZellBreite - 1; 
  hgt := ZellHoehe - 1; 
  m := ZellBreite div 2; 
  z := Zeilen div 2; 
  r := Reihen - z - 1; 
  if Abstand = 255 then 
    Abstand := Round(ZellHoehe / 4) 
  else if Abstand < 2 then 
    Abstand := 2 
  else if Abstand > hgt div 2 - 1 then 
    Abstand := hgt div 2 - 1; 
  h := hgt - Abstand; 
  x := z * (wdt div 2); 
  bm.Height := Zeilen * h + Abstand + 1; 
  bm.Width := wdt * Reihen + 1; 
  with bm.Canvas do 
  begin 
    brush.Color := Grund; 
    FillRect(ClipRect); 
    brush.Color := Fuellung; 
    Pen.Color := Stift; 
  end; 
  if komplett then 
  begin 
    for j := 0 to z do 
    begin 
      o := ord(odd(j)); 
      for i := 0 to Reihen - 1 - o do 
        Sechseck(bm.Canvas, i * wdt + o * m, h * j); 
    end; 
  end 
  else 
    for j := 0 to z do 
      for i := 0 to r + j do 
        Sechseck(bm.Canvas, x + i * wdt - j * m, h * j); 
  y := (Zeilen - 1) * h; 
  if komplett then 
  begin 
    for j := 0 to z - 1 do 
    begin 
      o := ord(odd(j)); 
      for i := 0 to Reihen - 1 - o do 
        Sechseck(bm.Canvas, i * wdt + o * m, y - h * j); 
    end; 
  end 
  else 
    for j := 0 to z - 1 do 
      for i := 0 to r + j do 
        Sechseck(bm.Canvas, x + i * wdt - j * m, y - h * j); 
  Result := 0; 
end; 
 
 
// Beispielaufruf 
 
procedure TForm1.Button1Click(Sender: TObject); 
var 
  Value: Byte; 
  bmp: TBitmap; 
begin 
  bmp := TBitmap.Create; 
  Zeilen := 9; 
  Reihen := 8; 
  ZellHoehe := 27; 
  ZellBreite := 25; 
  Value := Waben(bmp, True, clWhite, clNavy, $99FFFF, 7); 
// oder auch nur
// Value := Waben(bmp, True, clWhite, clNavy, $99FFFF); 
  case Value of 
    1: 
      showmessage('Zeilenanzahl muss ungerade sein!'); 
    2: 
      showmessage('Die Zeilenanzahl ist zu groß für die Reihenzahl!'); 
    3: 
      showmessage('ZellBreite muss ungerade sein!'); 
    4: 
      showmessage('ZellHoehe muss mindestens 7 sein!'); 
    5: 
      showmessage('ZellBreite muss mindestens 7 sein!'); 
    0: 
      begin 
        Image1.AutoSize := True; 
        Image1.Picture.Assign(bmp); 
        // Image1.Transparent := True; 
      end; 
  end; 
  bmp.Free; 
end;