графический конвертер на Delphi — Помогите пожалуйста сделать программу конвертер графических файлов. У ... (страница 1 из 2)

1. Конвертирование BMP в EMF.
Следующая несложная процедура конвертирует bmp-файл SourceFileName в emf-файл и располагает его в той же директории, что и исходный файл.
function bmp2emf( const SourceFileName: TFileName): Boolean;
var Metafile: TMetafile; MetaCanvas: TMetafileCanvas; Bitmap: TBitmap;
begin
Metafile := TMetaFile.Create;
try
Bitmap := TBitmap.Create;
try
Bitmap.LoadFromFile(SourceFileName);
Metafile.Height := Bitmap.Height;
Metafile.Width := Bitmap.Width;
MetaCanvas := TMetafileCanvas.Create(Metafile, 0);
try
MetaCanvas.Draw(0, 0, Bitmap);
finally
MetaCanvas.Free;
end;
finally
Bitmap.Free;
end;
Metafile.SaveToFile(ChangeFileExt(SourceFileName, '.emf'));
finally
Metafile.Free;
end;
end;
Пример вызова:

procedure TForm1.Button1Click(Sender: TObject);
begin
bmp2emf( 'C:\TestBitmap.bmp' );
end;
2. Конвертирование BMP в JPG.
Данная процедура выполняет такое конвертирование:
procedure TfrmMain.ConvertBMP2JPEG;
var
jpgImg: TJPEGImage;
begin
chrtOutputSingle.CopyToClipboardBitmap;
Image1.Picture.Bitmap.LoadFromClipboardFormat(cf_BitMap, ClipBoard.GetAsHandle(cf_Bitmap), 0);
jpgImg := TJPEGImage.Create;
jpgImg.Assign(Image1.Picture.Bitmap);
jpgImg.SaveToFile('TChartExample.jpg');
end;
В Uses необходимо добавить модули Jpeg и Clipbrd. В данном примере chrtOutputSingle - это объект TChart (страница Additional). Перед вызовом функции в буфере обмена должен находиться объект типа TBitmap.
3. Конвертирование BMP в WMF.
Данное конвертирование также не составляет труда:
procedure ConvertBMP2WMF (const BMPFileName, WMFFileName: TFileName);
var
MetaFile : TMetafile;
Bitmap : TBitmap;
begin
Metafile := TMetaFile.Create;
Bitmap := TBitmap.Create;
try
Bitmap.LoadFromFile(BMPFileName);
with MetaFile do
begin
Height := Bitmap.Height;
Width := Bitmap.Width;
Canvas.Draw( 0 , 0 , Bitmap);
SaveToFile(WMFFileName);
end;
finally
Bitmap.Free;
MetaFile.Free;
end;
end;
Пример использования: ConvertBMP2WMF( 'c:\mypic.bmp' , 'c:\mypic.wmf').
4. Обратное конвертирование: WMF в BMP.
Обратное конвертирование мало чем отличается от предыдущего:
procedure ConvertWMF2BMP (const WMFFileName, BMPFileName: TFileName);
var
MetaFile : TMetafile;
Bitmap : TBitmap;
begin
Metafile := TMetaFile.Create;
Bitmap := TBitmap.Create;
try
MetaFile.LoadFromFile(WMFFileName);
with Bitmap do
begin
Height := Metafile.Height;
Width := Metafile.Width;
Canvas.Draw( 0 , 0 , MetaFile);
SaveToFile(BMPFileName);
end;
finally
Bitmap.Free;
MetaFile.Free;
end;
end;
Использование: ConvertWMF2BMP('c:\mypic.wmf' , 'c:\mypic.bmp').

5. Конвертирование BMP в DIB.
Допустим, что файл хранится в формате BMP. Нужно его преобразовать в DIB и отобразить. Итак... Это не тривиально, но помочь нам смогут функции GetDIBSizes и GetDIB из модуля GRAPHICS.PAS. Приведу две процедуры: одну для создания DIB из TBitmap и вторую для его освобождения:
{ Преобразование TBitmap в DIB }

