unit dibutils;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  OleCtrls, GR32;

type
  PBYTE = ^Byte;

  //Retorna el ancho de un dib
  function DibWidth(dibSrc : HGlobal) : integer;
  //Retorna el Alto de un Dib
  function DibHeight(dibSrc : HGlobal) : integer;
  //Duplica una porción de memoria
  //Recibe: El handle de esa memoria
  //Devuelve: El handle de la memoria duplicada
  //Atención: El usuario de esta función es el responsable
  //de liberar la memoria, usando la función GlobalFree
  function GlobalDuplicate(HSrc : HGlobal) : HGlobal;

  //copia memoria, sz es la cantidad de bytes a copiar
  //desde src a dst.
  procedure memcpy(src : pByte; dst : pByte; sz : integer );

  //superpone una imagen de menor tamaño sobre otra de mayor tamaño
  //en forma multiplicativa
  procedure SuperponerDibs(src,dst : PBITMAPINFOHEADER; cx,cy : integer);

  //Retorna por variable las dimensiones de un dib
  procedure DibExtents(dib : HGlobal; var w : integer;  var h : integer);

  //copia a un nuevo dib el área comprendida en x1,y1,x2,y2 de aDib.
  function CopyDibArea(aDib : HGlobal; x1, y1, x2, y2 : integer) : HGlobal;

  //Reduce un dib por el factor indicado. Retorna el nuevo dib
  function ReduceDib( aDib : HGLOBAL; factor : double) : HGLOBAL; overload;

  //Salva el dib, como bmp
  //Retorna true si esta todo Ok.
  function SaveDib( aDib : HGLOBAL; aStream : TStream ) : boolean; overload;
  function SaveDib( aDib : HGLOBAL; FileName : string ) : boolean; overload;
  function LoadDib( FileName : string ) : PBITMAPINFOHEADER; overload;
  function LoadDib( aStream : TStream ) : PBITMAPINFOHEADER; overload;
  function GetFileSize(arch: string): LongInt;
  function IsPaletteOK( FileName : string ) : boolean;
  // Convierte un Raw en HDib
  function RawToBmp(RawPtr: Pointer; Width, Height: Integer ) : HGlobal;
  procedure RawToBmpStream(RawPtr: Pointer; Width, Height: Integer;
    Stream : TStream );
  procedure RawToBmpFile(RawPtr: Pointer; Width, Height: Integer;
    FileName : string );
  procedure Bitmap32ToRaw(RedPtr, GreenPtr, BluePtr: PByte; Bitmap32: TBitmap32);
  //Crea un bitmap grayscale del tamaño dado
  function CreateBitmap( Width, Height: Integer ) : HGlobal;
  procedure SaveFicha(output_filename : string; base_filename : string);
  function RawToTBitmap(RawPtr: Pointer; Width, Height: Integer ) : TBitmap;
  function RawToTBitmap24(RedPtr, GreenPtr, BluePtr: Pointer; Width, Height: Integer ) : TBitmap;
  function CreateGrayTBitmap(Width, Height : Integer) : TBitmap;
  function HDibToTBitmap(const hDIB:  THandle):  TBitmap;

implementation

  //copia memoria, sz es la cantidad de bytes a copiar
  //desde src a dst.
  procedure memcpy(src : pByte; dst : pByte; sz : integer );
  var
    i : integer;
  begin
    for i := 0 to sz-1 do
      pByte(integer(dst)+i)^ := pByte(integer(src)+i)^;
  end;
  function mult4(x : integer) : integer;
  begin
    result := ((x+3) and ( not 3) );
  end;


  //Duplica una porción de memoria
  //Recibe: El handle de esa memoria
  //Devuelve: El handle de la memoria duplicada
  //Atención: El usuario de esta función es el responsable
  //de liberar la memoria, usando la función GlobalFree
  function GlobalDuplicate(HSrc : HGlobal) : HGlobal;
  var
    hDst : HGlobal;
    ptrDst, ptrSrc : pByte;
    i : integer;
    size : integer;
  begin
    size := GlobalSize(HSrc);
  {Aloca la memoria del mismo tamaño que el dib recibido}
    hDst := GlobalAlloc(GMEM_MOVEABLE, size);
  {Copia la información}
    ptrDst := GlobalLock(hDst);
    ptrSrc := GlobalLock(HSrc);
    for i := 0 to size-1 do
      pByte(integer(ptrDst)+i)^ := pByte(integer(ptrSrc)+i)^;
    GlobalUnlock(hDst);
    GlobalUnlock(HSrc);
  {retorna el nuevo HGlobal}
    result := hDst;
  end;

