unidib.pas

(Delphi) Universal dib codes. Usign DIB palettes, dib bitmaps and more

  Result:=(Z AND $7C00 SHL 6) OR (Z AND $3E0 SHL 3) OR (Z AND $001E SHL 1) OR (Z AND $8000 SHR 1);
  FActPointer:=Pointer(Integer(FActPointer)+2);
end;

procedure TUniDIB.SetSeqPixel24 (Value:Integer);
begin
  pByte(FActPointer)^:=Value AND $FF;
  pByte(Integer(FActPointer)+1)^:=Value SHR 8 AND $FF;
  pByte(integer(FActPointer)+2)^:=Value SHR 16 AND $FF;
  FActPointer:=Pointer(Integer(FActPointer)+3);
end;

function TUniDIB.GetSeqPixel24:Integer;
begin
  Result:=pByte(FActPointer)^ OR (pByte(integer(FActPointer)+1)^ SHL 8) OR (pByte(integer(FActPointer)+2)^ shl 16);
  FActPointer:=Pointer(Integer(FActPointer)+3);
end;

procedure TUniDIB.SetSeqPixel32 (Value:Integer);
begin
  pInteger(FActPointer)^:=Value;
  FActPointer:=Pointer (Integer(FActPointer)+4);
end;

function TUniDIB.GetSeqPixel32 :Integer;
begin
  Result:=pInteger(FActPointer)^;
  FActPointer:=Pointer (Integer(FActPointer)+4);
end;

procedure TUniDIB.Seek (X,Y:Integer);
begin
  XActX:=X;
  FActPointer:=Pointer(Integer(FBits)+Y*FDWordWidth+X*(FBMInfo.bmiHeader.biBitCount shr 3));
end;

constructor TUniDIB.Create (AWidth,AHeight:LongInt;ABPP:Byte;SByteUse:Byte);
var A:Integer;
begin
  inherited Create;
  FDC := CreateCompatibleDC(0);
  with FBMInfo.bmiHeader do
  begin
    biSize:=SizeOf(TBitmapInfoHeader);
    biPlanes:=1;
    A:=1;
    while (A<C_MaxAllowedBPP) AND (ABPP>C_AllowedBPP[A]) do
      Inc (A);
    biBitCount:=C_AllowedBPP[A];
    biCompression:=BI_RGB;
    If AWidth<=0 then
      biWidth:=1
    else
      biWidth:=AWidth;
    If AHeight=0 then
      biHeight:=1
    else
      biHeight:=AHeight;
    biSizeImage:=0;
    biXPelsPerMeter:=0;
    biYPelsPerMeter:=0;
    biClrUsed:=0;
    biClrImportant:=0;
  end;

  If ABPP<=8 then
  begin
    XClrCount:=1 shl FBMInfo.bmiHeader.biBitCount;
      {=> XClrCount:=2^FBMInfo.bmiHeader.biBitCount;}
    XUsage:=DIB_PAL_COLORS;
  end
  else
    XUsage:=DIB_RGB_COLORS;

  FDWordWidth:=((AWidth*FBMInfo.bmiHeader.biBitCount+31) shr 5)shl 2;
  FHandle := CreateDIBSection(FDC,pBitmapInfo(@FBMInfo)^,
     XUsage,FBits,0,0);
  Case FBMInfo.bmiHeader.biBitCount of
    1:begin
        SetPixel:=SetPixel1;
        GetPixel:=GetPixel1;
        SetSeqPixel:=SetSeqPixel1;
        GetSeqPixel:=GetSeqPixel1;
      end;
    4:begin
        SetPixel:=SetPixel4;
        GetPixel:=GetPixel4;
        SetSeqPixel:=SetSeqPixel4;
        GetSeqPixel:=GetSeqPixel4;
      end;
    8:begin
        SetPixel:=SetPixel8;
        GetPixel:=GetPixel8;
        SetSeqPixel:=SetSeqPixel8;
        GetSeqPixel:=GetSeqPixel8;
      end;
    16:begin
         Case SByteUse of
           SBU_NONE:begin
               SetPixel:=SetPixel16;
               GetPixel:=GetPixel16;
               SetSeqPixel:=SetSeqPixel16;
               GetSeqPixel:=GetSeqPixel16;
             end;
           SBU_RED:begin
               SetPixel:=SetPixel16R;
               GetPixel:=GetPixel16R;
               SetSeqPixel:=SetSeqPixel16R;
               GetSeqPixel:=GetSeqPixel16R;
             end;
           SBU_GREEN:begin
               SetPixel:=SetPixel16G;
               GetPixel:=GetPixel16G;
               SetSeqPixel:=SetSeqPixel16G;
               GetSeqPixel:=GetSeqPixel16G;
             end;
           SBU_BLUE:begin
               SetPixel:=SetPixel16B;
               GetPixel:=GetPixel16B;
               SetSeqPixel:=SetSeqPixel16B;
               GetSeqPixel:=GetSeqPixel16B;
             end;
        end;
      end;
    24:begin
         SetPixel:=SetPixel24;
         GetPixel:=GetPixel24;
         SetSeqPixel:=SetSeqPixel24;
         GetSeqPixel:=GetSeqPixel24;
      end;
    32:begin
         SetPixel:=SetPixel32;
         GetPixel:=GetPixel32;
         SetSeqPixel:=SetSeqPixel32;
         GetSeqPixel:=GetSeqPixel32;
      end;
  end;
  SelectObject(FDC, FHandle);
