Procedury i funkcje graficzne

1.   Tworzenie ikony z bitmapy (bmp na ico)

Należy stworzyć 2 bitmapy - bitmapę maskę (AndMask) i bitmapę obrazu ikony (XOrMask)oraz wykorzystać funkcję API Windowsa - CreateIconIndirect(), np:

procedure TForm1.Button1Click(Sender: TObject);
var IconSizeX : integer; IconSizeY : integer; AndMask : TBitmap;
XOrMask : TBitmap; IconInfo : TIconInfo; Icon : TIcon;
begin     {Get the icon size}
IconSizeX := GetSystemMetrics(SM_CXICON);
IconSizeY := GetSystemMetrics(SM_CYICON);

{Create the "And" mask}
AndMask := TBitmap.Create;   AndMask.Monochrome := true;
AndMask.Width := IconSizeX;   AndMask.Height := IconSizeY;

{Draw on the "And" mask}
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);

{Draw as a test}
Form1.Canvas.Draw(IconSizeX * 2, IconSizeY, AndMask);

{Create the "XOr" mask}
XOrMask := TBitmap.Create;   XOrMask.Width := IconSizeX;   XOrMask.Height := IconSizeY;

{Draw on the "XOr" mask}
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);

{Draw as a test}
Form1.Canvas.Draw(IconSizeX * 4, IconSizeY, XOrMask);

{Create a icon}
Icon := TIcon.Create;   IconInfo.fIcon := true;   IconInfo.xHotspot := 0;
IconInfo.yHotspot := 0;   IconInfo.hbmMask := AndMask.Handle;
IconInfo.hbmColor := XOrMask.Handle;   Icon.Handle := CreateIconIndirect(IconInfo);

{Destroy the temporary bitmaps}
AndMask.Free;   XOrMask.Free;

{Draw as a test}
Form1.Canvas.Draw(IconSizeX * 6, IconSizeY, Icon);

{Assign the application icon}
Application.Icon := Icon;

{Force a repaint}
InvalidateRect(Application.Handle, nil, true);

{Free the icon}
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.

2. Tworzenie z Ikony Bitmapy (ico na bmp).


procedure ...
var aIcon: TIcon; aBitmap: TBitmap;
begin
aIcon := TIcon.Create;
try   
aIcon.Handle := ExtractIcon(HInstance, Name_Of_Resource, 0);
aBitmap := TBitmap.Create;
with aBitmap do begin
Width := aIcon.Width;   Height := aIcon.Height;   Canvas.Draw(0, 0, aIcon);
end   // with aBitmap ...
finally   FreeAndNil(aIcon);   FreeAndNil(aBitmap)   end  // try ... finally ...
end;

Wersja 2 - tworzenie BMP z ikony w postaci pliku zewnętrznego:


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;

ICO na BMP - Wersja 3:


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;

3.   Konwersja Bitmapy do pliku EMF.