procedure SuperponerDibs(src,dst : PBITMAPINFOHEADER; cx,cy : integer);
var
  v,u,z           : byte;
  srclw,dstlw     : longint;
  srcbits,dstbits : longint;
  mx,my,x,y,w,h   : longint;
  zz              : real;
begin
  srclw := mult4(src^.biWidth);
  dstlw := mult4(dst^.biWidth);
  srcbits := longint(src) + sizeof(BITMAPINFOHEADER) + sizeof(RGBQUAD)*256;
  dstbits := longint(dst) + sizeof(BITMAPINFOHEADER) + sizeof(RGBQUAD)*256;
  w := src^.biWidth;
  h := src^.biHeight;

  mx := w div 2;
  my := h div 2;
  for x := 0 to w - 1 do
    for y := 0 to h - 1 do
    if ( x+cx-mx >= 0 ) and ( x+cx-mx < dst^.biWidth  ) and
       ( y+cy-my >= 0 ) and ( y+cy-my < dst^.biHeight ) and
       ( x       >= 0 ) and ( x       < src^.biWidth  ) and
       ( y       >= 0 ) and ( y       < src^.biHeight ) then
    begin
      v := (PBYTE( srcbits +    (y)          *  srclw  +  (x)          ))^; //gp(src, x-cx+mx, y-cy+my)
      u := (PBYTE( dstbits +    (y+cy-my)    *  dstlw  +  (x+cx-mx)    ))^; //gp(dst, x, y)
      zz := (v/255)*(u/255);
      zz := zz*255;
      if (zz > 255) then z := 255 else z := byte(round(zz));
      (PBYTE( dstbits +    (y+cy-my)    *  dstlw  +  (x+cx-mx)    ))^ := z;
    end;
end;

function CopyDibArea(aDib : HGlobal; x1, y1, x2, y2 : integer) : HGlobal;
var
  pDib,pNewDib : PBITMAPINFO;
  newDibSize,newDibWidth,newDibHeight : integer;
  dibWidth,dibHeight : integer;
  newDib : HGLOBAL;
  i,x,y : integer;
  pDibLineWidth : integer;
  newDibLineWidth : integer;
  pSrc,pDst : longint;
  ps,pd : Pbyte;
begin
  pDib := PBITMAPINFO(GlobalLock(aDib));
  dibWidth := pDib^.bmiHeader.biWidth;
  dibHeight := pDib^.bmiHeader.biHeight;
  pDibLineWidth := mult4(dibWidth);

 //Chequeos
  Result := 0;
  if (x1 >= x2) or (y1 >= y2) then exit;
  if (x1 < 0 ) or (y1<0) then exit;
  if (x2 >= dibWidth ) or ( y2 >= dibHeight ) then exit;

  newDibWidth := x2-x1;
  newDibHeight := y2-y1;
  newDibLineWidth := mult4(newDibWidth);

  newDibSize := sizeof(BITMAPINFOHEADER) + sizeof(RGBQUAD)*256 +
                newDibLineWidth*newDibHeight;
  newDib := GlobalAlloc(GMEM_MOVEABLE, newDibSize);
  pNewDib := GlobalLock(newDib);
  //Llena la estructura
  pNewDib^.bmiHeader.biSize := sizeof(BITMAPINFOHEADER);
  pNewDib^.bmiHeader.biWidth := newDibWidth;
  pNewDib^.bmiHeader.biHeight := newDibHeight;
  pNewDib^.bmiHeader.biPlanes := 1;
  pNewDib^.bmiHeader.biBitCount := 8;
  pNewDib^.bmiHeader.biCompression := BI_RGB;
  pNewDib^.bmiHeader.biSizeImage := newDibLineWidth*newDibHeight;
  pNewDib^.bmiHeader.biXPelsPerMeter := pDib^.bmiHeader.biXPelsPerMeter;
  pNewDib^.bmiHeader.biYPelsPerMeter := pDib^.bmiHeader.biYPelsPerMeter;
  pNewDib^.bmiHeader.biClrUsed := 256;
  pNewDib^.bmiHeader.biClrImportant := 0;
  //ahora llena la paleta
  for i := 0 to 255 do begin
    pNewDib^.bmiColors[i].rgbBlue := pDib^.bmiColors[i].rgbBlue;
    pNewDib^.bmiColors[i].rgbGreen := pDib^.bmiColors[i].rgbGreen;
    pNewDib^.bmiColors[i].rgbRed := pDib^.bmiColors[i].rgbRed;
    pNewDib^.bmiColors[i].rgbReserved := i;
  end;
  //ahora copia los pixels
  pSrc := longint(pDib);
  pDst := longint(pNewDib);
  for x := 0 to newDibWidth -1 do for y := 0 to newDibHeight -1 do begin
     ps := pByte(pSrc + sizeof(BITMAPINFOHEADER) + 256*sizeof(RGBQUAD) +
                        (y+y1)*pDibLineWidth + x + x1 ) ;
     pd := pByte(pDst + sizeof(BITMAPINFOHEADER) + 256*sizeof(RGBQUAD) + y*newDibLineWidth + x );
     pd^ := ps^;
  end;
  GlobalUnlock(newDib);
  GlobalUnlock(aDib);
  result := newDib;