procedure BitmapToDIB(Bitmap: TBitmap;
var BitmapInfo: PBitmapInfo;
var InfoSize: integer;
var Bits: pointer;
var BitsSize: longint);
begin
BitmapInfo := nil ;
InfoSize := 0;
Bits := nil;
BitsSize := 0;
if not Bitmap.Empty then
try
GetDIBSizes(Bitmap.Handle, InfoSize, BitsSize);
GetMem(BitmapInfo, InfoSize);
Bits := GlobalAllocPtr(GMEM_MOVEABLE, BitsSize);
if Bits = nil then
raise
EOutOfMemory.Create( 'Не хватает памяти для пикселей изображения' );
if not GetDIB(Bitmap.Handle, Bitmap.Palette, BitmapInfo^, Bits^) then
raise Exception.Create( 'Не могу создать DIB' );
except
if BitmapInfo <> nil then
FreeMem(BitmapInfo, InfoSize);
if Bits <> nil then
GlobalFreePtr(Bits);
BitmapInfo := nil;
Bits := nil;
raise ;
end;
end;

{ используйте FreeDIB для освобождения информации об изображении и битовых указателей }

procedure FreeDIB(BitmapInfo: PBitmapInfo;
InfoSize: integer;
Bits: pointer;
BitsSize: longint);
begin
if BitmapInfo <> nil then
FreeMem(BitmapInfo, InfoSize);
if Bits <> nil then
GlobalFreePtr(Bits);
end;
Создаем форму с TImage Image1 и загружаем в него 256-цветное изображение, затем рядом размещаем TPaintBox. Добавляем следующие строчки к private-объявлениям вашей формы:

{ Private declarations }
BitmapInfo : PBitmapInfo;
InfoSize : integer;
Bits : pointer;
BitsSize : longint;

Создаем нижеприведенные обработчики событий, которые демонстрируют процесс отрисовки DIB:

procedure TForm1.FormCreate(Sender: TObject);
begin
BitmapToDIB(Image1.Picture.Bitmap, BitmapInfo, InfoSize,
Bits, BitsSize);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
FreeDIB(BitmapInfo, InfoSize, Bits, BitsSize);
end;

procedure TForm1.PaintBox1Paint(Sender: TObject);
var
OldPalette: HPalette;
begin
if Assigned(BitmapInfo) and Assigned(Bits) then
with BitmapInfo^.bmiHeader, PaintBox1.Canvas do
begin
OldPalette := SelectPalette(Handle,
Image1.Picture.Bitmap.Palette,
false);
try
RealizePalette(Handle);
StretchDIBits(Handle, 0 , 0 , PaintBox1.Width, PaintBox1.Height,
0 , 0 , biWidth, biHeight, Bits,
BitmapInfo^, DIB_RGB_COLORS,
SRCCOPY);
finally
SelectPalette(Handle, OldPalette, true);
end;
end;
end;

Это поможет вам сделать первый шаг. Единственное, что вы можете захотеть, это создать собственный HPalette на основе DIB, вместо использования TBitmap и своей палитры. Функция с именемPaletteFromW3DIB из GRAPHICS.PAS как раз этим и занимается, но она не объявлена в качестве экспортируемой, поэтому для ее использования необходимо скопировать ее исходный код и вставить его в модуль.
6. Конвертирование BMP в ICO.
Вам необходимо создать два битмапа, битмап маски (назовём его "AND" bitmap) и битмап изображения (назовём его XOR bitmap). Вы можете пропустить обработчики для "AND" и "XOR" битмапов в Windows API функции CreateIconIndirect() и использовать обработчик возвращённой иконки в Вашем приложении.
procedure TForm1.Button1Click(Sender: TObject);
var
IconSizeX : integer;
IconSizeY : integer;
AndMask : TBitmap;
XOrMask : TBitmap;
IconInfo : TIconInfo;
Icon : TIcon;
begin
{Получаем размер иконки}
IconSizeX := GetSystemMetrics(SM_CXICON);
IconSizeY := GetSystemMetrics(SM_CYICON);

