Bmp2gif

Bmp2gif

Bmp2gif : Plusieurs milliers de conseils pour vous faciliter la vie.

Convertir BMP en GIF
Contributeur: JEAN LE GRAND
{ Avertissements:
& nbsp & nbsp 1. Cela ne convertit les images bitmap 256 couleurs!
& nbsp & nbsp 2. Le seul format pris en charge est GIF87a.
}
unite de Bmp2Gif
interface
& nbsp & nbsp utilise
& ! & ! & ! & nbsp SysUtils,
& nbsp & nbsp Classes,
& nbsp & nbsp Windows,
& nbsp & nbsp Graphiques
& nbsp & nbsp fonction SaveAsGif(InputBM : TBitmap Pnom : string) : boolean
application
const
& nbsp & nbsp BlockTerminator:octets = 0
& nbsp & nbsp FileTrailer:octets = $3B
& nbsp & nbsp gifBGColor:octets = 0
& nbsp & nbsp gifPixAsp:octets = 0
& nbsp & nbsp gifcolordepth:octet = 8 // 8 bits = 256 couleurs
& nbsp & nbsp gifncolors:integer = 256
& nbsp & nbsp gifLIDid:octets = $2C
& nbsp & nbsp HASHSIZE:entier = 5101
& nbsp & nbsp HASHBITS:entier = 4
& nbsp & nbsp TABLSIZE:entier = 4096
& nbsp & nbsp VIDE:entier = -1
var
& nbsp F : integer
& nbsp Dbg : fichier Texte
& nbsp MapBM : TBitmap
& nbsp ImageWidth,ImageHeight:Integer
& nbsp tampon : array[0..255] of byte
& nbsp codes : array[0..5101] of Integer
& nbsp prefixe: array[0..5101] of Integer
& nbsp suffixe: array[0..5101] of Integer
& nbsp nBytes,nbits, la taille,la cursize, curcode, maxcode : Entier
& nbsp BitmapSizeImage : Integer
& nbsp Commence : Boolean
& nbsp minsize,maxsize nroots,Capacite : Integer
& nbsp endc, scea : Integer
& nbsp MinLZWCodeSize : Octet
& nbsp bytecode,bytemask :Integer
& nbsp compteur : Integer
& nbsp strc,la ccdp :Integer
& nbsp ErrorMsg : string
fonction de Putbyte(B,fh:Integer):Boolean
begin
& nbsp & nbsp Compteur := compteur 1
& nbsp & nbsp tampon[nbytes] := B
& nbsp & nbsp Inc(nbytes)
& nbsp & nbsp Si nbytes = 255
& nbsp & nbsp commencer
& ! & ! & ! & nbsp //ShowMessage('255')
& ! & ! & ! & nbsp FileWrite(fh,nbytes,1)
& ! & ! & ! & nbsp FileWrite(fh,tampon,nbytes)
& ! & ! & ! & nbsp nbytes := 0
& nbsp & nbsp fin
& nbsp & nbsp result := True
fin
fonction de PutCode(code fh :Integer) : Boolean
var
& nbsp & nbsp temp,n,masque :Integer
begin
& nbsp & nbsp masque := 1
& nbsp & nbsp n := nbits
& nbsp & nbsp //Si nbits > 11 ShowMessage('nbits = 12')
& nbsp & nbsp tandis que n > 0 faire
& nbsp & nbsp commencer
& ! & ! & ! & nbsp dec(n)
& ! & ! & ! & nbsp si ((code et le masque)<>0) alors bytecode := (bytecode ou bytemask)
& ! & ! & ! & nbsp bytemask := bytemask shl 1
& ! & ! & ! & nbsp si (bytemask > $80),
& ! & ! & ! & nbsp commencer
& ! & ! & ! & ! & ! & nbsp Si PutByte(bytecode,fh) puis
& ! & ! & ! & ! & ! & nbsp commencer
& ! & ! & ! & ! & ! & ! & ! & nbsp bytecode := 0
& ! & ! & ! & ! & ! & ! & ! & nbsp bytemask := 1
& ! & ! & ! & ! & ! & nbsp fin
& ! & ! & ! & nbsp fin
& ! & ! & ! & nbsp masque := masque shl 1
& nbsp & nbsp fin
& nbsp & nbsp result := True
fin
procedure de rinçage(fh:Integer)
begin
& nbsp & nbsp si bytemask <> 1 then
& nbsp & nbsp commencer
& ! & ! & ! & nbsp PutByte(byteCode,fh)
& ! & ! & ! & nbsp bytecode :=0
& ! & ! & ! & nbsp bytemask :=1
& nbsp & nbsp fin
& nbsp & nbsp si nbytes > 0, alors
& nbsp & nbsp commencer
& ! & ! & ! & nbsp FileWrite(fh,nbytes,1)
& ! & ! & ! & nbsp FileWrite(fh,tampon,nbytes)
& ! & ! & ! & nbsp nbytes :=0
& nbsp & nbsp fin
fin
procedure ClearX
var
& nbsp & nbsp J : Integer
begin
& nbsp & nbsp cursize := minsize
& nbsp & nbsp nbits := cursize
& nbsp & nbsp curcode := 1 endc
& nbsp & nbsp maxcode := 1 shl cursize
& nbsp & nbsp pour J := 0 pour HASHSIZE ne codes[J] := VIDE
fin
fonction de findstr(pfx,sfx :Integer):integer
var
& nbsp & nbsp i,di : Integer
begin
& nbsp & nbsp i := (sfx shl HASHBITS) xor pfx
& nbsp & nbsp si i = 0 alors di := 1 else di := Capacite -je
& nbsp & nbsp while True do
& nbsp & nbsp commencer
& ! & ! & ! & nbsp si des codes[i] = VIDE alors pause
& ! & ! & ! & nbsp si ((prefixe[i] = pfx) et (suffixe[i] = sfx)) puis pause
& ! & ! & ! & ! i := i - di
& ! & ! & ! & nbsp si i < 0 alors i := i Capacite
& nbsp & nbsp fin
& nbsp & nbsp Resultat := i
fin
procedure EncodeScanLine(fh : Entier var buf : Pbyte npxls : Integer)
var
& nbsp & nbsp np,I : Integer
begin
& nbsp & nbsp np := 0
& nbsp & nbsp si pas Commence alors
& nbsp & nbsp commencer
& ! & ! & ! & nbsp strc := buf^
& ! & ! & ! & nbsp Inc(np) Inc(buf)
& ! & ! & ! & nbsp Commence := True
& nbsp & nbsp fin
& nbsp & nbsp tandis que np < npxls ne
& nbsp & nbsp commencer
& ! & ! & ! & nbsp // Si np = 3 then break
& ! & ! & ! & nbsp ccdp := buf^
& ! & ! & ! & nbsp Inc(np) Inc(buf)
& ! & ! & ! & ! I := findstr(strc,ccdp)
& ! & ! & ! & nbsp si des codes[I] <> EMPTY
& ! & ! & ! & ! & ! & nbsp strc := codes[I]
& ! & ! & ! & nbsp else
& ! & ! & ! & nbsp commencer
& ! & ! & ! & ! & ! & nbsp codes[I] := curcode
& ! & ! & ! & ! & ! & nbsp prefixe[I] := strc
& ! & ! & ! & ! & ! & nbsp suffixe[I] := ccdp
& ! & ! & ! & ! & ! & nbsp putcode(strc,fh)
& ! & ! & ! & ! & ! & nbsp strc := ccdp
& ! & ! & ! & ! & ! & nbsp Inc(curcode)
& ! & ! & ! & ! & ! & nbsp si curcode > maxcode puis
& ! & ! & ! & ! & ! & nbsp commencer
& ! & ! & ! & ! & ! & ! & ! & nbsp Inc(cursize)
& ! & ! & ! & ! & ! & ! & ! & nbsp si cursize > maxsize puis
& ! & ! & ! & ! & ! & ! & ! & nbsp commencer
& ! & ! & ! & ! & ! & ! & ! & ! & ! & nbsp putcode(scea,fh)
& ! & ! & ! & ! & ! & ! & ! & ! & ! & nbsp ClearX
& ! & ! & ! & ! & ! & ! & ! & nbsp fin