end;

function ReduceDib( aDib : HGLOBAL; factor : double) : HGLOBAL;
var
  pDib,pNewDib : PBITMAPINFO;
  newDibSize,newDibWidth,newDibHeight : integer;
  dibWidth,dibHeight : integer;
  newDib : HGLOBAL;
  i,x,y : integer;
  pDibLineWidth : integer;
  pSrc,pDst : longint;
  ps,pd : Pbyte;
begin
  pDib := PBITMAPINFO(GlobalLock(aDib));
  dibWidth := pDib^.bmiHeader.biWidth;
  dibHeight := pDib^.bmiHeader.biHeight;
  pDibLineWidth := mult4(dibWidth);
  newDibWidth := mult4(round(dibWidth / factor));
  newDibHeight := round(dibHeight / factor);

  newDibSize := sizeof(BITMAPINFOHEADER) + sizeof(RGBQUAD)*256 +
                newDibWidth*newDibHeight;
  newDib := GlobalAlloc(GMEM_MOVEABLE, newDibSize);
  pNewDib := GlobalLock(newDib);
  //Llena la estructura
  pNewDib^.bmiHeader.biSize := sizeof(BITMAPINFOHEADER);
  pNewDib^.bmiHeader.biWidth := newDibWidth;
  pNewDib^.bmiHeader.biHeight := newDibHeight;
  pNewDib^.bmiHeader.biPlanes := 1;
  pNewDib^.bmiHeader.biBitCount := 8;
  pNewDib^.bmiHeader.biCompression := BI_RGB;
  pNewDib^.bmiHeader.biSizeImage := newDibWidth*newDibHeight;
  pNewDib^.bmiHeader.biXPelsPerMeter := pDib^.bmiHeader.biXPelsPerMeter;
  pNewDib^.bmiHeader.biYPelsPerMeter := pDib^.bmiHeader.biYPelsPerMeter;
  pNewDib^.bmiHeader.biClrUsed := 256;
  pNewDib^.bmiHeader.biClrImportant := 0;
  //ahora llena la paleta
  for i := 0 to 255 do begin
    pNewDib^.bmiColors[i].rgbBlue := pDib^.bmiColors[i].rgbBlue;
    pNewDib^.bmiColors[i].rgbGreen := pDib^.bmiColors[i].rgbGreen;
    pNewDib^.bmiColors[i].rgbRed := pDib^.bmiColors[i].rgbRed;
    pNewDib^.bmiColors[i].rgbReserved := i;
  end;
  //ahora copia los pixels
  pSrc := longint(pDib);
  pDst := longint(pNewDib);
  for x := 0 to newDibWidth -1 do for y := 0 to newDibHeight -1 do begin
     ps := pByte(pSrc + sizeof(BITMAPINFOHEADER) + 256*sizeof(RGBQUAD) +
                        round(y*factor)*pDibLineWidth + round(x*factor) );
     pd := pByte(pDst + sizeof(BITMAPINFOHEADER) + 256*sizeof(RGBQUAD) + y*newDibWidth + x);
     pd^ := ps^;
  end;
  GlobalUnlock(newDib);
  GlobalUnlock(aDib);
  result := newDib;
end;

function SaveDib( aDib : HGLOBAL; aStream : TStream ) : boolean;
var
    bmFH : BITMAPFILEHEADER ;
    pDib : PBITMAPINFOHEADER;
    size : DWORD;