{Создаём маску "And"}
AndMask := TBitmap.Create;
AndMask.Monochrome := true;
AndMask.Width := IconSizeX;
AndMask.Height := IconSizeY;

{Рисуем на маске "And"}
AndMask.Canvas.Brush.Color := clWhite;
AndMask.Canvas.FillRect(Rect( 0 , 0 , IconSizeX, IconSizeY));
AndMask.Canvas.Brush.Color := clBlack;
AndMask.Canvas.Ellipse( 4 , 4 , IconSizeX - 4 , IconSizeY - 4 );

{Рисуем для теста}
Form1.Canvas.Draw(IconSizeX * 2 , IconSizeY, AndMask);

{Создаём маску "XOr"}
XOrMask := TBitmap.Create;
XOrMask.Width := IconSizeX;
XOrMask.Height := IconSizeY;

{Рисуем на маске "XOr"}
XOrMask.Canvas.Brush.Color := ClBlack;
XOrMask.Canvas.FillRect(Rect( 0 , 0 , IconSizeX, IconSizeY));
XOrMask.Canvas.Pen.Color := clRed;
XOrMask.Canvas.Brush.Color := clRed;
XOrMask.Canvas.Ellipse( 4 , 4 , IconSizeX - 4 , IconSizeY - 4 );

{Рисуем в качестве теста}
Form1.Canvas.Draw(IconSizeX * 4 , IconSizeY, XOrMask);

{Создаём иконку}
Icon := TIcon.Create;
IconInfo.fIcon := true;
IconInfo.xHotspot := 0 ;
IconInfo.yHotspot := 0 ;
IconInfo.hbmMask := AndMask.Handle;
IconInfo.hbmColor := XOrMask.Handle;
Icon.Handle := CreateIconIndirect(IconInfo);

{Уничтожаем временные битмапы}
AndMask.Free;
XOrMask.Free;

{Рисуем в качестве теста}
Form1.Canvas.Draw(IconSizeX * 6 , IconSizeY, Icon);

{Объявляем иконку в качестве иконки приложения}
Application.Icon := Icon;

{генерируем перерисовку}
InvalidateRect(Application.Handle, nil , true);

{Освобождаем иконку}
Icon.Free;
end ;
Способ преобразования изображения размером 32x32 в иконку:

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 TForm1.Button1Click(Sender: TObject);
var
winDC, srcdc, destdc: HDC;

oldBitmap: HBitmap;
iinfo: TICONINFO;
begin

GetIconInfo(Image1.Picture.Icon.Handle, iinfo);

WinDC := getDC(handle);
srcDC := CreateCompatibleDC(WinDC);
destDC := CreateCompatibleDC(WinDC);
oldBitmap := SelectObject(destDC, iinfo.hbmColor);
oldBitmap := SelectObject(srcDC, iinfo.hbmMask);

BitBlt(destdc, 0 , 0 , Image1.picture.icon.width,
Image1.picture.icon.height,
srcdc, 0 , 0 , SRCPAINT);
Image2.picture.bitmap.handle := SelectObject(destDC, oldBitmap);
DeleteDC(destDC);
DeleteDC(srcDC);
DeleteDC(WinDC);

image2.Picture.Bitmap.savetofile(ExtractFilePath(Application.ExeName)
+ 'myfile.bmp' );
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
image1.picture.icon.loadfromfile( 'c:\myicon.ico' );
end;