& ! & ! & ! & ! & ! & ! & ! & nbsp else
& ! & ! & ! & ! & ! & ! & ! & nbsp commencer
& nbsp & nbsp & ! & ! & ! & ! & ! & ! & ! & nbsp nbits := cursize
& ! & ! & ! & ! & ! & ! & ! & ! & ! & nbsp maxcode := maxcode shl 1
& ! & ! & ! & ! & ! & ! & ! & ! & ! & nbsp si cursize = maxsize puis dec(maxcode)
& ! & ! & ! & ! & ! & ! & ! & nbsp fin
& ! & ! & ! & ! & ! & nbsp fin
& ! & ! & ! & nbsp fin
& nbsp & nbsp fin
fin
procedure Initialiser(fh:entier)
var
& nbsp & nbsp drapeaux : Byte
begin
& nbsp & nbsp compteur := 0
& nbsp & nbsp Commence := False
& nbsp & nbsp taille := 8
& nbsp & nbsp nbytes := 0
& nbsp & nbsp nbits := 8
& nbsp & nbsp bytecode := 0
& nbsp & nbsp bytemask := 1
& nbsp & nbsp Capacite := HASHSIZE
& nbsp & nbsp minsize := 9
& nbsp & nbsp maxsize := 12
& nbsp & nbsp nroots := 1 shl 8
& nbsp & nbsp scea := nroots
& nbsp & nbsp endc := scea 1
& nbsp & nbsp MinLZWCodeSize := 8
& nbsp & nbsp ClearX
& nbsp & nbsp // Ecriture du type
& nbsp & nbsp FileWrite(fh,'GIF87a',6)
& nbsp & nbsp // Ecrire le GIF ecran descripteur
& nbsp & nbsp // Note: la largeur > 255 est un mot de deux octets!!
& nbsp & nbsp FileWrite(fh,ImageWidth,2)
& nbsp & nbsp FileWrite(fh,ImageHeight,2)
& nbsp & nbsp drapeaux : = 80 $ou ((gifcolordepth-1)shl 4) ou (gifcolordepth-1)
& nbsp & nbsp FileWrite(fh,drapeaux,1)
& nbsp & nbsp FileWrite(fh,gifBGColor,1)
& nbsp & nbsp FileWrite(fh,gifPixAsp,1)
fin