end;

destructor TUniDIB.Destroy;
begin
  DeleteDC (FDC);
  DeleteObject (FHandle);  
  inherited Destroy;
end;

procedure TUniDIB.DIBtoScreen(DC:hDC);
var Pal:HPalette;
begin
  If XUsage=DIB_PAL_COLORS then
  begin
    Pal:=SelectPalette(DC,FPalHandle,False);
    If Pal<>0 then
      DeleteObject (Pal);
    RealizePalette (DC);
  end;
  BitBlt(DC,0,0,FBMInfo.bmiHeader.biWidth,Abs(FBMInfo.bmiHeader.biHeight),FDC,0,0,SRCCOPY);
end;

procedure TUniDIB.Clear;
var
   pDWord : pLongInt;
   i   : integer;
begin
  pDWord := FBits;
  for i := 1 to FDWordWidth*Abs(FBMInfo.bmiHeader.biHeight) shr 2 do
  begin
    pLongInt(pDWord)^ := $00000000;
    inc(pDWord); {!! pDWord:=pDWord+ 4 }
                                   {===}
  end;
end;

procedure TUniDIB.DrawHorizLine(X1,X2,Y:Integer; Col:Integer);
var X,T:Integer;
    P:Pointer;
begin
  If X2>X1 then
  begin
    X:=X1;
    X1:=X2;
    X2:=X;
  end;
  T:=XActX;
  P:=FActPointer;
  Seek (X1,Y);
  For X:=X1 to X2 do
    SetSeqPixel (Col);
  XActX:=T;
  FActPointer:=P;
end;

procedure TUniDIB.DrawVertLine (X,Y1,Y2,Col:Integer);
var Y:Integer;
begin
  If Y1>Y2 then
  begin
    Y:=Y1;
    Y1:=Y2;
    Y2:=Y;
  end;
  For Y:=Y1 to Y2 do
    SetPixel (X,Y,Col);
end;

procedure TUniDIB.DrawLine(x1,y1,x2,y2:integer; Col:Integer);
var
   lp1              : integer;
   x,y              : integer;
   dy,dx,step,delta : integer;
