Procedury i funkcje konwersji

1.  Konwersja kodu ANSI na UTF


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;

2.   Konwersja liczb na słowa


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.

3.   Zamiana liczb dziesiętnych na dwójkowe i odwrotnie


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;

4.   Ile jest słów w łańcuchu (stringu)?


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;

5.   Konwersja liczb szesnastkowych (HEX) na dziesiętne


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;

5.   Konwersja stringów w Delphi


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;

6.   Nieudokumentowana w Delphi zamiana   BinToHex   i   HexToBin


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;

7.   Konwersja formatów grafiki - wg http://www.delphi.int.ru


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.

## Konwersja bmp do emf.


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;

# Konwersja bmp na 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;

W uses dopisz moduł jpeg clipbrd. W tym przykładzie chrtoutputsingle - to obiekt TChart. Przed wywołaniem funkcji schowek musi już byc typu TBitmap.

# Konwersja bmp do wmf. - również łatwe


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").

# Konwersji odwrotna: wmf do bmp - nie różni się zbytnio od poprzedniej


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').

# Konwersja bmp do dib.


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;

# Konwersja bmp do ico.


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.

# Konwersja bmp na rtf. - tak też można . Oto przykład:


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;

# Konwersja cur na bmp - przekształcenie kursora w 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;

# Konwersja ico na 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;

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;

# Konwersja jpg na bmp.


uses jpeg;

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;

8. Procedury szybkiego uzyskania wielkośći obrazu z plików JPG, GIF, PNG.


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.

9. Jak przekonwertować z dziesiętnego na binarny


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;

10. Eksport obrazu TImage do pliku w formacie WMF


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;