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

    { 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.

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