procedure WriteGif(fh : entier)
var
& nbsp & nbsp F:fichier Texte
& nbsp & nbsp gifxLeft,gifyTop : mot //Doit etre de 16 bits!!
& nbsp & nbsp drapeaux :Octet
& nbsp & nbsp K : Pointeur
& nbsp & nbsp Test,J,M : Entier
& nbsp & nbsp scanLine, TempscanLine, Bits, PBits : PByte
begin
& nbsp & nbsp //Obtenir l'info de l'image Bitmap
& nbsp & nbsp GetMem(K,(sizeof(TBitMapInfoHeader) 4 * gifncolors))
& nbsp & nbsp TBitmapInfo(K^).bmiHeader.biSize := sizeof(TBitMapInfoHeader)
& nbsp & nbsp TBitmapInfo(K^).bmiHeader.biWidth := ImageWidth
& nbsp & nbsp TBitmapInfo(K^).bmiHeader.biHeight := ImageHeight
& nbsp & nbsp TBitmapInfo(K^).bmiHeader.les biplans := 1
& nbsp & nbsp TBitmapInfo(K^).bmiHeader.valeur bibitcount := 8
& nbsp & nbsp TBitmapInfo(K^).bmiHeader.biCompression := BI_RGB
& nbsp & nbsp TBitmapInfo(K^).bmiHeader.biSizeImage :=
& nbsp nbsp & ((((TBitmapInfo(K^).bmiHeader.biWidth * TBitmapInfo(K^).bmiHeader.valeur bibitcount) 31)
& ! & ! & ! & ! & ! & nbsp et Pas(31)) shr 3)*TBitmapInfo(K^).bmiHeader.biHeight
& nbsp & nbsp TBitmapInfo(K^).bmiHeader.biXPelsPerMeter := 0
& nbsp & nbsp TBitmapInfo(K^).bmiHeader.biYPelsPerMeter := 0
& nbsp & nbsp TBitmapInfo(K^).bmiHeader.biClrUsed := 0
& nbsp & nbsp TBitmapInfo(K^).bmiHeader.biClrImportant := 0
& nbsp & nbsp essayer
& ! & ! & ! & nbsp GetMem(Bits,TBitmapInfo(K^).bmiHeader.biSizeImage)
& ! & ! & ! & nbsp Test := GetDIBits(MapBM.Toile.Poignee,MapBM.Poignee,0,ImageHeight,Bits,TBitmapInfo(K^),DIB_RGB_COLORS)
& ! & ! & ! & nbsp Si le Test > 0, alors
& ! & ! & ! & nbsp commencer
& ! & ! & ! & ! & ! & nbsp pour J := 0 a 255 ne
& ! & ! & ! & ! & ! & nbsp commencer
& ! & ! & ! & ! & ! & ! & ! & nbsp FileWrite(fh,TBitMapInfo(K^).bmiColors[J].et rgbred,1)
& ! & ! & ! & ! & ! & ! & ! & nbsp FileWrite(fh,TBitMapInfo(K^).bmiColors[J].rgbGreen,1)
& ! & ! & ! & ! & ! & ! & ! & nbsp FileWrite(fh,TBitMapInfo(K^).bmiColors[J].rgbBlue,1)
& ! & ! & ! & ! & ! & nbsp fin
& ! & ! & ! & ! & ! & nbsp //Ecrire la Logique de l'Image Descripteur
& ! & ! & ! & ! & ! & nbsp FileWrite(fh,gifLIDid,1)
& ! & ! & ! & ! & ! & nbsp gifxLeft := 0 FileWrite(fh,gifxLeft,2) // Ecriture de la position X de l'image
& ! & ! & ! & ! & ! & nbsp gifyTop := 0 FileWrite(fh,gifyTop,2) // Ecriture de la position Y de l'image
& ! & ! & ! & ! & ! & nbsp FileWrite(fh,ImageWidth,2)
& ! & ! & ! & ! & ! & nbsp FileWrite(fh,ImageHeight,2)
& ! & ! & ! & ! & ! & nbsp drapeaux := 0 FileWrite(fh,drapeaux,1) //Ecriture Local drapeaux 0=Aucun
& ! & ! & ! & ! & ! & nbsp /Ecriture/Min LZW code taille = 8 (8 bits)
& ! & ! & ! & ! & ! & nbsp MinLZWCodeSize := 8
& ! & ! & ! & ! & ! & nbsp FileWrite(fh,MinLZWCodesize,1)
& ! & ! & ! & ! & ! & nbsp PutCode(scea,fh)
& ! & ! & ! & ! & ! & nbsp PBits := Bits
& ! & ! & ! & ! & ! & nbsp Inc(Pbits,(ImageWidth *(ImageHeight -1)))
& ! & ! & ! & ! & ! & nbsp GetMem(scanLine,ImageWidth)
& ! & ! & ! & ! & ! & nbsp TempscanLine := scanLine
& ! & ! & ! & ! & ! & nbsp Pour M := De 0 a ImageHeight-1 do
& ! & ! & ! & ! & ! & nbsp commencer
& ! & ! & ! & ! & ! & ! & ! & nbsp FillChar(scanLine^,ImageWidth,0)
& ! & ! & ! & ! & ! & ! & ! & nbsp deplacer(PBits^,scanLine^,ImageWidth)
& ! & ! & ! & ! & ! & ! & ! & nbsp EncodeScanLine(fh,scanLine,ImageWidth)
& ! & ! & ! & ! & ! & ! & ! & nbsp dec(scanLine,ImageWidth)
& ! & ! & ! & ! & ! & ! & ! & nbsp Dec(PBits,ImageWidth)
& ! & ! & ! & ! & ! & nbsp fin
& ! & ! & ! & nbsp fin
& nbsp & nbsp enfin
& ! & ! & ! & nbsp scanLine := TempscanLine
& ! & ! & ! & nbsp FreeMem(scanLine,ImageWidth)
& ! & ! & ! & nbsp FreeMem(Bits,TBitMapInfo(K^).bmiHeader.biSizeImage)
& ! & ! & ! & nbsp FreeMem(K,(sizeof(TBitMapInfoHeader) 4 * gifncolors))
& nbsp & nbsp fin
fin

fonction de SaveAsGif(InputBM : TBitmap Pnom : string) : boolean
begin
& nbsp & nbsp ErrorMsg := '
& nbsp & nbsp Resultat := FALSE
& nbsp & nbsp MapBM := InputBM
& nbsp & nbsp ImageWidth := MapBM.La largeur
& nbsp & nbsp ImageHeight := MapBM.Hauteur
& nbsp & nbsp F := FileCreate(FName)
& nbsp & nbsp si F >= 0 alors
& nbsp & nbsp commencer
& ! & ! & ! & nbsp Initialiser(F)
& ! & ! & ! & nbsp WriteGif(F)
& ! & ! & ! & nbsp PutCode(strc,F)
& ! & ! & ! & nbsp PutCode(endc,F)
& ! & ! & ! & nbsp Flush(F)
& ! & ! & ! & nbsp FileWrite(F,BlockTerminator,1)
& ! & ! & ! & nbsp FileWrite(F,FileTrailer,1)
& ! & ! & ! & nbsp FileClose(F)
& ! & ! & ! & nbsp si la longueur(ErrorMsg) = 0 then Result := TRUE
& nbsp & nbsp fin
fin
a la fin.