Za pomocą dodatkowej funkcji można dokonac konwersji tekstu z UTF8 na ANSI i z ANSI na UTF8
function Utf8ToAnsi(x: string): ansistring;
{ Function that recieves UTF8 string and converts to ansi string }
var i: integer; b1, b2: byte;
begin
Result := x; i := 1; while i <= Length(Result) do begin
if (ord(Result[i]) and $80) < > 0 then begin
b1 := ord(Result[i]); b2 := ord(Result[i + 1]);
if (b1 and $F0) < > $C0 then Result[i] := #128
else begin
Result[i] := Chr((b1 shl 6) or (b2 and $3F));
Delete(Result, i + 1, 1);
end; end; inc(i);
end; end;
function AnsiToUtf8(x: ansistring): string;
{ Function that recieves ansi string and converts to UTF8 string }
var i: integer; b1, b2: byte;
begin
Result := x;
for i := Length(Result) downto 1 do
if Result[i] >= #127 then begin
b1 := $C0 or (ord(Result[i]) shr 6); b2 := $80 or (ord(Result[i]) and $3F);
Result[i] := chr(b1); Insert(chr(b2), Result, i + 1);
end; end;
Zamienia np. 1272 na słowa ''tysiąc dwieście siedemdziesiąt dwa''. Maksymalnie liczba 7 cyfrowa i 3 miejsca po przecinku
unit Inwordsu;
interface
uses SysUtils,Dialogs;
function InWords(const nNumber:Extended):String;
implementation
function InWords(const nNumber:Extended):String;
const
aUnits:array[0..9] of string=('','one ', 'two ', 'three ', 'four ', 'five ', 'six ', 'seven ','eight ','nine ');
//Local function to convert decimal portion
function cDecimal(const cDecDitxt:string):String;
var len,x,n:Integer; nNumber:string[17];
begin
result:=''; nNumber:=cDecDitxt; //cut off Zeros to the right
while copy(nNumber,length(nNumber),1)='0' do
delete(nNumber,length(nNumber),1); len:=length(nNumber); //No need to convert if it is all zeros
if len=0 then exit; //Start conversion !
for x:=1 to len do begin
n:=strToint(copy(nNumber,x,1));
if n=0 then result:=result+'zero ' else result:=result+aUnits[n];
end; if result < > then result:=' decimal '+trim(result);
end;
//Local function to convert the whole number portion
function Num2EngWords(const nNumber, nWordIndex:integer):String;
const
aLargeNumWords:array[0..5] of string=('','thousand, ','million, ', 'billion, ', 'trillion, ', 'quadrillion, ');
aTens:array[0..8] of string=('','twenty', 'thirty', 'forty', 'fifty', 'sixty', 'seventy', 'eighty', 'ninety');
aTwenties:array[10..19] of string=('ten ','eleven ', 'twelve ', 'thirteen ', 'fourteen ', 'fifteen ', 'sixteen ', 'seventeen ',
'eighteen ', 'nineteen ');
var nQtnt,nNum,nMod:Integer;
begin
result:=''; if nNumber < 1 then exit; nNum:=nNumber;
if nNumber >99 then begin //Pick up hundreds and leave others
nQtnt:=nNum div 100; nNum:=nNum mod 100;
result:=aUnits[nQtnt]+'hundred and '; end;
case nNum of
1..9: result:= result+aUnits[nNum]; {one to nine}
10..19: result:= result+aTwenties[nNum]; {ten to nineteen}
20..99: begin
nQtnt:=nNum div 10; nMod:=nNum mod 10;
result:= result+aTens[nQtnt-1]; {digit at tenth place}
if nMod < > 0 then result:= result+'-'+aUnits[nMod] {digit at unit place}
else result:= result+' ';
end else if result < > '' then result:=copy(result,1,length(result)-4);
end; result:= result+aLargeNumWords[nWordIndex]; {add thousand, million etc...}
end;
var nNum,nIndex:Integer; cStr,cDec:String; lNegative:Boolean;
begin
result:=''; if (nNumber > 999999999999999999.0) then begin
showmessage('Sorry this is too large ! larger than the budget of the whole world !!');
exit;
end;
str(nNumber:34:15,cStr); lNegative:=False;
nIndex:=pos('-',cStr); {having - sign is negative}
if nIndex > 0 then begin
lNegative:=True;
cStr:=copy(cStr,nIndex+1,length(cStr)-nIndex); {trim off minus sign}
end;
while cStr[1]=' ' do {trim of spaces}
delete(cStr,1,1); nIndex:=pos('.',cStr); {decimal position}
if nIndex=0 then nIndex:=length(cStr)+1; {if no decimal it must be at the far right}
cDec:=copy(cStr,nIndex+1,length(cStr)-nIndex); {digits after decimal point}
cStr:=copy(cStr,1,nIndex-1); {digits before decimal point}
nIndex:=0; {index to point the words thousand, million etc.}
nNum:=length(cStr); {count of digits}
while nNum >0 do begin
if nNum < 3 then begin
result:=Num2EngWords(strToInt(copy(cStr,1,nNum)),nIndex)+result;
cstr:=''; {less than 3 digits means finished}
end else begin
result:=Num2EngWords(strToInt(copy(cStr,nNum-2,3)),nIndex)+result;
cStr:=copy(cStr,1,nNum-3); {cut off three rightmost digits}
end;
nNum:=length(cStr); {remaining number of digits}
inc(nIndex); {increase the large number's word index}
end;
result:=trim(result)+cDecimal(cDec)+'.'; {finished, add a full stop}
if lNegative then result:='minus '+result; {if the number is negative add "minus" at first}
end;
//Zrobić w programie:
//label1.caption:=InWords(nNum); {nInt:Integer or nInt:longint}
//label2.caption:=InWords(nint);
end.
function IntToBin(Value: LongInt;Size: Integer): String;
var i: Integer;
begin
Result:=''; for i:=Size downto 0 do begin
if Value and (1 shl i) < > 0 then Result:=Result+'1';
else Result:=Result+'0';
end; end;
function BinToInt(Value: String): LongInt;
var i,Size: Integer;
begin
Result:=0; Size:=Length(Value);
for i:=Size downto 0 do begin
if Copy(Value,i,1)='1' then Result:=Result+(1 shl i);
end; end;
Policzy to poniższa funkcja:
Function Seps(As_Arg: Char): Boolean;
Begin
Seps := As_Arg In [#0..#$1F, ' ', '.', ',', '?', ':', ';', '(',')', '/', '\'];
End;
Function Word_Count(CText: String): Longint;
Var Ix: Word; Work_Count: Longint;
Begin
Work_Count := 0; Ix := 1;
While Ix <= Length(Wc_Arg) Do Begin
While (Ix < = Length(Wc_Arg)) And Seps(Wc_Arg[Ix]) Do Inc(Ix);
If Ix < = Length(Wc_Arg) Then Begin
Inc(Work_Count); While (Ix < = Length(WC_Arg)) And (Not Seps(WC_Arg[Ix])) Do Inc(Ix);
End; End; Word_Count := Work_Count;
End;
Nie zapomnij wstawić w uses modułu ''math''
function HEX_to_DEC(Value: string): Int64;
var Lunghezza, i : Byte; ValoreDEC: Int64; Value2 : string;
begin
Result := 0; for i := 1 to Length( Value ) do
Value2 := Value[ i ] + Value2; Value := Value2;
for Lunghezza := Length(Value) - 1 downto 0 do begin
ValoreDEC := Pos(Value[Lunghezza +1],'0123456789ABCDEF')-1;
if (ValoreDEC < 0 ) or (ValoreDEC > 15) then begin
ShowMessage('Valore inserito non valido');
Result := 0; exit; end;
Result := Result + ValoreDEC shl (4 * Lunghezza);
end; end;
Jeżeli zamiast procedur ze stringami potrzebna jest taka funkcja to zrobić je tak:
interface
function str_(const x : double) : string; overload;
function str_(const x : longint) : string; overload;
function str_(const x : longword) : string; overload;
function str_(const x : boolean) : string; overload;
implementation
function str_(const x: double ) : string; overload;
var aux : string;
begin
str(x:8:2,aux); str_:=aux;
end;
function str_(const x: longint ) : string; overload;
var aux : string;
begin
str(x:8,aux); str_:=aux;
end;
function str_(const x: longword) : string; overload;
var aux : string;
begin
str(x:8,aux); str_:=aux;
end;
function str_(const x: boolean ) : string; overload;
begin
if x then str_:='true' else str_:='false';
end;
procedure BinToHex(Buffer, Text: PChar; BufSize: Integer);
function HexToBin(Text, Buffer: PChar; BufSize: Integer): Integer;
procedure TForm1.Button1Click(Sender: TObject);
var E: Extended; //Make sure there is room for null terminator
Buf: array[0..SizeOf(Extended) * 2] of Char;
begin
E := Pi; Label1.Caption := Format('E starts off as %.15f', [E]);
BinToHex(@E, Buf, SizeOf(E));
//Slot in the null terminator for the PChar, so we can display it easily
Buf[SizeOf(Buf) - 1] := #0;
Label2.Caption := Format('As text, the binary contents of E look like %s', [Buf]);
//Translate just the characters, not the null terminator
HexToBin(Buf, @E, SizeOf(Buf) - 1);
Label3.Caption := Format('Back from text to binary, E is now %.15f', [E]);
end;
Z pomocą delphi można w pełni przekształcić formatów graficznych z jednego do drugiego. Do obrazowania, jest kilka predefiniowanych klas. Weźmy pod uwagę niektóre wersje konwersji.
Poniższa procedura konwertuje plik BMP do WMF według nazwy Sourcefilename i umieszcza go w tym samym katalogu co plik oryginalny.
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;
Przykład wywołania:
procedure tform1.button1click(sender: tobject);
begin
bmp2emf( 'c:\testbitmap.bmp' );
end;
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;
W uses dopisz moduł jpeg clipbrd. W tym przykładzie chrtoutputsingle - to obiekt TChart. Przed wywołaniem funkcji schowek musi już byc typu TBitmap.
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;
Przykład użycia: convertbmp2wmf ("c: \ mypic.bmp", "c: \ mypic.wmf").
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;
Wywołanie: convertwmf2bmp('c:\mypic.wmf' , 'c:\mypic.bmp').
Załóżmy, że plik jest zapisany w formacie bmp. Potrzebujesz przekonwertować go do dib i wyświetlić. Oto dwie procedury: jedna do stworzenia dib z TBitmap, a drugi do jego wydania:
procedure bitmaptodib(bitmap: tbitmap; {Konwersja TBitmap dib}
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( 'Za mało pamięci pikseli obrazu ');
if not getdib(bitmap.handle, bitmap.palette, bitmapinfo^, bits^) then
raise exception.create( 'Nie można otworzyć dib' );
except
if bitmapinfo < > nil then freemem(bitmapinfo, infosize);
if bits < > nil then globalfreeptr(bits);
bitmapinfo := nil; bits := nil;
raise ;
end; end;
{Użyj freedib do przekazania informacji o obrazie }
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;
Tworzenie formularza z Image1 i załadowanie go do umieszczonego TPainBoxa jako 256-kolorowego obrazu.
{ private declarations }
bitmapinfo : pbitmapinfo;
infosize : integer;
bits : pointer;
bitssize : longint;
Niżej tworzenie procedur obsługi zdarzeń, które pokazują proces renderowania 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;
Należy utworzyć dwie bitmapy, bitmap maski (nazwijmy go andmask) i bitmap (nazwijmy jego xormask). W funkcji API systemu Windows do tego służy createiconindirect () .
procedure tform1.button1click(sender: tobject);
var iconsizex : integer; iconsizey : integer; andmask : tbitmap; xormask : tbitmap;
iconinfo : ticoninfo; icon : ticon;
begin {otrzymujemy rozmiar ikon}
iconsizex := getsystemmetrics(sm_cxicon); iconsizey := getsystemmetrics(sm_cyicon);
{tworzymy maskę "and"}
andmask := tbitmap.create; andmask.monochrome := true;
andmask.width := iconsizex; andmask.height := iconsizey;
{rysujemy na masce "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 );
{rysujemy dla testu}
form1.canvas.draw(iconsizex * 2 , iconsizey, andmask);
{tworzymy maskę "xor"}
xormask := tbitmap.create; xormask.width := iconsizex; xormask.height := iconsizey;
{rysujemy na masce "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 );
{rysujemy jako test}
form1.canvas.draw(iconsizex * 4 , iconsizey, xormask);
{tworzymy ikonę}
icon := ticon.create; iconinfo.ficon := true;
iconinfo.xhotspot := 0 ; iconinfo.yhotspot := 0 ;
iconinfo.hbmmask := andmask.handle; iconinfo.hbmcolor := xormask.handle;
icon.handle := createiconindirect(iconinfo);
{niszczymy tymczasowe bitmapy}
andmask.free; xormask.free;
{rysujemy jako test}
form1.canvas.draw(iconsizex * 6 , iconsizey, icon);
{deklaracja ikony jako ikony aplikacji}
application.icon := icon;
{generowanie rysowania}
invalidaterect(application.handle, nil , true);
{zwalniamy pamięć dla ikony}
icon.free;
end ;
Poniżej konwersja obrazu do ikony 32x32 pikseli:
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.
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;
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;
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;
Wariant 2:
procedure ticonshow.filelistbox1click(sender: tobject);
var myicon: ticon; mybitmap: tbitmap;
begin
myicon := ticon.create; mybitmap := tbitmap.create;
try { pobierz nazwę pliku i ikony z nim związane}
strfilename := filelistbox1.items[filelistbox1.itemindex];
strpcopy(cstrfilename, strfilename);
myicon.handle := extracticon(hinstance, cstrfilename, 0 );
{ rysuje ikonę jako bitmapę w przycisku 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;
Aby przekonwertować ikonę do mapy bitowej, należy wykorzystać TImagelist. Dla konwersji odwrotnej zamienić należy metodę AddIcon na Add i metodę getbitmap na getIcon.
function icon2bitmap(icon: ticon): tbitmap;
begin
with timagelist.create ( nil ) do begin
addicon (icon); result := tbitmap.create; getbitmap ( 0 , result);
free; end;
end;
procedure jpegtobmp( const filename: tfilename);
var jpeg: tjpegimage; bmp: tbitmap;
begin
jpeg := tjpegimage.create;
try jpeg.compressionquality := 100 ; {wartość domyślna}
jpeg.loadfromfile(filename); bmp := tbitmap.create;
try
bmp.assign(jpeg); bmp.savetofile(changefileext(filename, '.bmp' ));
finally bmp.free; end; finally jpeg.free;
end; end;
unit imgsize;
interface
uses classes;
procedure getjpgsize(const sfile: string; var wwidth, wheight: word);
procedure getpngsize(const sfile: string; var wwidth, wheight: word);
procedure getgifsize(const sgiffile: string; var wwidth, wheight: word);
implementation
uses sysutils;
function readmword(f: tfilestream): word;
type tmotorolaword = record
case byte of
0: (value: word);
1: (byte1, byte2: byte);
end;
var mw: tmotorolaword;
begin
{ it would probably be better to just read these two bytes in normally }
{ and then do a small asm routine to swap them. but we aren't talking }
{ about reading entire files, so i doubt the performance gain would be }
{ worth the trouble.}
f.read(mw.byte2, sizeof(byte));
f.read(mw.byte1, sizeof(byte));
result := mw.value;
end;
procedure getjpgsize(const sfile: string; var wwidth, wheight: word);
const validsig : array[0..1] of byte = ($ff, $d8);
parameterless = [$01, $d0, $d1, $d2, $d3, $d4, $d5, $d6, $d7];
var sig: array[0..1] of byte; f: tfilestream; x: integer; seg: byte;
dummy: array[0..15] of byte; len: word; readlen: longint;
begin
fillchar(sig, sizeof(sig), #0); f := tfilestream.create(sfile, fmopenread);
try
readlen := f.read(sig[0], sizeof(sig)); for x := low(sig) to high(sig) do
if sig[x] < > validsig[x] then readlen := 0;
if readlen > 0 then begin
readlen := f.read(seg, 1);
while (seg = $ff) and (readlen > 0) do begin
readlen := f.read(seg, 1);
if seg < > $ff then begin
if (seg = $c0) or (seg = $c1) then begin
readlen := f.read(dummy[0], 3); { don't need these bytes }
wheight := readmword(f); wwidth := readmword(f);
end else begin
if not (seg in parameterless) then begin
len := readmword(f); f.seek(len-2, 1); f.read(seg, 1);
end else seg := $ff; { fake it to keep looping. }
end; end; end; end;
finally f.free; end;
end;
procedure getpngsize(const sfile: string; var wwidth, wheight: word);
type tpngsig = array[0..7] of byte;
const validsig: tpngsig = (137,80,78,71,13,10,26,10);
var sig: tpngsig; f: tfilestream; x: integer;
begin
fillchar(sig, sizeof(sig), #0); f := tfilestream.create(sfile, fmopenread);
try
f.read(sig[0], sizeof(sig)); for x := low(sig) to high(sig) do
if sig[x] < > validsig[x] then exit;
f.seek(18, 0); wwidth := readmword(f); f.seek(22, 0); wheight := readmword(f);
finally f.free; end;
end;
procedure getgifsize(const sgiffile: string; var wwidth, wheight: word);
type
tgifheader = record
sig: array[0..5] of char;
screenwidth, screenheight: word;
flags, background, aspect: byte;
end;
tgifimageblock = record
left, top, width, height: word;
flags: byte;
end;
var f: file; header: tgifheader; imageblock: tgifimageblock; nresult: integer;
x: integer; c: char; dimensionsfound: boolean;
begin
wwidth := 0; wheight := 0;
if sgiffile = '' then exit;
{$i-}
filemode := 0; { read-only }
assignfile(f, sgiffile);
reset(f, 1);
if ioresult < > 0 then {could not open file }
exit; { read header and ensure valid file. }
blockread(f, header, sizeof(tgifheader), nresult);
if (nresult < > sizeof(tgifheader)) or (ioresult < > 0)
or (strlcomp('gif', header.sig, 3) < > 0) then begin { image file invalid }
close(f); exit;
end; { skip color map, if there is one }
if (header.flags and $80) > 0 then begin
x := 3 * (1 shl ((header.flags and 7) + 1)); seek(f, x);
if ioresult < > 0 then begin { color map thrashed }
close(f); exit; end;
end;
dimensionsfound := false; fillchar(imageblock, sizeof(tgifimageblock), #0); { step through blocks. }
blockread(f, c, 1, nresult);
while (not eof(f)) and (not dimensionsfound) do begin
case c of
',': { found image }
begin
blockread(f, imageblock, sizeof(tgifimageblock), nresult);
if nresult < > sizeof(tgifimageblock) then begin { invalid image block encountered }
close(f); exit;
end;
wwidth := imageblock.width; wheight := imageblock.height;
dimensionsfound := true;
end;
'y' : { skip }
begin { nop }
end; { nothing else. just ignore }
end;
blockread(f, c, 1, nresult);
end;
close(f); {$i+}
end;
end.
function DecToBinStr(n: integer): string; {Konwertuje liczbę dziesiętną na binarną}
var S: string; i: integer; Negative: boolean;
begin
if n < 0 then begin Negative := true; end; n := Abs(n);
for i := 1 to SizeOf(n) * 8 do begin
if n < 0 then begin S := S + '1';
end else begin
S := S + '0'; end; n := n shl 1;
end;
Delete(S,1,Pos('1',S) - 1); //remove leading zeros
if Negative then begin
S := '-' + S; end; Result := S;
end;
procedure ExportaBMPtoWMF(Imagem:TImage;Dest:Pchar);
var Metafile : TMetafile; MetafileCanvas : TMetafileCanvas; DC : HDC; ScreenLogPixels : Integer;
begin
Metafile := TMetafile.Create;
try
DC := GetDC(0); ScreenLogPixels := GetDeviceCaps(DC, LOGPIXELSY);
Metafile.Inch := ScreenLogPixels;
Metafile.Width := Imagem.Picture.Bitmap.Width;
Metafile.Height := Imagem.Picture.Bitmap.Height;
MetafileCanvas := TMetafileCanvas.Create(Metafile, DC);
ReleaseDC(0, DC);
try
MetafileCanvas.Draw(0, 0, Imagem.Picture.Bitmap);
finally MetafileCanvas.Free;
end;
Metafile.Enhanced := FALSE; Metafile.SaveToFile(Dest);
finally Metafile.Destroy; end;
end;