begin
  result := true;
  size := GlobalSize(aDib);
  bmFH.bfType := ord('B') + (ord('M') shl 8);
  bmFH.bfSize := sizeof(BITMAPFILEHEADER) + GlobalSize(aDib);
  bmFH.bfReserved1 := 0;
  bmFH.bfReserved2 := 0;
  bmFH.bfOffBits := sizeof(BITMAPFILEHEADER) + sizeof(BITMAPINFOHEADER) + 256*sizeof(RGBQUAD);
  aStream.Write(bmFH,sizeof(BITMAPFILEHEADER));
  pDib := PBITMAPINFOHEADER(GlobalLock(aDib));
  if ( aStream.Write(pDib^,size) <> size ) then
       Result := false;
  GlobalUnlock(aDib);
end;

function SaveDib( aDib : HGLOBAL; FileName : string ) : boolean;
var
    bmFH : BITMAPFILEHEADER ;
    pDib : PBITMAPINFOHEADER;
    size : DWORD;
    aStream : TFileStream;
begin
  aStream := TFileStream.Create(FileName,fmCreate);
  DeleteFile(FileName);
  SaveDib(aDib, aStream);
  aStream.Free;
end;

procedure DibExtents(dib : HGlobal; var w : integer;  var h : integer);
var
  p : PBITMAPINFOHEADER;
begin
  p := GlobalLock(dib);
  w := p^.biWidth;
  h := p^.biHeight;
  GlobalUnlock(dib);
end;

function GetDibSizeFrom_BMPFile( aStream : TStream ) : longint; overload;
var
  bmih : BITMAPINFOHEADER;
  bmfh : BITMAPFILEHEADER;
begin
  Result := 0;
  aStream.Seek( 0, soFromBeginning );
  if Assigned(aStream) then begin
     if aStream.Read( bmfh, sizeof(bmfh) ) < sizeof(bmfh) then
        raise Exception.Create('Invalid file format');
     if aStream.Read( bmih, sizeof(bmih) ) < sizeof(bmih) then
        raise Exception.Create('Invalid file format');
     Result := sizeof( BITMAPINFOHEADER ) + 256*sizeof( RGBQUAD )
       + Mult4(bmih.biWidth) * bmih.biHeight;
  end;
end;

function GetDibSizeFrom_BMPFile( FileName : string ) : longint; overload;
var
  aStream : TFileStream;
begin
  Result := 0;
  if fileExists(FileName) then begin
     aStream := TFileStream.Create( FileName, fmOpenRead or fmShareDenyNone );
     Result := GetDibSizeFrom_BMPFile( aStream );
     aStream.Free;
  end;
end;

function LoadDib( aStream : TStream ) : PBITMAPINFOHEADER;
var
  bmFH : BITMAPFILEHEADER ;
  pDib : PBITMAPINFOHEADER;
  dibSize  : DWORD;
begin
  Result := 0;
  dibSize := GetDibSizeFrom_BMPFile( aStream );
  if dibSize = 0 then raise Exception.Create('Invalid file format');
  aStream.Seek( 0, soFromBeginning );
  if aStream.Read( bmFH, sizeof(bmFH) ) < sizeof( bmFH ) then
     raise Exception.Create('Invalid file format');
  pDib := PBITMAPINFOHEADER( GlobalAlloc( GPTR, dibSize ) );
  if pDib = nil then raise Exception.Create('Invalid file format');
  if aStream.Read( pDib^, dibSize ) < dibSize then begin
     GlobalFree( Cardinal(pDib) );
     raise Exception.Create('Invalid file format');
  end;
  Result := pDib;
end;

function LoadDib( FileName : string ) : PBITMAPINFOHEADER;
var
    bmFH : BITMAPFILEHEADER ;
    pDib : PBITMAPINFOHEADER;
    dibSize  : DWORD;
    aStream : TFileStream;
begin
  Result := 0;
  dibSize := GetDibSizeFrom_BMPFile( FileName );
  if dibSize = 0 then exit;
  aStream := TFileStream.Create( FileName, fmOpenRead );
  if aStream.Read( bmFH, sizeof(bmFH) ) < sizeof( bmFH ) then begin
     aStream.Free;
     exit;
  end;
  pDib := PBITMAPINFOHEADER( GlobalAlloc( GPTR, dibSize ) );
  if pDib = nil then begin
     aStream.Free;
     exit;
  end;
  if aStream.Read( pDib^, dibSize ) < dibSize then begin
     aStream.Free;
     GlobalFree( Cardinal(pDib) );
     exit;
  end;
  Result := pDib;
  aStream.Free;