end.
7. Конвертирование BMP в RTF.
Да, и такое тоже возможно. Вот так например:
function BitmapToRTF(pict: TBitmap): string ;
var
bi, bb, rtf: string ;
bis, bbs: Cardinal;
achar: ShortString;
hexpict: string ;
I: Integer;
begin
GetDIBSizes(pict.Handle, bis, bbs);
SetLength(bi, bis);
SetLength(bb, bbs);
GetDIB(pict.Handle, pict.Palette, PChar(bi)^, PChar(bb)^);
rtf := '{\rtf1 {\pict\dibitmap0 ' ;
SetLength(hexpict, (Length(bb) + Length(bi)) * 2 );
I := 2 ;
for bis := 1 to Length(bi) do
begin
achar := IntToHex(Integer(bi[bis]), 2 );
hexpict[I - 1] := achar[ 1 ];
hexpict[I] := achar[ 2 ];
Inc(I, 2 );
end ;
for bbs := 1 to Length(bb) do
begin
achar := IntToHex(Integer(bb[bbs]), 2 );
hexpict[I - 1] := achar[ 1 ];
hexpict[I] := achar[ 2 ];
Inc(I, 2);
end ;
rtf := rtf + hexpict + ' }}';
Result := rtf;
end;
8. Конвертирование CUR в BMP.
Преобразование курсора в bitmap:
procedure TForm1.Button1Click(Sender: TObject);
var
hCursor: LongInt;
Bitmap: TBitmap;
begin
Bitmap := TBitmap.Create;
Bitmap.Width := 32 ;
Bitmap.Height := 32 ;
hCursor := LoadCursorFromFile( 'test.cur' );
DrawIcon(Bitmap.Canvas.Handle, 0 , 0 , hCursor);
Bitmap.SaveToFile( 'test.bmp' );
Bitmap.Free;
end;
9. Конвертирование ICO в BMP.
Var
Icon : TIcon;
Bitmap : TBitmap;
begin
Icon := TIcon.Create;
Bitmap := TBitmap.Create;
Icon.LoadFromFile( 'c:\picture.ico' );
Bitmap.Width := Icon.Width;
Bitmap.Height := Icon.Height;
Bitmap.Canvas.Draw( 0 , 0 , Icon);
Bitmap.SaveToFile( 'c:\picture.bmp' );
Icon.Free;
Bitmap.Free;
end;
Вариант 2:
procedure TIconShow.FileListBox1Click(Sender: TObject);
var

MyIcon: TIcon;
MyBitMap: TBitmap;
begin

MyIcon := TIcon.Create;
MyBitMap := TBitmap.Create;

try
{ получаем имя файла и связанную с ним иконку}
strFileName := FileListBox1.Items[FileListBox1.ItemIndex];
StrPCopy(cStrFileName, strFileName);
MyIcon.Handle := ExtractIcon(hInstance, cStrFileName, 0 );

{ рисуем иконку на bitmap в speedbutton }
SpeedButton1.Glyph := MyBitMap;
SpeedButton1.Glyph.Width := MyIcon.Width;
SpeedButton1.Glyph.Height := MyIcon.Height;
SpeedButton1.Glyph.Canvas.Draw( 0 , 0 , MyIcon);

SpeedButton1.Hint := strFileName;

finally
MyIcon.Free;
MyBitMap.Free;
end;
end;
Чтобы преобразовать Icon в Bitmap, используйте TImageList. Для обратного преобразования замените метод AddIcon на Add, и метод GetBitmap на GetIcon.

function Icon2Bitmap(Icon: TIcon): TBitmap;
begin
with TImageList.Create ( nil ) do
begin
AddIcon (Icon);
Result := TBitmap.Create;
GetBitmap ( 0 , Result);
Free;
end;
end;
10. Конвертирование JPG в BMP.
uses
JPEG;

procedure JPEGtoBMP( const FileName: TFileName);
var
jpeg: TJPEGImage;
bmp: TBitmap;
begin
jpeg := TJPEGImage.Create;
try
jpeg.CompressionQuality := 100 ; {Default Value}
jpeg.LoadFromFile(FileName);
bmp := TBitmap.Create;
try
bmp.Assign(jpeg);
bmp.SaveTofile(ChangeFileExt(FileName, '.bmp' ));
finally
bmp.Free;
end;
finally
jpeg.Free;
end;
end;