Bmp2GIF

Umwandlung von BMP in GIF

Autor: John DIE GROSSE



{Hinweise:

1 Dieses dreht sich nur 256 Farben-Bitmaps!

2 Die einzige unterstützte Format ist GIF87a.

}



Einheit Bmp2Gif;



Schnittstelle



Anwendungen

SysUtils,

Unterricht

Fenster

Grafiken;



Funktion SaveAsGif (InputBM: TBitmap; FName: String): Boolean;



Ausführung



const

BlockTerminator: Byte = 0;

FileTrailer: Byte = $ 3B;

gifBGColor: Byte = 0;

gifPixAsp: Byte = 0;

gifcolordepth: Byte = 8; // 8 Bit = 256 Farben

gifncolors: integer = 256;

gifLIDid: Byte = $ 2C;

HASHSIZE: integer = 5101;

HASHBITS: integer = 4;

TABLSIZE: integer = 4096;

LEER: Integer = -1;



var

F: integer;

DBG: Textdatei;

MapBM: TBitmap;

Width, Imageheight: Integer;

Puffer: array [0..255] Byte;

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

Präfix: array [0..5101] of Integer;

Suffix Array [0..5101] of Integer;

nbytes, nbits, Größe, cursize, curcode, maxcode: Integer;

BitmapSizeImage: Integer;

Geöffnet: Boolean;

minsize, maxsize, nroots, Kapazität: Integer;

ENDC, CLRC: Integer;

MinLZWCodeSize: Byte;

Bytecode, Bytemaske: Integer;

Gegen: Integer;

STRC, CHRC: Integer;

ErrorMsg: string;



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



Start

Zähler: = Zähler + 1;

buffer [nbytes]: = B;

Inc (nbytes);

Wenn nbytes = 255 dann

Start

// Showmessage ("255");

Filewrite (fh, nbytes, 1);

Filewrite (FH, Puffer, nbytes);

nbytes: = 0;

Ende;

Ergebnis: = True;

Ende;



PutCode Arbeit (Code, FH: Integer): Boolean;



var

temp, n, Maske: Integer;



Start

Maske: = 1;

n: = nbits;

Wenn // nbits> 11 dann Showmessage ('nbits = 12');

während n> 0 do

Start

Dezember (n);

if ((Code und Maske 0)), dann Bytecode: = (Bytecode oder Bytemaske);

Bytemaske: Bytemaske SHL = 1;

if (Bytemaske> $ 80) dann

Start

Wenn PutByte (Bytecode, fh), dann

Start

Bytecode: = 0;

Bytemaske: = 1;

Ende;

Ende;

Maske: SHL = 1;

Ende;

Ergebnis: = True;

Ende;



Verfahren Flush (fh: Integer);



Start

Falls 1 werden Bytemaske

Start

PutByte (byteCode, fh);

Bytecode: = 0;

Bytemaske: = 1;

Ende;

wenn nbytes> 0, dann

Start

Filewrite (fh, nbytes, 1);

Filewrite (FH, Puffer, nbytes);

nbytes: = 0;

Ende;

Ende;



ClearX Verfahren;



var

J: Integer;



Start

cursize: = minsize;

nbits: = cursize;

curcode: ENDC + = 1;

maxcode: cursize SHL = 1;

für J: = 0 zu machen HASHSIZE Codes [J]: = LEER;

Ende;



Funktion Findstr (PFX, SFX: integer): integer;



var

i, der: Integer;



Start

i: = (SFX HASHBITS SHL) xor pfx;

wenn i = 0, dann: = 1 else: = Kapazität i;

do while True

Start

Wenn die Codes [i] = leer ist, dann brechen;

if ((Präfix [i] = PFX) und (Suffix [i] = SFX)) dann brechen;

i: = i - von;

wenn i <0, dann i: = i + Kapazität;

Ende;

Ergebnis: = i;

Ende;



Verfahren EncodeScanLine (fh: Integer; var buf: PBYTE; npxls: Integer);



var

np, I: Integer;



Start

NP: = 0;

wenn nicht, dann starten

Start

STRC: ^ = buf;

Inc (np); Inc (buf);

Geöffnet: = true;

Ende;

während np
Start

// Wenn np = 3 dann brechen;

CHRC: ^ = buf;

Inc (np); Inc (buf);

I: = Findstr (STRC, CHRC);

wenn die Codes [I] leer ist, dann

STRC: = Codes [I]

andere

Start

Codes [I]: = curcode;

