Konverter BMP til GIFContributor: JOHN THE GREAT {Advarsler: 1. Denne konverterer KUN 256 fargepunktgrafikk! 2. Den eneste format som støttes er GIF87a} enhet Bmp2Gif;. Grensesnittet bruker SysUtils, Klasser, Windows, grafikk; funksjon SaveAsGif (InputBM: TBitmap; fname: string): boolean; implementationconst BlockTerminator: byte = 0; FileTrailer: byte = $ 3B; gifBGColor: byte = 0; gifPixAsp: byte = 0; gifcolordepth: byte = 8; //8 bits = 256 farger gifncolors: integer = 256; gifLIDid: byte = $ 2C; HASHSIZE: integer = 5101; HASHBITS: integer = 4; TABLSIZE: integer = 4096; TOM: integer = 1; Div F: integer; DBG: tekstfil; MapBM: TBitmap; ImageWidth, ImageHeight: Integer; buffer: array [0..255] av byte; koder: array [0..5101] av Integer; prefix: array [0..5101] av Integer; suffiks: array [0..5101] av Integer; nBytes, nbits, størrelse, cursize, curcode, maxcode: Integer; BitmapSizeImage: Integer; Startet: Boolean; minsize, MAXSIZE, nroots, Kapasitet: Integer; endc, clrc: Integer; MinLZWCodeSize: Byte; bytecode, bytemask: Integer; teller: Integer; strc, chrc: Integer; Errormsg: string; funksjon Putbyte (B, fh: Integer): Boolean, begynner Teller: = teller + 1; buffer [nbytes]: = B; Inc (nbytes); Hvis nbytes = 255 da begynne //ShowMessage ( '255'); WRITE (fh, nbytes, 1); WRITE (FH, buffer, nbytes); nbytes: = 0; slutt; Resultatet: = True; ende; funksjon PutCode (kode, fh: Integer): Boolean; Var temp, n, maske: Integer; begynne maske: = 1; n: = nbits; //Hvis nbits > 11 da ShowMessage ( 'nbits = 12'); mens n > 0 gjør begynne desember (n); if ((kode og maske) < > 0) så Bytecode: = (bytecode eller bytemask); bytemask: = bytemask SHL 1; if (bytemask > $ 80), og start Hvis PutByte (bytecode, fh), og start Bytecode: = 0; bytemask: = 1; slutt; slutt; maske: = maske SHL 1; slutt; Resultatet: = True; ende; prosedyre Flush (fh: Integer); begynne hvis bytemask < > 1 da begynne PutByte (bytecode, fh); Bytecode: = 0; bytemask: = 1; slutt; hvis nbytes > 0 da begynne WRITE (fh, nbytes, 1); WRITE (FH, buffer, nbytes); nbytes: = 0; end, end, prosedyre ClearX, Div J: Integer; begynne cursize: = minsize; nbits: = cursize; curcode: = endc + 1; maxcode: = 1 SHL cursize; for J: = 0 til HASHSIZE gjøre koder [J]: = Tom; ende; funksjon findstr (pfx, sfx: Integer): integer; Var jeg, di: Integer, begynner jeg: = (sfx SHL HASHBITS) xor pfx; hvis i = 0, så di: = 1 annet di: = Kapasitet -i; mens Sann gjør begynne hvis kodene [i] = Tom deretter bryte; if ((prefiks [i] = PFX) og (suffiks [i] = sfx)) og deretter bryte; jeg: = i - di; hvis jeg < 0 da jeg: = i + Kapasitet; slutt; Resultat: = i; ende; prosedyre EncodeScanLine (fh: Integer; Var buf: Pbyte; npxls: Integer); Var np, jeg: Integer; begynne np: = 0; om ikke i gang da begynne strc: = buf ^; Inc (np); Inc (buf); Startet: = true; slutt; mens np < npxls ikke begynne //Hvis np = 3 og deretter bryte; chrc: = buf ^; Inc (np); Inc (buf); I: = findstr (strc, chrc); Hvis kodene [I] < > Tøm deretter strc: = koder [I] ellers begynne koder [I]: = curcode; prefiks [I]: = strc; suffikset [I]: = chrc; putcode (strc, fh); strc: = chrc; Inc (curcode); hvis curcode > maxcode deretter begynne Inc (cursize); hvis cursize > MAXSIZE deretter begynne putcode (clrc, fh); ClearX; ende ellers begynner nbits: = cursize; maxcode: = maxcode SHL 1; hvis cursize = MAXSIZE deretter felles (maxcode); slutt; slutt; slutt; end, end, prosedyre Initial (fh: integer); Var flagg: Byte, begynner disken: = 0; Startet: = False; size: = 8; nbytes: = 0; nbits: = 8; Bytecode: = 0; bytemask: = 1; Kapasitet: = HASHSIZE; minsize: = 9; MAXSIZE: = 12; nroots: = 1 SHL 8; clrc: = nroots; endc: = clrc + 1; MinLZWCodeSize: = 8; ClearX; //Skriv typen WRITE (fh, 'GIF87a', 6); //Skriv GIF skjermen descriptor //Note: bredde > 255 er en to-byte ord !! WRITE (fh, ImageWidth, 2); WRITE (fh, ImageHeight, 2); flagg: = 80 $ eller ((gifcolordepth-1) SHL 4) eller (gifcolordepth-1); WRITE (fh, flagg, 1); WRITE (fh, gifBGColor, 1); WRITE (fh, gifPixAsp, 1); end; prosedyre WriteGif (fh: integer); Var F: tekstfil; gifxLeft, gifyTop: ord; //Må være 16 bit !! flagg: Byte; K: Pointer; Test, J, M: Integer; Scanline, TempscanLine, Bits, PBits: PByte; begynne //Få info fra 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) og 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;. prøve GetMem (Bits, TBitmapInfo (K ^) bmiHeader.biSizeImage.); Test: = GetDIBits (MapBM.Canvas.Handle, MapBM.Handle, 0, ImageHeight, Bits, TBitmapInfo (K ^), DIB_RGB_COLORS); Hvis Test > 0 da begynne for J: = 0 til 255 gjør begynne WRITE, (fh, TBitMapInfo (K ^) bmiColors [J] .rgbRed, 1.) WRITE (fh, TBitMapInfo (K ^) bmiColors [J] .rgbGreen, 1.); WRITE (fh, TBitMapInfo (K ^) bmiColors [J] .rgbBlue, 1.); slutt; //Skriv Logical Bilde Descriptor WRITE (fh, gifLIDid, 1); gifxLeft: = 0; WRITE (fh, gifxLeft, 2); //Skriv X posisjonen til gifyTop: = 0; WRITE (fh, gifyTop, 2); //Skriv Y posisjonen til WRITE (fh, ImageWidth, 2); WRITE (fh, ImageHeight, 2); flagg: = 0; WRITE (fh, flagg, 1); //Skriv Lokale flagg 0 = Ingen //Skriv Min LZW kode size = 8 (for 8 bit) MinLZWCodeSize: = 8; WRITE (fh, MinLZWCodesize, 1); PutCode (clrc, fh); PBits: = Bits; Inc (Pbits, (ImageWidth * (ImageHeight -1))); GetMem (Scanline, ImageWidth); TempscanLine: = Scanline; For M: = 0 til ImageHeight-en gjøre begynne FillChar (Scanline ^, ImageWidth, 0); flytte (PBits ^, Scanline ^, ImageWidth); EncodeScanLine (fh, Scanline, ImageWidth); desember (Scanline, ImageWidth); Des (PBits, ImageWidth); slutt; slutt; endelig Scanline: = TempscanLine; FreeMem (Scanline, ImageWidth); FreeMem (Bits, TBitMapInfo (K ^) bmiHeader.biSizeImage.); FreeMem (K, (sizeof (TBitMapInfoHeader) + 4 * gifncolors)); end, end, funksjon SaveAsGif (InputBM: TBitmap; fname: string): boolean, begynner errormsg: = ''; Resultat: = false; MapBM: = InputBM; ImageWidth: = MapBM.Width; ImageHeight: = MapBM.Height; F: = FileCreate (fname); hvis F > = 0 da begynne Initial (F); WriteGif (F); PutCode (strc, F); PutCode (endc, F); Flush (F); WRITE (F, BlockTerminator, 1); WRITE (F, FileTrailer, 1); FileClose (F); hvis lengde (errormsg) = 0, så Resultat: = true; end, end,. slutten