dibsurf.pas

Delphi Dib usage components. These ise a dib-paintbox... u can use them. :>)

unit DIBSurf; // Version 0.8 Alpha

interface

uses Windows,SysUtils;

type

TBitmapInfoRGB = record
    bmiHeader : TBITMAPINFOHEADER;
    bmiColors : array[0..255] of TRGBQUAD;
end;

TBitmapInfoPal = record
    bmiHeader : TBITMAPINFOHEADER;
    bmiColors : array[0..255] of dword;
end;

TLogPalette256 = record
  palVersion: Word;
  palNumEntries: Word;
  palEntry: array[0..255] of TPaletteEntry;
end;

TPalette = class
private
  FHandle     : HPALETTE;
  OldPal      : HPALETTE;
public
  nColors     : integer;
  LogPalette  : TLogPalette256;
  property Handle : HPALETTE read FHandle;
  procedure LoadFromFile(filename:TFileName);
//  procedure SaveToFile(name : TFileName);
  constructor Create;
  constructor CreateLogPalette(aLogPal : TLogPalette256);
  destructor  Destroy; override;
end;

TDIBSurface = class
private
   BitmapInfo : TBitmapInfoPal;

   FBits      : Pointer;
   FSize      : longint;
   DWordWidth : integer;
   { Handles }
   FHandle     : HDC;
   hDIB       : HBITMAP;
   { Old Handles }
   OldBitmap  : HBITMAP;
   OldPalette : HPALETTE;

protected
   {m閠odos acceso propiedad Pixels[x,y]}
   procedure SetPixel(x,y:integer; b : byte);
   function  ReadPixel(x,y:integer):byte;

   {m閠odos acceso propiedad SafePixels[x,y]}
   procedure SafeSetPixel(x,y:integer; b : byte);
   function  SafeReadPixel(x,y:integer):byte;

   {m閠odos acceso propiedad Width}
   procedure SetWidth( w : integer);
   function  ReadWidth : integer;

   {m閠odos acceso propiedad Heigth}
   function  ReadHeight: integer;
   procedure SetHeigth( h : integer);


public
   Palette    : TPalette;
   constructor Create(aWidth, aHeigth : integer);
   constructor CreateLogPalette(pal:TLogPalette256;aWidth, aHeigth : integer);
   destructor  Destroy; override;
   procedure Resize( w, h : integer);
   procedure SurfaceToScreen(destDC:hDC);
   procedure ScreenToSurface(sourceDC:hDC);
   procedure SetPalette(pal:TLogPalette256);
   //property hPal   : HPALETTE read Palette.Handle;
   property Handle : HDC read FHandle;
   property Width  : integer read ReadWidth  write SetWidth;
   property Height : integer read ReadHeight write SetHeigth;
   property Size   : LongInt read FSize;

   {acceso a pixeles}
   property Bits   : Pointer read FBits;
   property Pixel[x,y : integer] : byte read ReadPixel write SetPixel;
   property SafePixel[x,y : integer] : byte read SafeReadPixel write SafeSetPixel;

   {Rutinas de Dibujo}
   procedure Clear;
   procedure DrawLine(x1,y1,x2,y2:integer; b:byte);
   procedure FillPolygon(poly:array of TPoint; fillcol:byte);
   procedure DrawHorizontalLine(x1,x2,y:integer; b:byte);
   procedure DrawVerticalLine(x,y1,y2:integer; b:byte);

end;

implementation

uses Dialogs;
type
    EDIB = class(Exception);

(******* Tpalette *******)

constructor TPalette.Create; { Uses Default palette }
var
   i  : integer;
   dc : HDC;
begin
     inherited Create;
     dc := GetDC(0);
     try
      //  GetSystemPaletteEntries(dc,0,10,LogPalette.palEntry);
      //  GetSystemPaletteEntries(dc,246,10,LogPalette.palEntry);
        GetSystemPaletteEntries(dc,0,256,LogPalette.palEntry);
     finally
        ReleaseDC(0,DC);
     end;
     {
     for i:= 10 to 245 do
        with LogPalette.palEntry[i] do
        begin
             peRed   := i;
             peGreen := i;
             peBlue  := i;
             peFlags := i;
        end;
     }
     with LogPalette do
     begin
          palVersion    := $300;
          palNumEntries := 256;
     end; {with}
     nColors := 235; {?????????????}
     FHandle := CreatePalette(pLogPalette(@LogPalette)^);
end;

constructor TPalette.CreateLogPalette;
var
   i  : integer;
   dc : HDC;
begin
     inherited Create;
     dc := GetDC(0);
     try
        GetSystemPaletteEntries(dc,0,256,LogPalette.palEntry);
     finally
        ReleaseDC(0,DC);
     end;
     LogPalette := aLogPal;
     with LogPalette do
     begin
          palVersion    := $300;
          palNumEntries := 256;
     end; {with}
     nColors := 235; {?????????????}
     FHandle := CreatePalette(pLogPalette(@aLogPal)^);
end;

destructor  TPalette.Destroy;
begin
     if FHandle<>0 then DeleteObject(FHandle);
     inherited Destroy;
end;

procedure TPalette.LoadFromFile(filename:TFileName);
var
   screen        : hDC;
   pal_cols      : integer;
   lp1,lp2,c1,c2 : Integer;
   f             : text;
   instr,substr  : shortstring;
   r_g_b         : array[1..3] of integer;