Präfix [I]: = STRC;

Suffix [I]: = CHRC;

putcode (STRC, fh);

STRC: = CHRC;

Inc (curcode);

wenn curcode> maxcode dann

Start

Inc (cursize);

wenn cursize> maxsize dann

Start

putcode (CLRC, fh);

ClearX;

Ende

andere

Start

nbits: = cursize;

maxcode: maxcode SHL = 1;

wenn cursize = maxsize dann dez (maxcode);

Ende;

Ende;

Ende;

Ende;

Ende;



Initialisierung (fh: integer);



var

Fahnen: Byte;



Start

Zähler: = 0;

Geöffnet: = false;

Größe: = 8;

nbytes: = 0;

nbits: = 8;

Bytecode: = 0;

Bytemaske: = 1;

Kapazität: = HASHSIZE;

minsize: = 9;

maxsize: = 12;

nroots: 1 SHL = 8;

CLRC: = nroots;

ENDC: CLRC + = 1;

MinLZWCodeSize: = 8;

ClearX;

Schreiben // Typ

Filewrite (fh, 'GIF87a', 6);

// Schreiben Sie die Descriptor-Display GIF

// Hinweis: Breite> 255 ist ein Zwei-Byte-Wort !!

Filewrite (fh, Width, 2);

Filewrite (fh, Imageheight, 2);

Fahnen: = $ 80 oder ((gifcolordepth-1) SHL 4) oder (gifcolordepth-1);

Filewrite (fh, Fahnen, 1);

Filewrite (fh, gifBGColor, 1);

Filewrite (fh, gifPixAsp, 1);

Ende;







Verfahren WriteGif (fh: integer);



var

F: Textdatei;

gifxLeft, gifyTop: word; // Muss 16-Bit sein !!

Fahnen: Byte;

K: Pointer;

Test, J, M: Integer;

Scanline, TempscanLine, Bits, PBITS: PBYTE;



Start

// Wir bekommen die Informationen von Bitmap

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

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

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

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

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)

und (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;.

versuchen

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

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

Wenn Test> 0, dann

Start

für J: = 0 bis 255 zu tun

Start

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

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

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

Ende;

// Schreiben Sie den Logical Bild Descriptor

Filewrite (fh, gifLIDid, 1);

gifxLeft: = 0; Filewrite (fh, gifxLeft, 2); Schreiben // Position X Bild

gifyTop: = 0; Filewrite (fh, gifyTop, 2); // Typing Position Y der Bild

Filewrite (fh, Width, 2);

Filewrite (fh, Imageheight, 2);

Fahnen: = 0; Filewrite (fh, Fahnen, 1); Schreib // lokale Merker 0 = keine

Schreiben // Min LZW Codegröße = 8 (8-bit)

MinLZWCodeSize: = 8;

Filewrite (fh, MinLZWCodesize, 1);

PutCode (CLRC, fh);

PBITS: = bit;

Inc (PBITS (Width * (Height -1)));

GetMem (Scanline, Imagewidth);

TempscanLine: = Scanline;

Für M: = 0 bis Height-1 zu tun

Start

FillChar (Scanline ^, Width, 0);

move (PBITS ^ ^ Scanline, Imagewidth);

EncodeScanLine (fh, Scanline, Imagewidth);

Mai (Scanline, Imagewidth);

Dezember (PBITS, Width);

Ende;

Ende;

endlich

Scanline: = TempscanLine;

FreeMem (Scanline, Imagewidth);

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

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

Ende;

Ende;





Funktion SaveAsGif (InputBM: TBitmap; FName: String): Boolean;



Start

ErrorMsg: = '';

Ergebnis: = false;

MapBM: = InputBM;

Width: = MapBM.Width;

Height: = MapBM.Height;

F: = Filecreate (FName);

wenn F> = 0, dann

Start

Initialisieren (F);

WriteGif (F);

PutCode (STRC, F);

PutCode (ENDC, F);

Flush (F);

Filewrite (F, BlockTerminator, 1);

Filewrite (F, FileTrailer, 1);

File (F);

wenn die Länge (ErrorMsg) = 0, dann Ergebnis: = TRUE;

Ende;

Ende;



Ende.

(0)
(0)

Kommentare - 0

Keine Kommentare

Fügen Sie einen Kommentar

smile smile smile smile smile smile smile smile
smile smile smile smile smile smile smile smile
smile smile smile smile smile smile smile smile
smile smile smile smile
Zeichen übrig: 3000
captcha