function ConvertBMPtoEMF(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
ConvertBMPtoEMF('C:\Source.bmp');
end;

4.   Tworzenie tymczasowego Canvasu.


Należy stworzyć bitmapę i jej obszar wypełnić dowolnym kolorem. Wstawić Canvas tej bitmapy na formatę a samą bitmapę zniszczyć, np:

procedure TForm1.Button1Click(Sender: TObject);
var bm : TBitmap;
begin
bm := TBitmap.Create;   bm.Width := 100;   bm.Height := 100;
bm.Canvas.Brush.Color := clRed;   bm.Canvas.FillRect(Rect(0, 0, 100, 100));
bm.Canvas.MoveTo(0, 0);     bm.Canvas.LineTo(100, 100);
Form1.Canvas.StretchDraw(Form1.ClientRect, Bm);
bm.Free;
end;

5.   Zmiana rozmiaru (rozciąganie) obrazu


uses   graphics, sysutils, classes, forms, windows;

procedure Stretch( ABitmap : graphics.TBitmap );
var   SrcRect : TRect;   DestRect : TRect;
begin
SrcRect := Bounds( 0,0, ABitmap.Width, ABitmap.Height );
DestRect := Bounds( 0,0, screen.Width, screen.Height );
ABitmap.Width := screen.Width;     ABitmap.Height := screen.Height;
ABitmap.Canvas.CopyRect( DestRect, ABitmap.Canvas, SrcRect );
end;

6.   Zapis schowka do pliku JPG


program CLP2JPG;     {$APPTYPE CONSOLE}

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, ClipBRD, Jpeg;

var myBitmap: TBitmap;   myJpegImg: TJpegImage;   i: Integer;   TargetFile: string;
begin
myBitmap := TBitmap.Create;     myJpegImg := TJpegImage.Create;
for i := 0 to ParamCount do
Write('Parameter '+IntToStr(i)+' = '+ParamStr(i)+#13#10);
if paramstr(1) = '' then begin
Write('A file name is required');   Exit;   end;
try     if Clipboard.HasFormat(cf_Bitmap) then begin
myBitmap.Assign(clipboard);   myJpegImg.Assign(myBitmap);
myJpegImg.SaveToFile(ParamStr(1));
end   else   Write('No graphic on the clipboard');
finally   myBitmap.FreeImage;   myJpegImg.Free;
end;

end.

7.   Rysowanie obrazu pod odpowiednim kątem


unit drawunit;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls;

type     TForm1 = class(TForm)
Image1: TImage;   Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private   { Private declarations }
public
rotateimage:timage;
end;

var     Form1: TForm1;

implementation     {$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
const   rotation = 2/3*pi;
var x,y : integer;   newx,newy : integer;   radius,a : real;
begin
form1.WindowState:=wsMaximized;
image1.Visible:=false;   button1.Visible:=false;
rotateimage:=timage.Create(self);   rotateimage.parent:=self;
rotateimage.Left:=0;   rotateimage.Top:=0;

rotateimage.width:=740;   rotateimage.Height:=540;

for x:=1 to image1.Picture.Width do begin
for y:=1 to image1.Height do begin
radius:=Sqrt(Sqr(X)+Sqr(Y));   a:=Arctan(Y/X);
newx:=round(Radius*Cos(A+Rotation)+300);
newy:=round(Radius*Sin(A+Rotation)+300);
rotateimage.Canvas.Pixels[newx,newy]:=image1.Canvas.Pixels[x,y];
end;   //nested for do
end;   //for do
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
rotateimage.free;
end;

end.

8.   Zapis komponentu z kategorii TWinControl jako obrazu do pliku


Poniższa procedura zrzuca ten komponent do Bitmapy i po konwersji do JPG zapisuje go do pliku

uses Jpeg;
procedure Zrzucaj (AControl : TWinControl; AFileName : string; UseJpegFormat : boolean = true);
var Canvas : TCanvas;   Bmp : TBitmap;   Jpg : TJpegImage;
begin
try     Canvas := TCanvas.Create;
Canvas.Handle := GetDc(AControl.Handle);
Bmp := TBitmap.Create;
Bmp.Width := AControl.Width;   Bmp.Height := AControl.Height;
bmp.PixelFormat :=pf24bit;
Bmp.Canvas.CopyRect(Canvas.ClipRect, Canvas, Canvas.ClipRect);
if UseJpegFormat then begin
Jpg := TJpegImage.Create;   jpg.PixelFormat := jf24bit;   Jpg.Assign(Bmp);
Jpg.SaveToFile(ChangeFileExt(AFileName,'.jpg'));
end   Else   Bmp.SaveToFile(ChangeFileExt(AFileName,'.bmp'));
finally   ReleaseDC(AControl.Handle, Canvas.Handle);   FreeAndNil(Bmp);
if UseJpegFormat then FreeAndNil(Jpg);   FreeAndNil(Canvas);
end;   end;

9. 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('taki_sobie_plik.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.

10. Konwersja bmp do wmf. - również łatwe - nieco inna wersja.


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

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

12. 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; 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;

13. 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;

14. 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;

15. 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;

16. 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 -100 procent}
jpeg.loadfromfile(filename); bmp := tbitmap.create;
try bmp.assign(jpeg);
bmp.savetofile(changefileext(filename, '.bmp' ));
finally bmp.free; end; finally jpeg.free;
end; end;

17. 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.

18. Programowa aktywacja klawisza Print Screen z zapisem do schowka.


Powyższa funkcja kopiuje ekran i zapisuje go do schowka (clipboard).
Konieczne dołączenie pliku clipbrd.pas do projektu.

procedure sendscreenimagetoclipboard;
var bmp: tbitmap;
begin
bmp := tbitmap.create;
try
bmp.width := screen.width;  bmp.height := screen.height;
bitblt(bmp.canvas.handle, 0, 0, screen.width, screen.height, getdc(getdesktopwindow), 0, 0, srccopy);
clipboard.assign(bmp);
finally  bmp.free;  end;
end;

19. Kopiowanie ekranu do bitmapy. autor: simon carter (simon.carter@orcka.com)


procedure getscreenimage(bmp: tbitmap);
begin
bmp.width := screen.width;  bmp.height := screen.height;
bitblt(bmp.canvas.handle, 0, 0, screen.width, screen.height,getdc(getdesktopwindow), 0, 0, srccopy);
end; //cały ekran
keybd_event(vk_snapshot,1,0,0);  keybd_event(vk_snapshot,1,keyeventf_keyup,0);
//aktywne okno
keybd_event(vk_snapshot,0,0,0);  keybd_event(vk_snapshot,0,keyeventf_keyup,0);

20. Lustrzane odbicie pobrazu BMP (obrót w poziomie i pionie).


procedure flip_horizontal(quelle, ziel: tbitmap);
begin
ziel.assign(nil);   ziel.width := quelle.width;   ziel.height := quelle.height;
stretchblt(ziel.canvas.handle, 0, 0, ziel.width, ziel.height, quelle.canvas.handle,
0, quelle.height, quelle.width, quelle.height, srccopy);
end;

procedure flip_vertikal(quelle, ziel: tbitmap);
begin
ziel.assign(nil);   ziel.width := quelle.width;   ziel.height := quelle.height;
stretchblt(ziel.canvas.handle, 0, 0, ziel.width, ziel.height, quelle.canvas.handle,
quelle.width, 0, quelle.width, quelle.height, srccopy);
end;

//wywołanie takiej procedury...
procedure tform1.button1click(sender: tobject);
var   temp: tbitmap;
begin
temp := tbitmap.create;
try
temp.assign(image1.picture.bitmap);
flip_vertikal(temp, image1.picture.bitmap);
finally   temp.free;   end;
end;

21. Pulsujący obraz .


procedure tform1.button11click(sender: tobject);
begin
timer1.ontimer := button11click;   imagepulsate(image1, timer1, false, 0);
end;

{delphi code}
procedure imagepulsate( image : timage; timer : ttimer; transparent : boolean; cycles : integer);
begin
imagefadeinandoutdetail( image, timer, transparent, image.parent.clientrect.top+1,
image.parent.clientrect.left+1, (image.parent.clientrect.right-image.parent.clientrect.left)-2,
(image.parent.clientrect.bottom-image.parent.clientrect.top)-2,
(((image.parent.clientrect.right-image.parent.clientrect.left-2)*19) div 20),
(((image.parent.clientrect.bottom-image.parent.clientrect.top-2)*19) div 20), cycles);
end;

22. Zapis zawartości TPaintBox do BMP


var  bitmap: tbitmap;  source: trect;  dest: trect;
begin
bitmap := tbitmap.create;
try
with bitmap do
begin
width := mypaintbox.width;  height := mypaintbox.height;  dest := rect(0, 0, width, height);
end;
with mypaintbox do
source := rect(0, 0, width, height);
bitmap.canvas.copyrect(dest, mypaintbox.canvas, source);
bitmap.savetofile('myfile.bmp');
finally  bitmap.free;  end;
end;

23. Informacja o plikach BMP.


{ przykład pokazuje jak uzyskać takie dane jak rozmiar pliku, szerokość, wysokość, wartość bitową i kolory z bitmapy.}

procedure tform1.button1click(sender: tobject);
var   fileheader: tbitmapfileheader;   infoheader: tbitmapinfoheader;   s: tfilestream;
begin
s := tfilestream.create('c:yourbitmap.bmp', fmopenread);
try
s.read(fileheader, sizeof(fileheader));   s.read(infoheader, sizeof(infoheader));
finally   s.free;   end;
listbox1.items.clear;
listbox1.items.add('filesize: ' + inttostr(fileheader.bfsize));
listbox1.items.add('width: ' + inttostr(infoheader.biwidth));
listbox1.items.add('height: ' + inttostr(infoheader.biheight));
listbox1.items.add('bitcount: ' + inttostr(infoheader.bibitcount));
listbox1.items.add('used: ' + inttostr(infoheader.biclrused));
end;

{ wartości bitów: 1 = czarne/białe , 4 = 16 kolorow , 8 = 256 kolorów }

24. Odbiór / transmisja Bitmapy za pomocą schowka.


function copycliptobuf(dc: hdc; left, top,width, height: integer; rop: longint;
var copydc: hdc; var copybitmap: hbitmap): boolean;
var  tempbitmap: hbitmap;
begin
result := false;  copydc := 0;  copybitmap := 0;
if dc < > 0 then
begin
copydc := createcompatibledc(dc);  if copydc < > 0 then
begin
copybitmap := createcompatiblebitmap(dc,width, height);
if copybitmap < > 0 then
begin
tempbitmap := copybitmap;  copybitmap := selectobject(copydc,copybitmap);
result := bitblt(copydc, 0, 0,width, height, dc,left, top, rop);
copybitmap := tempbitmap;
end; end; end;
end;

function copybuftoclip(dc: hdc; var copydc: hdc;var copybitmap: hbitmap; left, top, width, height: integer;
rop: longint; deleteobjects: boolean): boolean;
var  tempbitmap: hbitmap;
begin
result := false;  if (dc < > 0) and (copydc < > 0) and (copybitmap < > 0) then
begin
tempbitmap := copybitmap;  copybitmap := selectobject(dc, copybitmap);
result := bitblt(dc, left, top,width, height, copydc,0, 0, rop);
copybitmap := tempbitmap;  if deleteobjects then
begin
deletedc(copydc);  deleteobject(copybitmap);
end; end;
end;

25. Plik BMP zapisany w .RES


1. Utwórz plik tekstowy, na przykład: RECURSOS.RC o zawartości jak poniżej:
BITMAP_1 BITMAP "C: ImagensGrafico.bmp" dla wszystkich bitmap, że chcesz;
2. Kompilacja tego pliku kompilatorem Windowsa BRCC32.EXE da w katalogu bin Delphi plik
RECURSOS.RES, którego potem...
3. Włóż do źródła projektu:
$ {R} RECURSOS.RES
Aby korzystać z bitmap wykonaj następujące czynności:
VarTipoTBitmap: = LoadBitmap (hInstance, "BITMAP_1 ');

26. Umieszczanie bitmapy w ComboBox.


Ustaw właściwość Styl ComboBox do csOwnerDrawVariable.
var Form1: TForm1; Bmp1, Bmp2, Bmp3: TBitmap;
implementation
{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
Bmp1:=TBitmap.Create;  Bmp.Loadfromfile('c:chip16.bmp');
Bmp1:=TBitmap.Create;  Bmp.Loadfromfile('c:zoom.bmp');
Bmp1:=TBitmap.Create;  Bmp.Loadfromfile('c:disk.bmp');
ComboBox1.Items.AddObject('Chip',Bmp1);
ComboBox1.Items.AddObject('Zoom',Bmp2);
ComboBox1.Items.AddObject('Disk',Bmp3);
end;

procedure TForm1.ComboBox1DrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOWnerDrawState);
var   Bitmap: TBitmap;   Offset: Integer;
begin
with (Control as TComboBox).Canvas do begin
FillRect(Rect);   Bitmap:= TBitmap(ComboBox1.Items.Objects[index]);
if Bitmap nil then begin
BrushCopy(Bounds(Rect.Left + 2, Rect.Top + 2, Bitmap.Width,
Bitmap.Height), Bitmap, Bounds(0, 0, Bitmap.Width, Bitmap.Height), clRed);
Offset: Bitmap.width + 8;
end;   TextOut(Rect.Left + Offset, Rect.Top, ComboBox1.Items[index]);
end;  end;

procedure TForm1.ComboBox1MeasureItem(Control: TWinControl; Index: Integer; var Height: Integer);
begin
Height:=20;
end;

27. Eksport obrazu TImage z planszy programu 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;

28.Zapis aktywnego okna lub bitmapy w schowku Windows.


//dodaj unit jpeg w uses

procedure CapturaErro(Path : string);
var   HandleTela: HDc;   RectTela: TRect;   BMPTela : TBitmap;
BMPTemp : tbitmap;   JPEGTela : TJPEGImage;
begin
BMPTela := TBitmap.Create;   BMPTemp := TBitmap.Create;  JPEGTela := TJPEGImage.Create;
Application.ProcessMessages;   HandleTela := GetWindowDC(GetDeskTopWindow);
try
Application.ProcessMessages;
BMPTemp.Canvas.Handle := HandleTela;   RectTela := Rect(0, 0, Screen.Width, Screen.Height);
BMPTela.Width := RectTela.Right - RectTela.Left;   BMPTela.Height := RectTela.Bottom - RectTela.Top;
BMPTela.Canvas.CopyRect(BMPTela.Canvas.ClipRect, BMPTemp.Canvas, RectTela);
finally
if Copy(Path,Length(Path)-2,3) = 'jpg' then begin
JPEGTela.CompressionQuality := 80;   JPEGTela.ProgressiveEncoding := True;
JPEGTela.Grayscale := False;   JPEGTela.Assign(BMPTela);
JPEGTela.SaveToFile(path);
end else
if Copy(Path,Length(Path)-2,3) = 'bmp' then begin
BMPTela.SaveToFile(Path);
end;
ReleaseDC(GetDeskTopWindow, HandleTela);  BMPTela.Free;   BMPTemp.Free;   JPEGTela.Free;
end; end;

29. Praca z grafiką i schowkiem (Clipboard).


W tym przykładzie użyto Buttona, TImage i komponent TShape na formie. Gdy użytkownik kliknie Button, obraz zostaje przechowywany w postaci zmiennej formimage i zostaje skopiowany do schowka (clipboard). Obraz ze schowka jest następnie kopiowany z powrotem do TImage, tworząc ciekawy efekt.

procedure tform1.button1click(sender: tobject);
var formimage: tbitmap;
begin
formimage := getformimage;
try
clipboard.assign(formimage);  image1.picture.assign(clipboard);
finally formimage.free;  end;
end;

procedure tform1.formcreate(sender: tobject);
begin
shape1.shape := stellipse;  shape1.brush.color := cllime;  image1.stretch := true;
end;

// Poniżej przykład kopiowania ekranu do schowka.
procedure copyscreentoclipboard;
var   dx,dy: integer;   hsourcdc, hdestdc, hbm, hbmold: thandle;
begin
dx := screen.width;  dy := screen.height;
hsourcdc := createdc('display', nil, nil, nil);  hdestdc := createcompatibledc(hsourcdc);
hbm := createcompatiblebitmap(hsourcdc, dx, dy);  hbmold:= selectobject(hdestdc, hbm);
bitblt(hdestdc, 0, 0, dx, dy, hsourcdc, 0, 0, srccopy);  openclipboard(form1.handle);
emptyclipboard;  setclipboarddata(cf_bitmap, hbm);  closeclipboard;
selectobject(hdestdc,hbmold);
deleteobject(hbm);  deletedc(hdestdc);  deletedc(hsourcdc);
end;

30. Zapis RichEdita do pliku EMF.


Czasami potrzeba przechować dane RichEdita w pliku EMF. Poniżej kod pozwala to wykonać, z tym że 1 strona tekstu stanowi jeden metaplik.

unit richeditemfprint;

interface
uses windows, sysutils, richedit, commdlg, classes, messages, comctrls;
procedure richedittometafile(acontrol : trichedit; afilename : string);

implementation // getprinterdc()
// returns a printer dc - uses printer common dialog
function getprinterdc : hdc;
var  pdlg : tprintdlg;
begin
fillchar(pdlg, sizeof(tprintdlg), 0);   pdlg.lstructsize := sizeof( tprintdlg );
pdlg.flags := pd_returndc;   printdlg(pdlg); result := pdlg.hdc;
end;

// get the length, in characters, of the text in the control
function getrtftextlength(hwndrtf : hwnd) : integer;
begin
result := sendmessage(hwndrtf, wm_gettextlength, 0, 0 );
end;
// rtftoemf - tell the control to draw itself on the emf parameters:
// hrefdc is used to create the emf
// pszmetafilename is the file name of the new emf (can be nil)
// prcmeta is the rect used to in createenhmetafile(), in 0.01mm
// units (should not be nil)
// hwndrtf is the control of interest
// nstart is the starting character location
// pend is a integer which receives the position of
// the next character to print after this page

function rtftoemf(hrefdc : hdc; pszmetafilename : lpctstr; prcmeta : trect;
hwndrtf : hwnd; nstart : integer; var pend : integer) : henhmetafile;
var   hmetadc : hdc;   fr : formatrange; ntextprinted : integer;
begin // create the emf
hmetadc := createenhmetafile( hrefdc, pszmetafilename, @prcmeta, nil );
if( hmetadc = 0 ) then begin
result := 0; exit;
end;

zeromemory(@fr, sizeof(fr));
// set up the page (convert 0.01mm to twips)
fr.rcpage.top := prcmeta.left*1440 div 2540;
fr.rcpage.left := prcmeta.top*1440 div 2540;
fr.rcpage.right := prcmeta.right*1440 div 2540;
fr.rcpage.bottom := prcmeta.bottom*1440 div 2540;
// set up no margins all around.
fr.rc := fr.rcpage; // set up the range of text to print as nstart to end of document
fr.chrg.cpmin := nstart;
fr.chrg.cpmax := -1;
fr.hdctarget := hmetadc;
fr.hdc := fr.hdctarget;

// tell the control to draw itself on our (meta) dc
ntextprinted := sendmessage(hwndrtf, em_formatrange, 1, integer(@(fr)));
pend := ntextprinted;   result := closeenhmetafile( hmetadc );
end;

// dumprtftopagedemfs - demonstrates using rtftoemf() to create an emf
// for each page in an rtf control
parameters:
// hwndrtfcontrol - the control
// szemffiletitlebase - base filename for emf files, number is appended

procedure dumprtftopagedemfs(hwndrtfcontrol : hwnd; szemffiletitlebase : lptstr);
var   szmetaname : string; nrtftextlength, nstart, npage : integer;
hrefdc : hdc; rcmeta : trect; hemf : henhmetafile;
begin
// first, determine how many chars are in the rtf
nrtftextlength := getrtftextlength( hwndrtfcontrol );
// get a reference dc (based on a printer)
hrefdc := getprinterdc();
// set up the meta rect for 0.01mm units
rcmeta := classes.rect( 0, 0, getdevicecaps(hrefdc, horzsize)*100,
getdevicecaps(hrefdc, vertsize)*100 );
npage := 0;   nstart := 0;
while nstartdo begin
// loop while we've not reached the end of the text in the control
// construct a file name for this page
szmetaname := format('%s%d.emf', [szemffiletitlebase, npage]);
// call function above to draw this portion of the rtf on the emf
hemf := rtftoemf( hrefdc, pchar(szmetaname), rcmeta, hwndrtfcontrol, nstart, nstart );
// clean up
deleteenhmetafile( hemf );   inc(npage);
if nstart = 0 then break;
end; end;

//przykład wykorzystania ....
procedure richedittometafile(acontrol : trichedit; afilename : string);
begin
dumprtftopagedemfs(acontrol.handle, pchar(afilename));
end;

end.

31. Wyciąg ikony z pliku EXE do TImage - jeszcze inna wersja.


uses shellapi;

procedure tform1.button1click(sender: tobject);
var   iconindex: word;   h: hicon;
begin
iconindex := 0;
h := extractassociatedicon(hinstance, 'c:windowsnotepad.exe', iconindex);
drawicon(form1.canvas.handle, 10, 10, h);
end;

32. Wyświetlanie tekstu na obrazie załadowanym do TImage.


procedure tform1.formcreate(sender: tobject);
var   bmp : tbitmap;
begin
bmp:=tbitmap.create;
bmp.loadfromfile('mypicture.bmp');
image1.picture.assign(bmp);   image1.canvas.brush.color:=clblue;
image1.canvas.font.name:='arial';   image1.canvas.font.size:=10;
image1.canvas.textout(10, 10, 'Tutaj jest ten tekst !!!');
end;