[Back to DELPHI SWAG index] [Back to Main SWAG index] [Original]

    {
    this is not complete but it may help someone
     - code for 256 colour DIBs

    I've nearly finished a little DIB demo that I'll upload to DSP soon

    John B
    ===================================
    }

    unit DIB_surface_object;

    interface

    uses
      { Borland }
      Windows,Sysutils,Graphics,Classes,
      { Mine }
      Palunit;

    type
      Pshape = ^shape;
      shape  = array[0..0] of Tpoint;

    type
      DIBsurfaceobject = Class(TObject)
        DIBheader    : TMyBitmapInfo;
        DIBPalette   : TMyLogPalette;
        DIBhpalette  : hPalette;
        DIBpalsize   : integer;
        DIBbits      : Pointer;
        DIBhandle    : THandle;
        DIBDC        : hDC;
        Original_BMP : hBitmap;
        Original_PAL : hPalette;
        DIBWidth     : integer;
        DIBHeight    : integer;
        DIBWidth_b   : integer;
        DIBSize      : integer;
        constructor Create(palette:TMyLogPalette; newsize:TPoint);
        destructor  destroy;  override;
        procedure   change_size(newsize:TPoint; force:boolean);
        procedure   change_palette(newpal:shortstring);
        procedure   draw_horizontal_line(x1,x2,y:integer; b:byte);
        procedure   set_pixel(x,y:integer; b:byte);
        procedure   safe_set_pixel(x,y:integer; b:byte);
        procedure   fill_polygon(n:integer; poly:Pshape; fillcol:byte);
        procedure   copy_surface_to_screen(destDC:hDC);
        procedure   copy_screen_to_surface(sourceDC:hDC);
        procedure   clear_surface;
      end;

    implementation

    { ------------------------------------------------------------------------ }
    {                             DIB surface object                           }
    { ------------------------------------------------------------------------ }
    constructor DIBsurfaceobject.Create(palette:TMyLogPalette; newsize:TPoint);
    var lp1 : integer;
    begin
      inherited Create;
      DIBbits      := nil;
      DIBhandle    := 0;
      DIBPalette   := palette;
      DIBhpalette  := CreatePalette(PLogPalette(@palette)^);
      DIBDC        := CreateCompatibleDC(0);
      Original_PAL := SelectPalette(DIBDC,DIBhpalette,false);
      with DIBheader do begin
        with bmiHeader do begin
          biSize          := sizeof(TBITMAPINFOHEADER);
          biWidth         := newsize.x;
          biHeight        := newsize.y;
          biPlanes        := 1;
          biBitCount      := 8;
          biCompression   := BI_RGB;
          biSizeImage     := 0;
          biXPelsPerMeter := 0;
          biYPelsPerMeter := 0;
          biClrUsed       := 0;
          biClrImportant  := 0;
        end;
        for lp1:=0 to 255 do BMIcolors[lp1] := (lp1+0) and 255; { Pal_indices - no offset }
      end;
      Original_BMP := 0;
      DIBWidth     := 0;
      DIBHeight    := 0;
      change_size(newsize,false);
    end;

    destructor DIBsurfaceobject.destroy;
    begin
      if Original_BMP<>0 then SelectObject(DIBDC,Original_BMP);
      if Original_PAL<>0 then SelectPalette(DIBDC,Original_PAL,false);
      if DIBhandle<>0    then DeleteObject(DIBhandle);
      if DIBhpalette<>0  then DeleteObject(DIBhpalette);
      DeleteDC(DIBDC);
      inherited destroy;
    end;

    procedure DIBsurfaceobject.change_size(newsize:TPoint; force:boolean);
    begin
      if (not force) and (newsize.x=DIBWidth) and (newsize.y=DIBHeight) then exit;
      DIBWidth   := newsize.x;
      DIBHeight  := newsize.y;
      DIBWidth_b := ((DIBWidth+3)shr 2)shl 2;
      DIBSize    := DIBWidth_b*DIBHeight;
      if Original_BMP<>0 then SelectObject(DIBDC,Original_BMP);
      if DIBhandle<>0 then DeleteObject(DIBhandle);
      DIBheader.BMIheader.biWidth  := DIBWidth;
      DIBheader.BMIheader.biHeight :=-DIBHeight; { Top down for me please...}
      DIBhandle    := CreateDIBSection(DIBDC,pBitmapInfo(@DIBheader)^,DIB_PAL_COLORS,DIBbits,nil,0);
      Original_BMP := SelectObject(DIBDC,DIBhandle);
    end;

    procedure DIBsurfaceobject.change_palette(newpal:shortstring);
    begin
      SelectPalette(DIBDC,Original_PAL,false);
      create_256_identity_palette_from_file(DIBpalette,DIBhpalette,newpal);
      Original_PAL := SelectPalette(DIBDC,DIBhpalette,false);
      change_size(Point(DIBwidth,DIBheight),true);
    end;

    procedure DIBsurfaceobject.draw_horizontal_line(x1,x2,y:integer; b:byte);
    var lp1,offset : integer;
    begin
      offset:=integer(DIBbits)+ y*DIBWidth_b;
      for lp1:=x1 to x2 do Pbyte( offset+lp1 )^ := b;
    end;

    procedure DIBsurfaceobject.set_pixel(x,y:integer; b:byte);
    begin
      Pbyte( integer(DIBbits) + y*DIBWidth_b + x )^ := b;
    end;

    procedure DIBsurfaceobject.safe_set_pixel(x,y:integer; b:byte);
    begin
      if (x<DIBWidth) and (x>=0) then begin
        if (y<DIBHeight) and (y>=0) then begin
          Pbyte( integer(DIBbits) + y*DIBWidth_b + x )^ := b;
        end;
      end;
    end;

    procedure DIBsurfaceobject.fill_polygon(n:integer; poly:Pshape; fillcol:byte);
    var loop1                   : integer;
        yval,ymax,ymin          : integer;
        yval0,yval1,yval2,yval3 : integer;
        ydifl,ydifr             : integer;
        xval0,xval1,xval2,xval3 : integer;
        xleft,xright            : integer;
        mu                      : integer;
        minvertex               : integer;
        vert0,vert1,vert2,vert3 : integer;
    begin
      ymax:=-99999; ymin:=99999;
      { get top & bottom scan lines to work with }
      for loop1:=0 to n-1 do begin
        yval:=poly^[loop1].y;
        if yval>ymax then ymax:=yval;
        if yval<ymin then begin ymin:=yval; minvertex:=loop1; end;
      end;
      vert0 := minvertex;      vert1 :=(minvertex+1) mod n-1;
      vert2 := minvertex;      vert3 :=(minvertex-1) mod n-1;
      yval0 := poly^[vert0].y; yval1 := poly^[vert1].y;
      yval2 := poly^[vert2].y; yval3 := poly^[vert3].y;
      ydifl := yval1-yval0;    ydifr := yval3-yval2;
      xval0 := poly^[vert0].x; xval1 := poly^[vert1].x;
      xval2 := poly^[vert2].x; xval3 := poly^[vert3].x;

      for loop1:=ymin to ymax do begin

        {intersection on left hand side }
        mu:=(loop1-yval0);
        if mu>ydifl then begin
          vert0:=vert1; vert1:=(vert1+1) mod n-1;
          yval0 := poly^[vert0].y; yval1 := poly^[vert1].y;
          xval0 := poly^[vert0].x; xval1 := poly^[vert1].x;
          ydifl := yval1-yval0;
          mu:=(loop1-yval0)
        end;
        if ydifl<>0 then xleft:=xval0 - (mu*integer(xval0-xval1) div ydifl)
        else             xleft:=xval0;

        {intersection on right hand side }
        if ydifr<>0 then mu:=(loop1-yval2)
        else mu:=ydifr;
        if mu>ydifr then begin
          vert2:=vert3; vert3:=(vert3-1) mod n-1;
          yval2 := poly^[vert2].y; yval3 := poly^[vert3].y;
          xval2 := poly^[vert2].x; xval3 := poly^[vert3].x;
          ydifr := yval3-yval2;
          if ydifr<>0 then mu:=(loop1-yval2)
          else mu:=ydifr;
        end;
        if ydifr<>0 then xright:=xval2 + (mu*integer(xval3-xval2) div ydifr)
        else             xright:=xval2;
        draw_horizontal_line(xleft,xright,loop1,fillcol);
      end;
    end;

    procedure DIBsurfaceobject.copy_surface_to_screen(destDC:hDC);
    begin
      SelectPalette(destDC,DIBhpalette,false);
      BitBlt(destDC,0,0,DIBWidth,DIBHeight,DIBDC,0,0,SRCCOPY);
    end;

    procedure DIBsurfaceobject.copy_screen_to_surface(sourceDC:hDC);
    begin
      BitBlt(DIBDC,0,0,DIBWidth,DIBHeight,sourceDC,0,0,SRCCOPY);
    end;

    procedure DIBsurfaceobject.clear_surface;
    var DWORDptr : Plongint;
        lp1      : integer;
    begin
      for lp1:=0 to DIBheight-1 do
        draw_horizontal_line(0,DIBwidth,lp1,lp1);
      exit;

      DWORDptr:=DIBbits;
      for lp1:=0 to (DIBsize div 4)-1 do begin
        Plongint(DWORDptr)^:=$00000000;
        inc(DWORDptr);
      end;
    end;

    initialization
    end.

[Back to DELPHI SWAG index] [Back to Main SWAG index] [Original]