end;

// Devuelve el tamaño de un archivo
function GetFileSize(arch: string): LongInt;
var
   f: file;
begin
   Result:= 0;
   if FileExists(arch) then begin
      {$I-} // Desactiva el chequeo de I/O
      try
         AssignFile(f, arch);
         Reset(f, 1);
         Result:= FileSize(f);
      finally
         CloseFile(f);
      end;
      {$I+} // Vuelve a activar el chequeo de I/O
   end;
end;

function IsPaletteOK( FileName : string ) : boolean;
var
  bmih : BITMAPINFOHEADER;
  bmfh : BITMAPFILEHEADER;
  pal  : array[0..255] of RGBQUAD;
  aStream : TFileStream;
  i : integer;
begin
  Result := false;
  if fileExists(FileName) then begin
     aStream := TFileStream.Create( FileName, fmOpenRead or fmShareDenyNone );
     if aStream.Read( bmfh, sizeof(bmfh) ) < sizeof(bmfh) then begin
        aStream.Free;
        exit;
     end;
     if aStream.Read( bmih, sizeof(bmih) ) < sizeof(bmih) then begin
        aStream.Free;
        exit;
     end;
     if aStream.Read(pal, sizeof(pal) ) < sizeof(pal) then begin
        aStream.Free;
        exit;
     end;
     for i := 0 to 255 do
       if ( pal[i].rgbBlue <> i ) or 
          ( pal[i].rgbGreen <> i ) or
          ( pal[i].rgbRed <> i ) then begin
          aStream.Free;
          exit;
       end;
  end;
  result := true;
end;

function SaveDibDib( pDib : PBITMAPINFOHEADER; FileName : string; size : DWORD ) : boolean;
var
    bmFH : BITMAPFILEHEADER ;
    aStream : TFileStream;
begin
  result := true;
  bmFH.bfType := ord('B') + (ord('M') shl 8);
  bmFH.bfSize := sizeof(BITMAPFILEHEADER) + size;
  bmFH.bfReserved1 := 0;
  bmFH.bfReserved2 := 0;
  bmFH.bfOffBits := sizeof(BITMAPFILEHEADER) + sizeof(BITMAPINFOHEADER) + 256*sizeof(RGBQUAD);
  aStream := TFileStream.Create(FileName,fmCreate);
  aStream.Write(bmFH,sizeof(BITMAPFILEHEADER));

  if ( aStream.Write(pDib^, size) <> size ) then
       Result := false;
  aStream.Free;
end;

function RawToBmp(RawPtr: Pointer; Width, Height: Integer ) : HGlobal;
var
  pNewDib : PBITMAPINFO;
  line_width, i, x, y : integer;
  newDib : HGlobal;
  ps,pd : Pbyte;
  pDst,newDibSize : Longint;
begin
  line_width := mult4(Width);
  newDibSize := sizeof(BITMAPINFOHEADER) + sizeof(RGBQUAD)*256 + Width*Height;
  newDib := GlobalAlloc(GMEM_MOVEABLE, newDibSize);
  pNewDib := GlobalLock(newDib);
  //Llena la estructura
  pNewDib^.bmiHeader.biSize := sizeof(BITMAPINFOHEADER);
  pNewDib^.bmiHeader.biWidth := Width;
  pNewDib^.bmiHeader.biHeight := Height;
  pNewDib^.bmiHeader.biPlanes := 1;
  pNewDib^.bmiHeader.biBitCount := 8;
  pNewDib^.bmiHeader.biCompression := BI_RGB;
  pNewDib^.bmiHeader.biSizeImage := line_width*Height;
  pNewDib^.bmiHeader.biXPelsPerMeter := 0;
  pNewDib^.bmiHeader.biYPelsPerMeter := 0;
  pNewDib^.bmiHeader.biClrUsed := 256;
  pNewDib^.bmiHeader.biClrImportant := 0;
  //ahora llena la paleta
  for i := 0 to 255 do begin
    pNewDib^.bmiColors[i].rgbBlue := i;
    pNewDib^.bmiColors[i].rgbGreen := i;
    pNewDib^.bmiColors[i].rgbRed := i;
    pNewDib^.bmiColors[i].rgbReserved := i;
  end;
  ps := RawPtr;
  //ahora copia los pixels
  pDst := longint(pNewDib) + sizeof(BITMAPINFOHEADER) + 256*sizeof(RGBQUAD);
  for y := Height -1 downto 0 do for x := 0 to Width -1 do begin
     pd := pByte(pDst + y*Width + x );
     pd^ := ps^;
     inc(ps);
  end;
  GlobalUnlock(newDib);
  result := newDib;
