Delphi common image format conversion technology (2)

Author: lyboy99
E-mail: lyboy99@sina.com
URL: http://hnh.126.com

We provide several common image format conversion methods and their conversion functions.
Hope to help you

1. Convert TXT to gif
2. Convert WMF Format to BMP format
3. Convert BMP format to WMF Format
4. tbitmaps to Windows regions
-----------------------------------------------------------------------
Convert TXT to gif
------------------------------------------------
Procedure txttogif (txt, filename: string );
VaR
Temp: tbitmap;
GIF: tgifimage;
Begin

Temp: = tbitmap. Create;
Try
Temp. Height: = 400;
Temp. Width: = 60;
Temp. Transparent: = true;
Temp. Canvas. Brush. Color: = colfondo. colorvalue;
Temp. Canvas. Font. Name: = fuente. fontname;
Temp. Canvas. Font. Color: = colfuente. colorvalue;
Temp. Canvas. textout (10, 10, txt );
Imagen. Picture. Assign (NiL );

GIF: = tgifimage. Create;
Try

GIF. Assign (temp );
// Save GIF
GIF. savetofile (filename );
Imagen. Picture. Assign (GIF );
Finally
GIF. Free;
End;

Finally

Temp. Destroy;
End;
End;
---------------------------------------------------------------------
2. Convert WMF Format to BMP format

--------------------------------------------------------------------
Procedure wmftobmp (ficherowmf, ficherobmp: string );
VaR
Metafile: tmetafile;
BMP: tbitmap;
Begin
Metafile: = tmetafile. Create;
{Create a temporal bitmap}
BMP: = tbitmap. Create;
{Load the Metafile}
Metafile. loadfromfile (ficherowmf );
{Draw the Metafile in bitmap's canvas}
With BMP do
Begin
Height: = Metafile. height;
Width: = Metafile. width;
Canvas. Draw (0, 0, Metafile );
{Save the BMP}
Savetofile (ficherobmp );
{Free BMP}
Free;
End;
{Free Metafile}
Metafile. Free;
End;

---------------------------------------------------------------------
3. Convert BMP format to WMF Format
---------------------------------------------------------------------
Procedure BMP towmf (BMP file, wmffile: string );
VaR
Metafile: tmetafile;
Mfcanvas: tmetafilecanvas;
BMP: tbitmap;
Begin
{Create temps}
Metafile: = tmetafile. Create;
BMP: = tbitmap. Create;
BMP. loadfromfile (BMP file );
{Igualemos Tama s}
{Equalizing sizes}
Metafile. Height: = BMP. height;
Metafile. Width: = BMP. width;
{Create a canvas for the Metafile}
Mfcanvas: = tmetafilecanvas. Create (Metafile, 0 );
With mfcanvas do
Begin
{Draw the BMP into canvas}
Draw (0, 0, BMP );
{Free the canvas}
Free;
End;
{Free the BMP}
BMP. Free;
With Metafile do
Begin
{Save the Metafile}
Savetofile (wmffile );
{Free it ...}
Free;
End;
End;

---------------------------------------------------------------------

4. tbitmaps to Windows regions
---------------------------------------------------------------------
Function bitmaptoregion (BMP: tbitmap; transparentcolor: tcolor = clblack;
Redtol: byte = 1; greentol: byte = 1; bluetol: byte = 1): hrgn;
Const
Allocunit = 100;
Type
Prectarray = ^ trectarray;
Trectarray = array [0 .. (maxint Div sizeof (trect)-1] of trect;
VaR
PR: prectarray;
H: hrgn;
Rgndata: prgndata;
LR, LG, LB, HR, Hg, HB: byte;
X, Y, x0: integer;
B: pbytearray;
Scanlineptr: pointer;
Scanlineinc: integer;
Maxrects: Cardinal;
Begin
Result: = 0;
{Keep on hand lowest and highest values for the "Transparent" pixels}
LR: = getrvalue (transparentcolor );
LG: = getgvalue (transparentcolor );
LB: = getbvalue (transparentcolor );
HR: = min ($ ff, LR + redtol );
Hg: = min ($ ff, LG + greentol );
HB: = min ($ ff, LB + bluetol );
 
BMP. pixelformat: = pf32bit;

Maxrects: = allocunit;
Getmem (rgndata, sizeof (rgndataheader) + (sizeof (trect) * maxrects ));
Try
With rgndata ^. RDH do
Begin
Dwsize: = sizeof (rgndataheader );
Itype: = rdh_rectangles;
Ncount: = 0;
Nrgnsize: = 0;
Setrect (rcbound, maxlong, maxlong, 0, 0 );
End;

Scanlineptr: = BMP. scanline [0];
Scanlineinc: = INTEGER (BMP. scanline [1])-INTEGER (scanlineptr );
For Y: = 0 to BMP. Height-1 do
Begin
X: = 0;
While x <BMP. Width do
Begin
X0: = X;
While x <BMP. Width do
Begin
B: = @ pbytearray (scanlineptr) [x * sizeof (trgbquad)];
// BGR-RGB: Windows 32bpp BMP s are made of bgra quads (not rgba)
If (B [2]> = LR) and (B [2] <= HR) and
(B [1]> = LG) and (B [1] <= Hg) and
(B [0]> = LB) and (B [0] <= Hb) then
Break; // pixel is transparent
INC (X );
End;
{Test to see if we have a non-transparent area in the image}
If X> x0 then
Begin
{Increase rgndata by allocunit rects if we exceeds maxrects}
If rgndata ^. RDH. ncount> = maxrects then
Begin
INC (maxrects, allocunit );
Reallocmem (rgndata, sizeof (rgndataheader) + (sizeof (trect) * maxrects ));
End;
{Add the rect (x0, Y)-(X, Y + 1) as a new visible area in the region}
PR: = @ rgndata ^. buffer; // buffer is an array of rects
With rgndata ^. RDH do
Begin
Setrect (PR [ncount], x0, Y, X, Y + 1 );
{Adjust the bound rectangle of the region if we are "out-of-bounds "}
If x0 <rcbound. Left Then rcbound. Left: = x0;
If y <rcbound. Top then rcbound. Top: = y;
If X> rcbound. Right then rcbound. Right: = X;
If y + 1> rcbound. Bottom then rcbound. Bottom: = Y + 1;
INC (ncount );
End;
End; // If x> x0


If rgndata ^. RDH. ncount = 2000 then
Begin
H: = extcreateregion (nil, sizeof (rgndataheader) + (sizeof (trect) * maxrects), rgndata ^ );
If result> 0 then
Begin // expand the current region
Combinergn (result, result, H, rgn_or );
Deleteobject (h );
End
Else // first region, assign it to result
Result: = h;
Rgndata ^. RDH. ncount: = 0;
Setrect (rgndata ^. RDH. rcbound, maxlong, maxlong, 0, 0 );
End;
INC (X );
End; // scan every sample byte of the image
INC (INTEGER (scanlineptr), scanlineinc );
End;
{Need to call excreateregion one more time because we cocould have left}
{A rgndata with less than 2000 rects, so it wasn' t yet created/combined}
H: = extcreateregion (nil, sizeof (rgndataheader) + (sizeof (trect) * maxrects), rgndata ^ );
If result> 0 then
Begin
Combinergn (result, result, H, rgn_or );
Deleteobject (h );
End
Else
Result: = h;
Finally
Freemem (rgndata, sizeof (rgndataheader) + (sizeof (trect) * maxrects ));
End;