Delphi常见图象格式转换技术

admin管理员组

文章数量:1534196

2024年1月13日发(作者：)

Delphi常见图象格式转换技术

e : ICO图标转换BMP格式

English :(Conversion from ICO to BMP)

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

var

Icon : TIcon;

Bitmap : TBitmap;

begin

Icon := ;

Bitmap := ;

omFile('c:');

:= ;

:= ;

(0, 0, Icon );

File('c:');

;

;

===================================

e: 32x32 BMP格式图象转换为 ICO格式

English :32x32 bit Bitmaps to ICO's

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

unit main;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls,

Forms,Dialogs,ExtCtrls, StdCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

Image1: TImage;

Image2: TImage;

procedure Button1Click(Sender: TObject);

procedure FormCreate(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure 1Click(Sender: TObject);

var winDC, srcdc, destdc : HDC;

oldBitmap : HBitmap;

iinfo : TICONINFO;

begin

GetIconInfo(, iinfo);

WinDC := getDC(handle);

srcDC := CreateCompatibleDC(WinDC);

destDC := CreateCompatibleDC(WinDC);

oldBitmap := SelectObject(destDC, or);

oldBitmap := SelectObject(srcDC, k);

BitBlt(destdc, 0, 0, ,

,

srcdc, 0, 0, SRCPAINT);

:= SelectObject(destDC, oldBitmap);

DeleteDC(destDC);

DeleteDC(srcDC);

DeleteDC(WinDC);

file(ExtractFilePath(e)

+ '');

end;

procedure eate(Sender: TObject);

begin

omfile('c:');

end;

end.

==================================================================

3. Chinese:转换BMP->JPEG文件格式

Englsh:convert the bitmap into a JPEG file format

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

var

MyJpeg: TJpegImage;

Image1: TImage;

begin

Image1:= ;

MyJpeg:= ;

omFile(''); // 读取Bitmap文件

();

object

File(''); //保存JPEG

end;

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

转换为BMP函数

procedure Jpg2Bmp(const source,dest:string);

var

MyJpeg: TJpegImage;

bmp: Tbitmap;

begin

bmp:=;

MyJpeg:= ;

try

omFile(source);

(myjpeg);

File(dest);

finally

;

;

end;

end;

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

转换为JPEG文件格式函数

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

procedure Bmp2Jpg(const source,dest:string;const scale:byte);

var

MyJpeg: TJpegImage;

Image1: TImage;

begin

Image1:= (application);

MyJpeg:= ;

try

omFile(source);

();

ssionQuality:=scale;

ss;

File(dest);

finally

;

;

end;

end;

TxT 转换为 GIF

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

procedure TxtToGif (txt, FileName: String);

var

temp: TBitmap;

GIF : TGIFImage;

begin

temp:=;

try

:=400;

:=60;

arent:=True;

:=alue;

:=me;

:=alue;

t (10,10,txt);

(nil);

GIF := ;

try

(Temp);

//保存 GIF

File(FileName);

(GIF);

finally

;

end;

Finally

y;

End;

end;

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

格式转换为BMP格式

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

procedure WmfToBmp(FicheroWmf,FicheroBmp:string);

var

Metafile:TMetafile;

Bmp:TBitmap;

begin

Metafile:=;

{Create a Temporal Bitmap}

Bmp:=;

{Load the Metafile}

omFile(FicheroWmf);

{Draw the metafile in Bitmap's canvas}

with Bmp do

begin

Height:=;

Width:=;

(0,0,MetaFile);

{Save the BMP}

SaveToFile(FicheroBmp);

{Free BMP}

Free;

end;

{Free Metafile}

;

end;

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

格式转换为WMF格式

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

procedure BmpToWmf (BmpFile,Wmffile:string);

var

MetaFile : TMetaFile;

MFCanvas : TMetaFileCanvas;

BMP : TBitmap;

begin

{Create temps}

MetaFile := ;

BMP := ;

omFile(BmpFile);

{Igualemos tama駉s}

{Equalizing sizes}

:= ;

:= ;

{Create a canvas for the Metafile}

MFCanvas:=(MetaFile, 0);

with MFCanvas do

begin

{Draw the BMP into canvas}

Draw(0, 0, BMP);

{Free the Canvas}

Free;

end;

{Free the BMP}

;

with MetaFile do

begin

{Save the Metafile}

SaveToFile(WmfFile);

{}

Free;

end;

end;

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

ps 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);

ormat := 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 := ne[0];

ScanLineInc := Integer(ne[1]) - Integer(ScanLinePtr);

for y := 0 to - 1 do

begin

x := 0;

while x < do

begin

x0 := x;

while x < do

begin

b := @PByteArray(ScanLinePtr)[x*SizeOf(TRGBQuad)];

// BGR-RGB: Windows 32bpp BMPs 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^. >= maxRects then

begin

lb := GetBValue(TransparentColor);

hr := Min($ff, lr + RedTol);

hg := Min($ff, lg + GreenTol);

hb := Min($ff, lb + BlueTol);

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 < then := x0;

if y < then := y;

if x > then := x;

if y+1 > then := y+1;

Inc(nCount);

end;

end; // if x > x0

if RgnData^. = 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^. := 0;

SetRect(RgnData^.d, 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 could 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;

本文标签： 格式转换读取文件