end;

function RawToBmp24(RedPtr, GreenPtr, BluePtr: Pointer; Width, Height: Integer ) : HGlobal;
var
  pNewDib : PBITMAPINFO;
  line_width, i, x, y : integer;
  newDib : HGlobal;
  pSrcRed,pSrcGreen, pSrcBlue : Pbyte;
  pd: pByte;
  pDst,newDibSize : Longint;
begin
  line_width := mult4(Width*3);
  newDibSize := sizeof(BITMAPINFOHEADER) + line_width*Height;
  newDib := GlobalAlloc(GMEM_MOVEABLE, newDibSize);
  pNewDib := GlobalLock(newDib);
  //Llena la estructura
  pNewDib^.bmiHeader.biSize := sizeof(BITMAPINFOHEADER);
  pNewDib^.bmiHeader.biWidth := Width;
  pNewDib^.bmiHeader.biHeight := Height;
  pNewDib^.bmiHeader.biPlanes := 1;
  pNewDib^.bmiHeader.biBitCount := 24;
  pNewDib^.bmiHeader.biCompression := BI_RGB;
  pNewDib^.bmiHeader.biSizeImage := line_width*Height;
  pNewDib^.bmiHeader.biXPelsPerMeter := 0;
  pNewDib^.bmiHeader.biYPelsPerMeter := 0;
  pNewDib^.bmiHeader.biClrUsed := 0;
  pNewDib^.bmiHeader.biClrImportant := 0;
  pSrcRed := RedPtr;
  pSrcGreen := GreenPtr;
  pSrcBlue := BluePtr;
  //ahora copia los pixels
  pDst := longint(pNewDib) + sizeof(BITMAPINFOHEADER);
  for y := Height -1 downto 0 do for x := 0 to Width do begin
     pd := pByte(pDst + y*line_width + x*3 );
     pd^ := pSrcBlue^;
     inc(pd);
     pd^ := pSrcGreen^;
     inc(pd);
     pd^ := pSrcRed^;
     inc(pSrcRed);
     inc(pSrcGreen);
     inc(pSrcBlue);
  end;
  GlobalUnlock(newDib);
  result := newDib;
end;

procedure RawToBmpFile(RawPtr: Pointer; Width, Height: Integer;
    FileName : string );
var
  HDib : HGlobal;
begin
  HDib := RawToBmp(RawPtr, Width, Height);
  SaveDib(HDib, FileName);
  GlobalFree(HDib);
end;

procedure RawToBmp24File(RedPtr, GreenPtr, BluePtr: Pointer;
  Width, Height: Integer; FileName : string );
var
  HDib : HGlobal;
begin
  HDib := RawToBmp24(RedPtr, GreenPtr, BluePtr, Width, Height);
  SaveDib(HDib, FileName);
  GlobalFree(HDib);
end;

procedure RawToBmpStream(RawPtr: Pointer; Width, Height: Integer;
    Stream : TStream );
var
  HDib : HGlobal;
begin
  HDib := RawToBmp(RawPtr, Width, Height);
  SaveDib(HDib, Stream);
  GlobalFree(HDib);
end;

procedure RawToBmp24Stream(RedPtr, GreenPtr, BluePtr: Pointer;
    Width, Height: Integer; Stream : TStream );
var
  HDib : HGlobal;
begin
  HDib := RawToBmp24(RedPtr, GreenPtr, BluePtr, Width, Height);
  SaveDib(HDib, Stream);
  GlobalFree(HDib);
end;

function RawToTBitmap(RawPtr: Pointer; Width, Height: Integer ) : TBitmap;
var
  HDib : HGlobal;
  Stream : TMemoryStream;
begin
  Stream := TMemoryStream.Create;
  RawToBmpStream(RawPtr, Width, Height, Stream);
  Stream.Seek(0,soFromBeginning	);
  Result := TBitmap.Create;
  Result.LoadFromStream(Stream);
  Stream.Free;
