dibsurf.pas

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

     inherited Destroy;
end;

procedure TDIBSurface.Resize;
begin
      DWordWidth := ((w+3) shr 2)shl 2;
      with BitmapInfo.bmiHeader do
      begin
        biWidth  := w;
        biHeight := h;
      end;
      FSize      := DWordWidth * h;
     if OldBitmap <> 0 then
        SelectObject(Handle, OldBitmap);
     if hDIB <> 0 then
        DeleteObject(hDIB);
     hDIB := CreateDIBSection( Handle,
                               pBitmapInfo(@BitmapInfo)^,
                               DIB_PAL_COLORS,
                               FBits,
                               nil,0);
     OldBitmap := SelectObject(Handle, hDIB);
end;

procedure TDIBsurface.SurfaceToScreen(destDC:hDC);
begin
  SelectPalette(destDC,Palette.Handle,false);
  BitBlt(destDC,0,0,Width,Height,Handle,0,0,SRCCOPY);
end;

procedure TDIBsurface.ScreenToSurface(sourceDC:hDC);
begin
  BitBlt(Handle,0,0,Width,Height,sourceDC,0,0,SRCCOPY);
end;

procedure TDIBsurface.SetPalette(pal:TLogPalette256);
var
   RGBQuads : array[0..255] of TRGBQuad;
   i : integer;
begin
  if OldPalette<>0      then SelectPalette(Handle,OldPalette,false);
  {
  if Palette.Handle<>0  then DeleteObject(DIBhpalette);
  DIBPalette   := palette;
  DIBhpalette  := CreatePalette(PLogPalette(@palette)^);
  }
  if Assigned(Palette) then Palette.Free;
  Palette := TPalette.CreateLogPalette(pal);

//  LogPal_to_RGBQuad(0,255,DIBpalette.palEntry,tempRGBQuads);
  with pal do
  for i:=0 to 255 do
  begin
    RGBQuads[i].rgbRed      := palEntry[i].peRed;
    RGBQuads[i].rgbGreen    := palEntry[i].peGreen;
    RGBQuads[i].rgbBlue     := palEntry[i].peBlue;
    RGBQuads[i].rgbReserved := palEntry[i].peFlags;
  end;

  SetDIBColorTable(Handle,0,256,RGBQuads);
  OldPalette := SelectPalette(Handle,Palette.Handle,false);
end;

(******* Rutinas de Dibujo *******)
procedure TDIBSurface.Clear;
var
   pDWord : pLongInt;
   i   : integer;
begin
     pDWord := FBits;
     for i := 0 to (FSize shr 2)-1 do
     begin
       pLongInt(pDWord)^ := $00000000;
       inc(pDWord);
     end; {for}
end;

procedure TDIBSurface.DrawLine(x1,y1,x2,y2:integer; b:byte);
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,b)
  { case one }
  else
      if dy=0 then
      begin
           DrawHorizontalLine(x1,x2,y1,b);
           exit;
      end
  { case two }
  else
      if dx=0 then
      begin
           DrawVerticalLine(x1,y1,y2,b);
           exit;
      end
  { case three }
  else
      if (abs(dx)>abs(dy)) then
      begin
           if dy>0 then
           begin
                step:= 1;
           end
      else
      begin
           step:=-1;
           dy:=-dy;
      end;
      delta:=dy div 2;
      if dx>=0 then
      begin
           y:=y1;
           for lp1:=x1 to x2 do
           begin
                SetPixel(lp1,y,b);
                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,b); 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
    begin
         step:= 1;
    end
    else
    begin
         step:=-1;
         dx:=-dx;
    end;
    delta:=dx div 2;
    if dy>=0 then
    begin
      x:=x1;
      for lp1:=y1 to y2 do
      begin
        SetPixel(x,lp1,b);
        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,b);
        delta:=delta-dx;
        if delta>dy then
        begin
             x:=x-step;
             delta:=delta-dy;
        end;
      end;
    end;
  end;
end;

procedure TDIBSurface.DrawHorizontalLine(x1,x2,y:integer; b:byte);
var
   lp1,offset : integer;
begin
  offset:=integer(Fbits)+ y*DWordWidth;
  if x2>=x1 then
     for lp1:=offset+x1 to offset+x2 do
         Pbyte(lp1)^ := b
  else
     for lp1:=offset+x2 to offset+x1 do
         Pbyte(lp1)^ := b;
end;

procedure TDIBSurface.DrawVerticalLine(x,y1,y2:integer; b:byte);
var
   lp1,offset : integer;
begin
  if y1<=y2 then
  begin
    offset := integer(FBits)+ y1*DWordWidth + x;
    for lp1:=y1 to y2 do
    begin
         Pbyte(offset)^ := b;
         inc(offset,DWordWidth);
    end;
  end
  else
  begin
    offset := integer(FBits)+ y2*DWordWidth + x;
    for lp1:=y2 to y1 do
    begin
         Pbyte(offset)^ := b;
         inc(offset,DWordWidth);
    end;
  end;
end;

procedure TDIBSurface.FillPolygon(poly:array of TPoint; fillcol:byte);
var
   loop1                   : integer;    { very fast - no floating point            }
   yval,ymax,ymin          : integer;    { standard screen pixel scanline algorithm }
   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);
  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;
    DrawHorizontalLine(xleft,xright,loop1,fillcol);
  end;
end;

(******* Propiedades  *******)
procedure TDIBSurface.SetPixel(x,y:integer; b : byte);
begin
  try
     pByte ( integer(FBits) + y*DWordWidth + x )^ := b;
  except
     on EAccessViolation do ShowMessage(IntToStr(x)+' '+IntToStr(y));
  end;
end;

function  TDIBSurface.ReadPixel(x,y:integer):byte;
begin
  Result := pByte ( integer(FBits) + y*DWordWidth + x )^;
end;

procedure TDIBSurface.SafeSetPixel(x,y:integer; b : byte);
begin
  if (x < Width) and (x>=0) and (y<Height) and (y>=0) then
     pByte ( integer(FBits) + y*DWordWidth + x )^ := b;
end;
function  TDIBSurface.SafeReadPixel(x,y:integer):byte;
begin
  if (x < Width) and (x>=0) and (y<Height) and (y>=0) then
     Result := pByte ( integer(FBits) + y*DWordWidth + x )^
  else
     Result :=0;
end;

procedure TDIBSurface.SetWidth( w : integer);
begin
  Resize(w,Height)
end;
function  TDIBSurface.ReadWidth : integer;
begin
  Result := BitmapInfo.bmiHeader.biWidth;
end;

procedure TDIBSurface.SetHeigth( h : integer);
begin
  Resize(Width,h);
end;
function  TDIBSurface.ReadHeight: integer;
begin
  Result := BitmapInfo.bmiHeader.biHeight;
end;

end.