{$IFNDEF WIN32}
type
 {Used for pointer math under Win16}
 PPtrRec = ^TPtrRec;
 TPtrRec = record
 Lo: Word;
 Hi: Word;
end;
{$ENDIF}

{Used for huge pointer math}
function GetBigPointer(lp: pointer; Offset: Longint): Pointer;
begin
 {$IFDEF WIN32}
 GetBigPointer := @PByteArray(lp)^[Offset];
 {$ELSE}
 Offset := Offset + TPtrRec(lp).Lo;
 GetBigPointer := Ptr(TPtrRec(lp).Hi + TPtrRec(Offset).Hi *
 SelectorInc,
 TPtrRec(Offset).Lo);
 {$ENDIF}
end;

procedure TForm1.Button1Click(Sender: TObject);
var
 hPixelBuffer : THandle; {Handle to the pixel buffer}
 lpPixelBuffer : pointer; {pointer to the pixel buffer}
 lpPalBuffer : PLogPalette; {The palette buffer}
 lpBitmapInfo : PBitmapInfo; {The bitmap info header}
 BitmapInfoSize : longint; {Size of the bitmap info header}
 BitmapSize : longint; {Size of the pixel array}
 PaletteSize : integer; {Size of the palette buffer}
 i : longint; {loop variable}
 j : longint; {loop variable}
 OldPal : hPalette; {temp palette}
 hPal : hPalette; {handle to our palette}
 hBm : hBitmap; {handle to our bitmap}
 Bm : TBitmap; {temporary TBitmap}
 Dc : hdc; {used to convert the DOB to a DDB}
 IsPaletteDevice : bool;
begin
 Application.ProcessMessages;
 {If range checking is on - turn it off for now}
 {we will remember if range checking was on by defining}
 {a define called CKRANGE if range checking is on.}
 {We do this to access array members past the arrays}
 {defined index range without causing a range check}
 {error at runtime. To satisfy the compiler, we must}
 {also access the indexes with a variable. ie: if we}
 {have an array defined as a: array[0..0] of byte,}
 {and an integer i, we can now access a[3] by setting}
 {i := 3; and then accessing a[i] without error}
 {$IFOPT R+}
 {$DEFINE CKRANGE}
 {$R-}
 {$ENDIF}

 {Lets check to see if this is a palette device - if so, then}
 {we must do palette handling for a successful operation.}
 {Get the screen's dc to use since memory dc's are not reliable}
 dc := GetDc(0);
 IsPaletteDevice :=
 GetDeviceCaps(dc, RASTERCAPS) and RC_PALETTE = RC_PALETTE;
 {Give back the screen dc}
 dc := ReleaseDc(0, dc);

 {Размер информации о рисунке должен равняться размеру BitmapInfo}
 {плюс размер таблицы цветов, минус одна таблица}
 {так как она уже объявлена в TBitmapInfo}
 BitmapInfoSize := sizeof(TBitmapInfo) + (sizeof(TRGBQUAD) * 255);

 {The bitmap size must be the width of the bitmap rounded}
 {up to the nearest 32 bit boundary}
 BitmapSize := (sizeof(byte) * 256) * 256;

 {Размер палитры должен равняться размеру TLogPalette}
 {плюс количество ячеек цветовой палитры - 1, так как}
 {одна палитра уже объявлена в TLogPalette}
 if IsPaletteDevice then
 PaletteSize := sizeof(TLogPalette) + (sizeof(TPaletteEntry) * 255);

 {Выделяем память под BitmapInfo, PixelBuffer, и Palette}
 GetMem(lpBitmapInfo, BitmapInfoSize);
 hPixelBuffer := GlobalAlloc(GHND, BitmapSize);
 lpPixelBuffer := GlobalLock(hPixelBuffer);

 if IsPaletteDevice then
 GetMem(lpPalBuffer, PaletteSize);

 {Заполняем нулями BitmapInfo, PixelBuffer, и Palette}
 FillChar(lpBitmapInfo^, BitmapInfoSize, #0);
 FillChar(lpPixelBuffer^, BitmapSize, #0);
 if IsPaletteDevice then
 FillChar(lpPalBuffer^,PaletteSize, #0);

 {Заполняем структуру BitmapInfo}
 lpBitmapInfo^.bmiHeader.biSize := sizeof(TBitmapInfoHeader);
 lpBitmapInfo^.bmiHeader.biWidth := 256;
 lpBitmapInfo^.bmiHeader.biHeight := 256;
 lpBitmapInfo^.bmiHeader.biPlanes := 1;
 lpBitmapInfo^.bmiHeader.biBitCount := 8;
 lpBitmapInfo^.bmiHeader.biCompression := BI_RGB;
 lpBitmapInfo^.bmiHeader.biSizeImage := BitmapSize;
 lpBitmapInfo^.bmiHeader.biXPelsPerMeter := 0;
 lpBitmapInfo^.bmiHeader.biYPelsPerMeter := 0;
 lpBitmapInfo^.bmiHeader.biClrUsed := 256;
 lpBitmapInfo^.bmiHeader.biClrImportant := 256;

 {Заполняем таблицу цветов BitmapInfo оттенками серого: от чёрного до белого}
 for i := 0 to 255 do
 begin
 lpBitmapInfo^.bmiColors[i].rgbRed := i;
 lpBitmapInfo^.bmiColors[i].rgbGreen := i;
 lpBitmapInfo^.bmiColors[i].rgbBlue := i;
 end;
end;