end;

function RawToTBitmap24(RedPtr, GreenPtr, BluePtr: Pointer; Width, Height: Integer ) : TBitmap;
var
  HDib : HGlobal;
  Stream : TMemoryStream;
begin
  HDib := RawToBmp24(RedPtr, GreenPtr, BluePtr, Width, Height);
  Result := HDibToTBitmap(HDib);
  GlobalFree(HDib);
end;

procedure Bitmap32ToRaw(RedPtr, GreenPtr, BluePtr: PByte; Bitmap32: TBitmap32);
var
  x,y: Integer;
  p: PColor32;
  c: TColor32;
begin
  for y := 0 to Bitmap32.Height - 1 do begin
  p := Bitmap32.PixelPtr[0,y];
  for x := 0 to Bitmap32.Width-1 do begin
    c := p^;
    RedPtr^ := (c and $00FF0000) shr 16;
    GreenPtr^ := (c and $0000FF00) shr 8;
    BluePtr^ := c and $000000FF;
    Inc(p);
    Inc(RedPtr);
    Inc(GreenPtr);
    Inc(BluePtr);
  end;
  // El muy dog... usa la última columna, es decir, el for x
  // tendría que llegar hasta la columna Bitmap32.Width
  //
  Inc(RedPtr);
  Inc(GreenPtr);
  Inc(BluePtr);
  end;
end;

function DibWidth(dibSrc : HGlobal) : integer;
var
  Height : integer;
begin
  DibExtents(dibSrc, Result, Height );
end;

function DibHeight(dibSrc : HGlobal) : integer;
var
  Width : integer;
begin
  DibExtents(dibSrc, Width, Result);
end;

function CreateBitmap( Width, Height: Integer ) : HGlobal;
var
  pNewDib : PBITMAPINFO;
  line_width, i, x, y : integer;
  newDib : HGlobal;
  pd : Pbyte;
  pDst,newDibSize : Longint;
begin
  line_width := mult4(Width);
  newDibSize := sizeof(BITMAPINFOHEADER) + sizeof(RGBQUAD)*256 + line_width*Height;
  newDib := GlobalAlloc(GMEM_MOVEABLE, newDibSize);
  pNewDib := GlobalLock(newDib);
  //Llena la estructura
  pNewDib^.bmiHeader.biSize := sizeof(BITMAPINFOHEADER);
  pNewDib^.bmiHeader.biWidth := Width;
  pNewDib^.bmiHeader.biHeight := Height;
  pNewDib^.bmiHeader.biPlanes := 1;
  pNewDib^.bmiHeader.biBitCount := 8;
  pNewDib^.bmiHeader.biCompression := BI_RGB;
  pNewDib^.bmiHeader.biSizeImage := line_width*Height;
  pNewDib^.bmiHeader.biXPelsPerMeter := 0;
  pNewDib^.bmiHeader.biYPelsPerMeter := 0;
  pNewDib^.bmiHeader.biClrUsed := 256;
  pNewDib^.bmiHeader.biClrImportant := 0;
  //ahora llena la paleta
  for i := 0 to 255 do begin
    pNewDib^.bmiColors[i].rgbBlue := i;
    pNewDib^.bmiColors[i].rgbGreen := i;
    pNewDib^.bmiColors[i].rgbRed := i;
    pNewDib^.bmiColors[i].rgbReserved := i;
  end;
  //ahora copia los pixels
  pDst := longint(pNewDib) + sizeof(BITMAPINFOHEADER) + 256*sizeof(RGBQUAD);
  for y := Height -1 downto 0 do for x := 0 to Width -1 do begin
     pd := pByte(pDst + y*Width + x );
     pd^ := 255;
  end;
  GlobalUnlock(newDib);
  result := newDib;
end;

procedure SaveFicha(output_filename : string; base_filename : string);
var
  img   : PBITMAPINFOHEADER;
  imgs  : array[1..10] of PBITMAPINFOHEADER;
  i, sz : integer;