begin
  if not FileExists(filename) then
  begin
    raise EDIB.Create('TPalette.LoadFromFile : '#13+FileName+' not found');
    exit;
  end;
  assign(f,filename);
  reset(f);
  readln(f,pal_cols);
  if pal_cols>236 then
     nColors := 236
  else
     nColors := pal_cols;
  with LogPalette do
  begin
      palVersion    := $0300;
      palNumEntries := 256;
      Screen            := GetDC(0);
      try
         GetSystemPaletteEntries(Screen,0  ,10,palEntry);
         GetSystemPaletteEntries(Screen,246,10,palEntry[246]);
      finally
         ReleaseDC(0,Screen);
      end;

      for lp1:=0 to nColors-1 do
      begin
        readln(f,instr); c1:=1;
        for lp2:=1 to 3 do
        begin
          c2:=1;
          while (instr[c1]=' ') do
                inc(c1);
          while (instr[c1]<>' ') and (c1<=length(instr)) do
          begin
            substr[c2]:=instr[c1];
            inc(c1); inc(c2);
          end;
          substr[0]:=chr(c2-1);
          val(substr,r_g_b[lp2],c2);
        end;
        palEntry[10+lp1].peFlags := pc_Reserved;
        palEntry[10+lp1].peRed   := r_g_b[1];
        palEntry[10+lp1].peGreen := r_g_b[2];
        palEntry[10+lp1].peBlue  := r_g_b[3];
      end;

      if (nColors-1)<235 then
         for lp1:=nColors to 235 do
         begin
             palEntry[10+lp1].peFlags := pc_Reserved;
             palEntry[10+lp1].peRed   := palEntry[10+lp1-nColors].peRed;
             palEntry[10+lp1].peGreen := palEntry[10+lp1-nColors].peGreen;
             palEntry[10+lp1].peBlue  := palEntry[10+lp1-nColors].peBlue;
         end;
  end;
  if (FHandle<>0) then
     DeleteObject(FHandle);
  FHandle := CreatePalette(PLogPalette(@LogPalette)^);
  close(f);
end;

(******* DIBSurface *******)

constructor TDIBSurface.Create;
var
   i : integer;
begin
     inherited Create;
     FBits   := nil;
     FHandle := CreateCompatibleDC(0);
     Palette := TPalette.Create; {podr韆 haber por defecto?}
     OldPalette := SelectPalette(Handle,Palette.Handle,false);
     with BitmapInfo do
     begin
          with bmiHeader do
          begin
               biSize     := SizeOf(TBitmapInfoHeader);
               biPlanes   := 1;
               biBitCount := 8;
               biCompression := BI_RGB;
               biWidth  := AWidth;
               biHeight := AHeigth;
               biSizeImage     := 0;
               biXPelsPerMeter := 0;
               biYPelsPerMeter := 0;
               biClrUsed       := 0;
               biClrImportant  := 0;
          end; {with}
          {
          for i := 0 to 255 do
          begin
            bmiColors[i] := (i+0) and $FF;
          end;} {for}
     end;
     OldBitmap  := 0;
//     Resize(aWidth, aHeigth);
     DWordWidth := ((aWidth+3) shr 2)shl 2;
     FSize      := DWordWidth * AHeigth;
     hDIB := CreateDIBSection( Handle,
                               pBitmapInfo(@BitmapInfo)^,
                               DIB_PAL_COLORS,
                               FBits,
                               nil,0);
     OldBitmap := SelectObject(Handle, hDIB);
end;

constructor TDIBSurface.CreateLogPalette(pal:TLogPalette256;aWidth, aHeigth : integer);
var
   i : integer;
begin
     inherited Create;
     FBits      := nil;
     FHandle     := 0;
     Palette    := TPalette.CreateLogPalette(pal); {podr韆 haber por defecto?}

     FHandle     := CreateCompatibleDC(0);
     OldPalette := SelectPalette(Handle,Palette.Handle,false);
     with BitmapInfo do
     begin
          with bmiHeader do
          begin
               biSize     := SizeOf(TBitmapInfoHeader);
               biPlanes   := 1;
               biBitCount := 8;
               biCompression := BI_RGB;
               biWidth  := AWidth;
               biHeight := AHeigth;
               biSizeImage     := 0;
               biXPelsPerMeter := 0;
               biYPelsPerMeter := 0;
               biClrUsed       := 0;
               biClrImportant  := 0;
          end; {with}
          {
          for i := 0 to 255 do
          begin
            bmiColors[i] := (i+0) and $FF;
          end;} {for}
     end;
     OldBitmap  := 0;
//     Resize(aWidth, aHeigth);
     DWordWidth := ((aWidth+3) shr 2)shl 2;
     FSize      := DWordWidth * AHeigth;
     hDIB := CreateDIBSection( Handle,
                               pBitmapInfo(@BitmapInfo)^,
                               DIB_PAL_COLORS,
                               FBits,
                               nil,0);
     OldBitmap := SelectObject(Handle, hDIB);
end;

destructor TDIBSurface.Destroy;
begin
     if OldBitmap <> 0 then
        SelectObject(Handle, OLdBitmap);
     if OldPalette <> 0 then
        SelectObject(Handle, OldPalette);
     if hDIB <> 0 then
        DeleteObject(hDIB);
     Palette.Free;
     DeleteDC(Handle);