Bmp2gif

Bmp2gif

Bmp2gif : Multi-millones de consejos para hacer su vida mas facil.

Convertir BMP a GIF
Colaborador: JUAN EL GRAN
{ Advertencias:
& nbsp & nbsp 1. Esto SOLO convierte los mapas de bits de 256 colores!
& nbsp & nbsp 2. El unico formato soportado es GIF87a.
}
unidad de Bmp2Gif
interfaz
& nbsp & nbsp usos
& nbsp & nbsp & nbsp & nbsp SysUtils,
& nbsp & nbsp Clases,
& nbsp & nbsp Windows,
& nbsp & nbsp Graficos
& nbsp & nbsp funcion SaveAsGif(InputBM : TBitmap FName : string) : boolean
aplicacion
const
& nbsp & nbsp BlockTerminator:bytes = 0
& nbsp & nbsp FileTrailer:bytes = $3B
& nbsp & nbsp gifBGColor:bytes = 0
& nbsp & nbsp gifPixAsp:bytes = 0
& nbsp & nbsp gifcolordepth:byte = 8 // 8 bits = 256 colores
& nbsp & nbsp gifncolors:integer = 256
& nbsp & nbsp gifLIDid:bytes = $2C
& nbsp & nbsp HASHSIZE:integer = 5101
& nbsp & nbsp HASHBITS:integer = 4
& nbsp & nbsp TABLSIZE:integer = 4096
& nbsp & nbsp VACIO:integer = -1
var
& nbsp F : integer
& nbsp Dbg : archivo de Texto
& nbsp MapBM : TBitmap
& nbsp ImageWidth,ImageHeight:Integer
& nbsp buffer : array[0..255] de bytes
& nbsp codigos : array[0..5101] of Integer
& nbsp prefijo: array[0..5101] of Integer
& nbsp sufijo: array[0..5101] of Integer
& nbsp nBytes,nbits, tamaño,cursize, curcode, maxcode : Integer
& nbsp BitmapSizeImage : Integer
& nbsp Comenzo : Boolean
& nbsp minsize,maxsize,nroots,Capacidad : Integer
& nbsp c d d n, clrc : Integer
& nbsp MinLZWCodeSize : Byte
& nbsp bytecode,bytemask :Integer
& nbsp contador : Integer
& nbsp strc,chrc :Integer
& nbsp ErrorMsg : cadena
funcion Putbyte(B,fh:Integer):Boolean
begin
& nbsp & nbsp Contador := contador 1
& nbsp & nbsp buffer[nbytes] := B
& nbsp & nbsp Inc(nbytes)
& nbsp & nbsp Si nbytes = 255, a continuacion,
& nbsp & nbsp empezar
& nbsp & nbsp & nbsp & nbsp //ShowMessage('255')
& nbsp & nbsp & nbsp & nbsp FileWrite(fh,nbytes,1)
& nbsp & nbsp & nbsp & nbsp FileWrite(fh,buffer,nbytes)
& nbsp & nbsp & nbsp & nbsp nbytes := 0
& nbsp & nbsp final
& nbsp & nbsp resultado := True
fin
funcion PutCode(codigo, fh :Integer) : Boolean
var
& nbsp & nbsp temp,n,de la mascara :Integer
begin
& nbsp & nbsp mascara := 1
& nbsp & nbsp n := nbits
& nbsp & nbsp //Si nbits > 11, a continuacion, ShowMessage('nbits = 12')
& nbsp & nbsp mientras n > 0
& nbsp & nbsp empezar
& nbsp & nbsp & nbsp & nbsp dic(n)
& nbsp & nbsp & nbsp & nbsp if ((codigo y mascara)<>0) entonces bytecode := (bytecode o bytemask)
& nbsp & nbsp & nbsp & nbsp bytemask := bytemask shl 1
& nbsp & nbsp & nbsp & nbsp si (bytemask > $80)
& nbsp & nbsp & nbsp & nbsp empezar
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Si PutByte(bytecode,fh) a continuacion,
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp empezar
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp bytecode := 0
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp bytemask := 1
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp final
& nbsp & nbsp & nbsp & nbsp final
& nbsp & nbsp & nbsp & nbsp mascara := mascara de shl 1
& nbsp & nbsp final
& nbsp & nbsp resultado := True
fin
procedimiento de purga(fh:Integer)
begin
& nbsp & nbsp si bytemask <> 1 y
& nbsp & nbsp empezar
& nbsp & nbsp & nbsp & nbsp PutByte(byteCode,fh)
& nbsp & nbsp & nbsp & nbsp bytecode :=0
& nbsp & nbsp & nbsp & nbsp bytemask :=1
& nbsp & nbsp final
& nbsp & nbsp si nbytes > 0, entonces
& nbsp & nbsp empezar
& nbsp & nbsp & nbsp & nbsp FileWrite(fh,nbytes,1)
& nbsp & nbsp & nbsp & nbsp FileWrite(fh,buffer,nbytes)
& nbsp & nbsp & nbsp & nbsp nbytes :=0
& nbsp & nbsp final
fin
procedimiento ClearX
var
& nbsp & nbsp J : Integer
begin
& nbsp & nbsp cursize := minsize
& nbsp & nbsp nbits := cursize
& nbsp & nbsp curcode := c d d n 1
& nbsp & nbsp maxcode := 1 shl cursize
& nbsp & nbsp para J := 0 a HASHSIZE hacer codigos[J] := VACIO
fin
funcion 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 entonces di := 1 else di := Capacidad -i
& nbsp & nbsp while True do
& nbsp & nbsp empezar
& nbsp & nbsp & nbsp & nbsp si los codigos[i] = EMPTY then break
& nbsp & nbsp & nbsp & nbsp if ((prefijo[i] = pfx) y (sufijo[i] = (sfx)) luego se rompen
& nbsp & nbsp & nbsp & nbsp i := i - di
& nbsp & nbsp & nbsp & nbsp si i < 0, entonces i := i Capacidad
& nbsp & nbsp final
& nbsp & nbsp Resultado := i
fin
procedimiento EncodeScanLine(fh : Entero var buf : Pbyte npxls : Integer)
var
& nbsp & nbsp np,I : Integer
begin
& nbsp & nbsp np := 0
& nbsp & nbsp si no se Inicia, a continuacion,
& nbsp & nbsp empezar
& nbsp & nbsp & nbsp & nbsp strc := buf^
& nbsp & nbsp & nbsp & nbsp Inc(np) Inc(buf)
& nbsp & nbsp & nbsp & nbsp Comenzo a := True
& nbsp & nbsp final
& nbsp & nbsp mientras np < npxls hacer
& nbsp & nbsp empezar
& nbsp & nbsp & nbsp & nbsp // Si np = 3 then break
& nbsp & nbsp & nbsp & nbsp chrc := buf^
& nbsp & nbsp & nbsp & nbsp Inc(np) Inc(buf)
& nbsp & nbsp & nbsp & nbsp I := findstr(strc,chrc)
& nbsp & nbsp & nbsp & nbsp si los codigos[I] <> VACIO
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp strc := codigos de[I]
& nbsp & nbsp & nbsp & nbsp else
& nbsp & nbsp & nbsp & nbsp empezar
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp codigos[I] := curcode
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp prefijo[I] := strc
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp sufijo[I] := chrc
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp putcode(strc,fh)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp strc := chrc
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Inc(curcode)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp si curcode > maxcode, a continuacion,
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp empezar
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Inc(cursize)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp si cursize > maxsize, a continuacion,
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp empezar
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp putcode(clrc,fh)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp ClearX
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp final

& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp else
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp empezar
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp nbits := cursize
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp maxcode := maxcode shl 1
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp si cursize = maxsize, a continuacion, dec(maxcode)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp final
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp final
& nbsp & nbsp & nbsp & nbsp final
& nbsp & nbsp final
fin
procedimiento de Inicializacion(fh:integer)
var
& nbsp & nbsp banderas : Byte
begin
& nbsp & nbsp contador := 0
& nbsp & nbsp Comenzo a := False
& nbsp & nbsp tamaño := 8
& nbsp & nbsp nbytes := 0
& nbsp & nbsp nbits := 8
& nbsp & nbsp bytecode := 0
& nbsp & nbsp bytemask := 1
& nbsp & nbsp Capacidad de := HASHSIZE
& nbsp & nbsp minsize := 9
& nbsp & nbsp maxsize := 12
& nbsp & nbsp nroots := 1 shl 8
& nbsp & nbsp clrc := nroots
& nbsp & nbsp c d d n := clrc 1
& nbsp & nbsp MinLZWCodeSize := 8
& nbsp & nbsp ClearX
& nbsp & nbsp // Escribir el tipo de
& nbsp & nbsp FileWrite(fh,'GIF87a',6)
& nbsp & nbsp // Escribir el GIF de la pantalla descriptor
& nbsp & nbsp // Nota: la anchura > 255 es una palabra de dos bytes!!
& nbsp & nbsp FileWrite(fh,ImageWidth,2)
& nbsp & nbsp FileWrite(fh,ImageHeight,2)
& nbsp & nbsp banderas := $80 o ((gifcolordepth-1)shl 4) o (gifcolordepth-1)
& nbsp & nbsp FileWrite(fh,banderas,1)
& nbsp & nbsp FileWrite(fh,gifBGColor,1)
& nbsp & nbsp FileWrite(fh,gifPixAsp,1)
fin

procedimiento WriteGif(fh : integer)
var
& nbsp & nbsp F:TextFile
& nbsp & nbsp gifxLeft,gifyTop : palabra //Debe ser de 16 bits!!
& nbsp & nbsp banderas :Byte
& nbsp & nbsp K : Puntero
& nbsp & nbsp Prueba,J,M : Integer
& nbsp & nbsp scanLine, TempscanLine, Bits, PBits : PByte
begin
& nbsp & nbsp //Obtener la informacion del mapa de bits
& 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.los biplanos := 1
& nbsp & nbsp TBitmapInfo(K^).bmiHeader.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.biBitCount) 31)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp y No(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 probar
& nbsp & nbsp & nbsp & nbsp GetMem(Bits,TBitmapInfo(K^).bmiHeader.biSizeImage)
& nbsp & nbsp & nbsp & nbsp Prueba := GetDIBits(MapBM.El lienzo.Manejar,MapBM.Manejar,0,ImageHeight,Bits,TBitmapInfo(K^),DIB_RGB_COLORS)
& nbsp & nbsp & nbsp & nbsp Caso de que la Prueba > 0, entonces
& nbsp & nbsp & nbsp & nbsp empezar
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp J := 0 a 255
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp empezar
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp FileWrite(fh,TBitMapInfo(K^).bmiColors[J].rgbRed,1)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp FileWrite(fh,TBitMapInfo(K^).bmiColors[J].rgbGreen,1)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp FileWrite(fh,TBitMapInfo(K^).bmiColors[J].rgbBlue,1)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp final
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp //Escribir la Logica de la Imagen Descriptor
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp FileWrite(fh,gifLIDid,1)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp gifxLeft := 0 FileWrite(fh,gifxLeft,2) // Escribir X de la posicion de la imagen
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp gifyTop := 0 FileWrite(fh,gifyTop,2) // Escribir Y posicion de la imagen
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp FileWrite(fh,ImageWidth,2)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp FileWrite(fh,ImageHeight,2)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp banderas := 0 FileWrite(fh,banderas,1) //Escribir Local banderas 0=Ninguno
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp /Escritura/Min codigo LZW size = 8 (8 bits)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp MinLZWCodeSize := 8
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp FileWrite(fh,MinLZWCodesize,1)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp PutCode(clrc,fh)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp PBits := Bits
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Inc(Pbits,(ImageWidth *(ImageHeight -1)))
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp GetMem(scanLine,ImageWidth)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp TempscanLine := scanLine
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Para M := 0 a ImageHeight-1 hacer
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp empezar
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp FillChar(scanLine^,ImageWidth,0)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp mover(PBits^,scanLine^,ImageWidth)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp EncodeScanLine(fh,scanLine,ImageWidth)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp dic(scanLine,ImageWidth)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp & nbsp Dic(PBits,ImageWidth)
& nbsp & nbsp & nbsp & nbsp & nbsp & nbsp final
& nbsp & nbsp & nbsp & nbsp final
& nbsp & nbsp finalmente
& nbsp & nbsp & nbsp & nbsp scanLine := TempscanLine
& nbsp & nbsp & nbsp & nbsp FreeMem(scanLine,ImageWidth)
& nbsp & nbsp & nbsp & nbsp FreeMem(Bits,TBitMapInfo(K^).bmiHeader.biSizeImage)
& nbsp & nbsp & nbsp & nbsp FreeMem(K,(sizeof(TBitMapInfoHeader) 4 * gifncolors))
& nbsp & nbsp final
fin

funcion SaveAsGif(InputBM : TBitmap FName : string) : boolean
begin
& nbsp & nbsp ErrorMsg := '
& nbsp & nbsp Resultado := FALSE
& nbsp & nbsp MapBM := InputBM
& nbsp & nbsp ImageWidth := MapBM.Anchura
& nbsp & nbsp ImageHeight := MapBM.Altura
& nbsp & nbsp F := FileCreate(FName)
& nbsp & nbsp si F >= 0,
& nbsp & nbsp empezar
& nbsp & nbsp & nbsp & nbsp Inicializar(F)
& nbsp & nbsp & nbsp & nbsp WriteGif(F)
& nbsp & nbsp & nbsp & nbsp PutCode(strc,F)
& nbsp & nbsp & nbsp & nbsp PutCode(c d d n,F)
& nbsp & nbsp & nbsp & nbsp Flush(F)
& nbsp & nbsp & nbsp & nbsp FileWrite(F,BlockTerminator,1)
& nbsp & nbsp & nbsp & nbsp FileWrite(F,FileTrailer,1)
& nbsp & nbsp & nbsp & nbsp instrucciones fileclose(F)
& nbsp & nbsp & nbsp & nbsp si longitud(ErrorMsg) = 0 then Resultado := TRUE
& nbsp & nbsp final
fin
final.