begin
  img := LoadDib( 'fmodelo.bemepe' );
  for i := 1 to 10 do imgs[i] := LoadDib( base_filename + IntToStr(i)+'.bmp' );
  dibutils.SuperponerDibs(imgs[ 1], img, 1095, 1510 );
  dibutils.SuperponerDibs(imgs[ 2], img, 1745, 1510 );
  dibutils.SuperponerDibs(imgs[ 3], img, 2345, 1510 );
  dibutils.SuperponerDibs(imgs[ 4], img, 2945, 1510 );
  dibutils.SuperponerDibs(imgs[ 5], img, 3530, 1510 );
  dibutils.SuperponerDibs(imgs[ 6], img, 1095, 460  );
  dibutils.SuperponerDibs(imgs[ 7], img, 1745, 460  );
  dibutils.SuperponerDibs(imgs[ 8], img, 2345, 460  );
  dibutils.SuperponerDibs(imgs[ 9], img, 2945, 460  );
  dibutils.SuperponerDibs(imgs[10], img, 3530, 460  );
  sz := sizeof(BITMAPINFOHEADER) + sizeof(RGBQUAD)*256 + mult4(img^.biWidth)*img^.biHeight;
  SaveDibDib( img, output_filename, sz );
end;

function CreateGrayTBitmap(Width, Height : Integer) : TBitmap;
type
  LogPal = record
    lpal  : TLogPalette;
    dummy : array[0..255] of TPaletteEntry;
  end;
var
  Pal : LogPal;
  i : integer;
begin
  Result := TBitmap.Create;
  Result.Width := Width;
  Result.Height := Height;
  Result.PixelFormat := pf8Bit;
  Pal.lPal.palVersion:=$300;
  Pal.lPal.palNumEntries:=256;
  for i := 0 to 255 do begin
    Pal.lpal.palPalEntry[i].peRed:=i;
    Pal.lpal.palPalEntry[i].peGreen:=i;
    Pal.lpal.palPalEntry[i].peBlue:=i;
    Pal.lpal.palPalEntry[i].peFlags:=0;
  end;
  Result.Palette := CreatePalette(Pal.lpal);
end;

function HDibToTBitmap(const hDIB:  THandle):  TBitmap;
const
  PaletteVersion = $0300;  // "magic number" for Window's LOGPALETTE
var
  BitCount      :  INTEGER;
  BitmapInfo    :  pBitmapInfo;
  BitmapBits    :  Pointer;
  i             :  INTEGER;
  LogicalPalette:  TMaxLogPalette;
  NumberOfColors:  INTEGER;
  RGBQuad       :  pRGBQuad;
begin
  RESULT := TBitmap.Create;

  BitmapInfo := GlobalLock(hDIB);
  try
    RESULT.Width  := BitmapInfo.bmiHeader.biWidth;
    RESULT.Height := BitmapInfo.bmiHeader.biHeight;

    NumberOfColors := BitmapInfo.bmiHeader.biClrUsed;
    BitCount       := BitmapInfo.bmiHeader.biBitCount;
    if   (NumberOfColors = 0) and (BitCount <= 8)
    then begin
      NumberOfColors := 1 shl BitCount;

      // First RGBQuad in Color Table
      RGBQuad := Pointer(DWORD(BitmapInfo) +  SizeOf(TBitmapInfoHeader));

      // Create palette
      LogicalPalette.palVersion := PaletteVersion;
      LogicalPalette.palNumEntries := NumberOfColors;

      for i := 0 TO NumberOfColors-1 do
      begin
        with LogicalPalette.palPalEntry[i]
        do begin
          peRed   := RGBQuad.rgbRed;
          peGreen := RGBQuad.rgbGreen;
          peBlue  := RGBQuad.rgbBlue;
          peFlags := 0   // default value
        end;

        INC(RGBQuad)  // next entry in Color Table
      end;

      RESULT.Palette := CreatePalette(pLogPalette(@LogicalPalette)^)
    end;

    BitmapBits := Pointer(DWORD(BitmapInfo) +
                  SizeOf(TBitmapInfoHeader) +
                  NumberOfColors*SizeOf(TRGBQuad));

    StretchDIBits(RESULT.Canvas.Handle,
                  0,0, RESULT.Width, RESULT.Height,
                  0,0, RESULT.Width, RESULT.Height,
                  BitmapBits, BitmapInfo^,
                  DIB_RGB_COLORS, SRCCOPY);

    // At this point the RESULT TBitmap is a device-dependent bitmap (DDB) and
    // depends on the current display mode (just like in Delphi 2 TBitmaps).
    ASSERT( RESULT.HandleType = bmDDB );

  finally
    GlobalUnlock(hDIB);
    GlobalFree(hDIB)
  end
end {hDIBToTBitmap1};


end.