[Graphics] Bitmap Library

unit LibBitmap;

interface

uses
  Windows;

  function CreateCompatibleBitmapAndDC(BaseDC: HDC; Width, Height : DWORD; var DC : HDC; var BMP : HBITMAP) : BOOL;
  function CreateCompatibleDIBAndDC_RGB(BaseDC: HDC; BMI : PBITMAPINFO; var DC : HDC; var BMP : HBITMAP; var ImgData : Pointer) : BOOL;
  function CreateCompatibleDIBAndDC_PAL(BaseDC: HDC; BMI : PBITMAPINFO; var DC : HDC; var BMP : HBITMAP; var ImgData : Pointer) : BOOL;
  procedure Fill256ColorPalette_Standard(PaletteBuffer : Pointer);
  procedure Fill256ColorPalette_332RGB(PaletteBuffer : Pointer);
  procedure Fill256ColorPalette_GrayScale(PaletteBuffer : Pointer);

function CreateCompatibleBitmapAndDC(BaseDC: HDC; Width, Height : DWORD; var DC : HDC; var BMP : HBITMAP) : BOOL;
var
  Error : DWORD;
begin
  RESULT := FALSE;
  DC := CreateCompatibleDC(BaseDC);
  if DC = 0 then Exit;

  BMP := CreateCompatibleBitmap(BaseDC, Width, Height);
  if BMP = 0 then begin
     Error := Windows.GetLastError();
     DeleteDC(DC);
     DC := 0;
     Windows.SetLastError(Error);
     Exit;
     end;

  SelectObject(DC, BMP);
  RESULT := TRUE;
end;

function CreateCompatibleDIBAndDC_RGB(BaseDC: HDC; BMI : PBITMAPINFO; var DC : HDC; var BMP : HBITMAP; var ImgData : Pointer) : BOOL;
var
  Error : DWORD;
begin
  RESULT := FALSE;
  DC := CreateCompatibleDC(BaseDC);
  if DC = 0 then Exit;

  BMP := CreateDIBSection(BaseDC, PBitmapInfo(BMI)^, DIB_RGB_COLORS, ImgData, 0, 0);
  if BMP = 0 then begin
     Error := Windows.GetLastError();
     DeleteDC(DC);
     DC := 0;
     ImgData := nil;
     Windows.SetLastError(Error);
     Exit;
     end;

  SelectObject(DC, BMP);
  RESULT := TRUE;
end;

function CreateCompatibleDIBAndDC_PAL(BaseDC: HDC; BMI : PBITMAPINFO; var DC : HDC; var BMP : HBITMAP; var ImgData : Pointer) : BOOL;
var
  Error : DWORD;
begin
  RESULT := FALSE;
  DC := CreateCompatibleDC(BaseDC);
  if DC = 0 then Exit;

  BMP := CreateDIBSection(BaseDC, PBitmapInfo(BMI)^, DIB_PAL_COLORS, ImgData, 0, 0);
  if BMP = 0 then begin
     Error := Windows.GetLastError();
     DeleteDC(DC);
     DC := 0;
     ImgData := nil;
     Windows.SetLastError(Error);
     Exit;
     end;

  SelectObject(DC, BMP);
  RESULT := TRUE;
end;

procedure Fill256ColorPalette_Standard(PaletteBuffer : Pointer);
const
  BASE_PAL : packed array[0..19] of array[0..3] of BYTE
    =(	(	0,	0,	0,	0	),	//0
	(	$80,	0,	0,	0	),	//1
	(	0,	$80,	0,	0	),	//2
	(	$80,	$80,	0,	0	),	//3
	(	0,	0,	$80,	0	),	//4
	(	$80,	0,	$80,	0	),	//5
	(	0,	$80,	$80,	0	),	//6
	(	$C0,	$C0,	$C0,	0	),	//7

	(	192,	220,	192,	0	),	//8
	(	166,	202,	240,	0	),	//9
	(	255,	251,	240,	0	),	//10
	(	160,	160,	164,	0	),	//11

	(	$80,	$80,	$80,	0	),	//12
	(	$FF,	0,	0,	0	),	//13
	(	0,	$FF,	0,	0	),	//14
	(	$FF,	$FF,	0,	0	),	//15
	(	0,	0,	$FF,	0	),	//16
	(	$FF,	0,	$FF,	0	),	//17
	(	0,	$FF,	$FF,	0	),	//18
	(	$FF,	$FF,	$FF,	0	)	//19
	);
var
  R,G,B : BYTE;
  I : DWORD;
  P : PRGBQUAD;
begin
  CopyMemory(PaletteBuffer, @BASE_PAL[0,0], SizeOf(BASE_PAL));

  R := 0;
  G := 0;
  B := 0;
  P := Pointer(DWORD(PaletteBuffer) + SizeOf(BASE_PAL));

  for I:=20 to 255 do begin
      P^.rgbRed		:= R;
      P^.rgbGreen	:= G;
      P^.rgbBlue	:= B;
      P^.rgbReserved	:= 0;
      Inc(P);

      Inc(R, 32);
      if R=0 then begin
	 Inc(G, 32);
	 if G=0 then Inc(B, 64);
	 end;
      end;
end;

procedure Fill256ColorPalette_332RGB(PaletteBuffer : Pointer);
var
  R,G,B : BYTE;
  I : BYTE;
  P : PRGBQUAD;
begin
  P := PaletteBuffer;

  for I:=0 to 255 do begin
      R := I and $E0;
      R := R or (R shr 3) or (R shr 6);
      G := I and $1C;
      G := G or (G shl 3) or (G shr 3);
      B := I and $03;
      B := B or (B shl 2);
      B := B or (B shl 4);
      
      P^.rgbRed		:= R;
      P^.rgbGreen	:= G;
      P^.rgbBlue	:= B;
      P^.rgbReserved	:= 0;
      Inc(P);
      end;
end;

procedure Fill256ColorPalette_GrayScale(PaletteBuffer : Pointer);
var
  I : DWORD;
  P : PRGBQUAD;
begin
  P := PaletteBuffer;

  for I:=0 to 255 do begin
      P^.rgbRed		:= I;
      P^.rgbGreen	:= I;
      P^.rgbBlue	:= I;
      P^.rgbReserved	:= 0;
      Inc(P);
      end;
end;

end.