Bmp2GIF

Convert BMP to GIF

Contributor: JOHN THE GREAT



{ Caveats:

  1. This ONLY converts 256 color bitmaps!

  2. The only format supported is GIF87a.

}



unit Bmp2Gif;



interface



  uses

    SysUtils,

  Classes,

  Windows,

  Graphics;



  function SaveAsGif(InputBM : TBitmap; FName : string) : boolean;



implementation



const

  BlockTerminator:byte = 0;

  FileTrailer:byte = $3B;

  gifBGColor:byte = 0;

  gifPixAsp:byte = 0;

  gifcolordepth:byte = 8; // 8 bit = 256 colors

  gifncolors:integer = 256;

  gifLIDid:byte = $2C;

  HASHSIZE:integer = 5101;

  HASHBITS:integer = 4;

  TABLSIZE:integer = 4096;

  EMPTY:integer = -1;



var

 F : integer;

 Dbg : TextFile;

 MapBM : TBitmap;

 ImageWidth,ImageHeight:Integer;

 buffer : array[0..255] of byte;

 codes : array[0..5101] of Integer;

 prefix: array[0..5101] of Integer;

 suffix: array[0..5101] of Integer;

 nBytes,nbits, size,cursize, curcode, maxcode : Integer;

 BitmapSizeImage : Integer;

 Started : Boolean;

 minsize,maxsize,nroots,Capacity : Integer;

 endc, clrc : Integer;

 MinLZWCodeSize : Byte;

 bytecode,bytemask :Integer;

 counter : Integer;

 strc,chrc :Integer;

 ErrorMsg : string;



function Putbyte(B,fh:Integer):Boolean;



begin

  Counter := counter + 1;

  buffer[nbytes] := B;

  Inc(nbytes);

  If nbytes = 255 then

  begin

    //ShowMessage('255');

    FileWrite(fh,nbytes,1);

    FileWrite(fh,buffer,nbytes);

    nbytes := 0;

  end;

  result := True;

end;



function PutCode(code, fh :Integer) : Boolean;



var

  temp,n,mask :Integer;



begin

  mask := 1;

  n := nbits;

  //If nbits > 11 then ShowMessage('nbits = 12');

  while n > 0 do

  begin

    dec(n);

    if ((code and mask)<>0) then bytecode := (bytecode or bytemask);

    bytemask := bytemask shl 1;

    if (bytemask > $80) then

    begin

      If PutByte(bytecode,fh) then

      begin

        bytecode := 0;

        bytemask := 1;

      end;

    end;

    mask := mask shl 1;

  end;

  result := True;

end;



procedure Flush(fh:Integer);



begin

  if bytemask <> 1 then

  begin

    PutByte(byteCode,fh);

    bytecode :=0;

    bytemask :=1;

  end;

  if nbytes > 0 then

  begin

    FileWrite(fh,nbytes,1);

    FileWrite(fh,buffer,nbytes);

    nbytes :=0;

  end;

end;



procedure ClearX;



var

  J : Integer;



begin

  cursize := minsize;

  nbits := cursize;

  curcode := endc + 1;

  maxcode := 1 shl cursize;

  for J := 0 to HASHSIZE do codes[J] := EMPTY;

end;



function findstr(pfx,sfx :Integer):integer;



var

  i,di : Integer;



begin

  i := (sfx shl HASHBITS) xor pfx;

  if i = 0 then di := 1 else di := Capacity -i;

  while True do

  begin

    if codes[i] = EMPTY then break;

    if ((prefix[i] = pfx) and (suffix[i] = sfx)) then break;

    i := i - di;

    if i < 0 then i := i + Capacity;

  end;

  Result := i;

end;



procedure EncodeScanLine(fh : Integer; var buf : Pbyte; npxls : Integer);



var

  np,I : Integer;



begin

  np := 0;

  if not Started then

  begin

    strc := buf^;

    Inc(np); Inc(buf);

    Started := True;

  end;

  while np < npxls do

  begin

    // If np = 3 then break;

    chrc := buf^;

    Inc(np); Inc(buf);

    I := findstr(strc,chrc);

    if codes[I] <> EMPTY then

      strc := codes[I]

    else

    begin

      codes[I] := curcode;

      prefix[I] := strc;

      suffix[I] := chrc;

      putcode(strc,fh);

      strc := chrc;

      Inc(curcode);

      if curcode > maxcode then

      begin

        Inc(cursize);

        if cursize > maxsize then

        begin

          putcode(clrc,fh);

          ClearX;

        end


        else

        begin

          nbits := cursize;

          maxcode := maxcode shl 1;

          if cursize = maxsize then dec(maxcode);

        end;

      end;

    end;

  end;

end;



procedure Initialize(fh:integer);



var

  flags : Byte;