begin
  dx:=x2-x1;
  dy:=y2-y1;
  { case nought }
  if (dy=0) and (dx=0) then
     SetPixel(x1,y1,Col)
  { case one }
  else
    if dy=0 then
    begin
      DrawHorizLine(x1,x2,y1,Col);
      exit;
    end
    { case two }
    else
      if dx=0 then
      begin
        DrawVertLine(x1,y1,y2,Col);
        exit;
      end
      { case three }
      else
        if (abs(dx)>abs(dy)) then
        begin
          if dy>0 then
            step:= 1
          else
          begin
            step:=-1;
            dy:=-dy;
          end;
          delta:=dy shr 1;
          if dx>=0 then
          begin
            y:=y1;
            for lp1:=x1 to x2 do
            begin
              SetPixel(lp1,y,Col);
              delta:=delta+dy;
              if delta>dx then
              begin
                y:=y+step;
                delta:=delta-dx;
              end;
            end;
          end
          else
          begin { dx<0 }
            y:=y2;
            dx:=-dx;
            dy:=-dy;
            for lp1:=x2 to x1 do
            begin
              SetPixel(lp1,y,Col); delta:=delta-dy;
              if delta>dx then
              begin
                y:=y-step;
                delta:=delta-dx;
              end;
            end;
          end;
        end
        else
        begin  { dy>dx }
          if dx>0 then
            step:= 1
          else
          begin
            step:=-1;
            dx:=-dx;
          end;
          delta:=dx shr 1;
          if dy>=0 then
          begin
            x:=x1;
            for lp1:=y1 to y2 do
            begin
              SetPixel(x,lp1,Col);
              delta:=delta+dx;
              if delta>dy then
              begin
                x:=x+step;
                delta:=delta-dy;
              end;
            end;
          end
          else
          begin { dy<0 }
            x:=x2;
            dy:=-dy;
            dx:=-dx;
            for lp1:=y2 to y1 do
            begin
              SetPixel(x,lp1,Col);
              delta:=delta-dx;
              if delta>dy then
              begin
                x:=x-step;
                delta:=delta-dy;
              end;
            end;
          end;
        end;
end;

procedure TUniDIB.SetPalette(Pal:TLogPalette256);
var A:Byte;
    Colors:Array [0..255] of TRGBQuad;
begin
  If XUsage<>DIB_PAL_COLORS then
    Exit;
  For A:=0 to XClrCount-1 do
  begin
    Colors[A].rgbRed:=Pal.palEntry[A].peRed;
    Colors[A].rgbGreen:=Pal.palEntry[A].peGreen;
    Colors[A].rgbBlue:=Pal.palEntry[A].peBlue;
    Colors[A].rgbReserved:=Pal.palEntry[A].peFlags;
  end;
  Pal.palVersion:=$300;
  Pal.palNumEntries:=XClrCount;
  SelectPalette (FDC,XSelPalette,false);
  DeleteObject (FPalHandle);
  FPalHandle:=CreatePalette(PLogPalette(@Pal)^);
  SetDIBColorTable(FDC,0,XClrCount,Colors);
  XSelPalette:=SelectPalette (FDC,FPalHandle,False);
end;

procedure TUniDIB.FillPolygon(poly:array of TPoint; fillcol:Integer);
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;
   n                       : integer; {number of points}
begin
  ymax:=-999999; ymin:=999999;
  { get top & bottom scan lines to work with }
  n := High(poly);
  minvertex:=0;
  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;
  vert2 := minvertex;      vert3 :=(minvertex-1) mod n;
  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;
      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;
      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;
    DrawHorizLine(xleft,xright,loop1,fillcol);
  end;
end;

procedure TUniDIB.CaptureScreen;
var DC:HDC;
    A,B:Integer;
{    LP:TLogPalette256;}
begin
  DC:=GetDC(0);
  A:=FBMInfo.bmiHeader.biWidth;
  If GetDeviceCaps (DC,HORZRES)<A then
    A:=GetDeviceCaps (DC,HORZRES);
  B:=Abs(FBMInfo.bmiHeader.biHeight);
  If GetDeviceCaps (DC,VERTRES)<B then
    B:=GetDeviceCaps (DC,VERTRES);
  BitBlt(FDC,0,0,A,B,DC,0,0,SRCCOPY);
{  If GetDeviceCaps (DC,RASTERCAPS) AND RC_PALETTE>0 then
  begin
    A:=GetDeviceCaps (DC,NUMCOLORS);
    GetPaletteEntries (,0,A,LP.PalEntry);
    SetPalette (LP);
  end;}
  ReleaseDC(0,DC);
end;

end.