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.
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;
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;
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;
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;
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;
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;
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.
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.
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;
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.
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; 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;
{ 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;
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;
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;
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.
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;
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);
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;
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;
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;
{ 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 }
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;
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 ');
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;
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;
//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;
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;
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.
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;
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;