begin

  counter := 0;

  Started := False;

  size := 8;

  nbytes := 0;

  nbits := 8;

  bytecode := 0;

  bytemask := 1;

  Capacity := HASHSIZE;

  minsize := 9;

  maxsize := 12;

  nroots := 1 shl 8;

  clrc := nroots;

  endc := clrc + 1;

  MinLZWCodeSize := 8;

  ClearX;

  // Write the type

  FileWrite(fh,'GIF87a',6);

  // Write the GIF screen descriptor

  // Note: width > 255 is a two byte word!!

  FileWrite(fh,ImageWidth,2);

  FileWrite(fh,ImageHeight,2);

  flags := $80 or ((gifcolordepth-1)shl 4) or (gifcolordepth-1);

  FileWrite(fh,flags,1);

  FileWrite(fh,gifBGColor,1);

  FileWrite(fh,gifPixAsp,1);

end;







procedure WriteGif(fh : integer);



var

  F:TextFile;

  gifxLeft,gifyTop : word; //Must be 16 bit!!

  flags :Byte;

  K : Pointer;

  Test,J,M : Integer;

  scanLine, TempscanLine, Bits, PBits : PByte;



begin

  //Get the info from the Bitmap

  GetMem(K,(sizeof(TBitMapInfoHeader) + 4 * gifncolors));

  TBitmapInfo(K^).bmiHeader.biSize := sizeof(TBitMapInfoHeader);

  TBitmapInfo(K^).bmiHeader.biWidth := ImageWidth;

  TBitmapInfo(K^).bmiHeader.biHeight := ImageHeight;

  TBitmapInfo(K^).bmiHeader.biPlanes := 1;

  TBitmapInfo(K^).bmiHeader.biBitCount := 8;

  TBitmapInfo(K^).bmiHeader.biCompression := BI_RGB;

  TBitmapInfo(K^).bmiHeader.biSizeImage :=

  ((((TBitmapInfo(K^).bmiHeader.biWidth * TBitmapInfo(K^).bmiHeader.biBitCount)+31)

      and Not(31)) shr 3)*TBitmapInfo(K^).bmiHeader.biHeight;

  TBitmapInfo(K^).bmiHeader.biXPelsPerMeter := 0;

  TBitmapInfo(K^).bmiHeader.biYPelsPerMeter := 0;

  TBitmapInfo(K^).bmiHeader.biClrUsed := 0;

  TBitmapInfo(K^).bmiHeader.biClrImportant := 0;

  try

    GetMem(Bits,TBitmapInfo(K^).bmiHeader.biSizeImage);

    Test := GetDIBits(MapBM.Canvas.Handle,MapBM.Handle,0,ImageHeight,Bits,TBitmapInfo(K^),DIB_RGB_COLORS);

    If Test > 0 then

    begin

      for J := 0 to 255 do

      begin

        FileWrite(fh,TBitMapInfo(K^).bmiColors[J].rgbRed,1);

        FileWrite(fh,TBitMapInfo(K^).bmiColors[J].rgbGreen,1);

        FileWrite(fh,TBitMapInfo(K^).bmiColors[J].rgbBlue,1);

      end;

      //Write the Logical Image Descriptor

      FileWrite(fh,gifLIDid,1);

      gifxLeft := 0; FileWrite(fh,gifxLeft,2); // Write X position of image

      gifyTop := 0; FileWrite(fh,gifyTop,2); // Write Y position of image

      FileWrite(fh,ImageWidth,2);

      FileWrite(fh,ImageHeight,2);

      flags := 0; FileWrite(fh,flags,1); //Write Local flags 0=None

      //Write Min LZW code size = 8 (for 8 bit)

      MinLZWCodeSize := 8;

      FileWrite(fh,MinLZWCodesize,1);

      PutCode(clrc,fh);

      PBits := Bits;

      Inc(Pbits,(ImageWidth *(ImageHeight -1)));

      GetMem(scanLine,ImageWidth);

      TempscanLine := scanLine;

      For M := 0 to ImageHeight-1 do

      begin

        FillChar(scanLine^,ImageWidth,0);

        move(PBits^,scanLine^,ImageWidth);

        EncodeScanLine(fh,scanLine,ImageWidth);

        dec(scanLine,ImageWidth);

        Dec(PBits,ImageWidth);

      end;

    end;

  finally

    scanLine := TempscanLine;

    FreeMem(scanLine,ImageWidth);

    FreeMem(Bits,TBitMapInfo(K^).bmiHeader.biSizeImage);

    FreeMem(K,(sizeof(TBitMapInfoHeader) + 4 * gifncolors));

  end;

end;





function SaveAsGif(InputBM : TBitmap; FName : string) : boolean;



begin

  ErrorMsg := '';

  Result := FALSE;

  MapBM := InputBM;

  ImageWidth := MapBM.Width;

  ImageHeight := MapBM.Height;

  F := FileCreate(FName);

  if F >= 0 then

  begin

    Initialize(F);

    WriteGif(F);

    PutCode(strc,F);

    PutCode(endc,F);

    Flush(F);

    FileWrite(F,BlockTerminator,1);

    FileWrite(F,FileTrailer,1);

    FileClose(F);

    if length(ErrorMsg) = 0 then Result := TRUE;

  end;

end;



end.

 

Share this article!

Follow us!

Find more helpful articles: