Renk Paletlerinin yaratılması ve kullanımı
Delphi uygulamasında çizim yapılırken, gereken paletin yaratılması ve kullanılması nasıl olur?
Eğer palet değiştirme yolu ile animasyon yapılacaksa, en az 256 renk modunda çalışılmalı ve, aşağıdaki kod örneğinde geçen bütün PC_NOCOLLAPSE değerleri PC_RESERVED olarak değiştirilmelidir.
Palet yaratmanın yanı sıra, yapılması gereken diğer işlemler de şunlardır.
1. Formun GetPalette davranışı,yeni paleti döndürecek şekilde değiştirilmelidir.
2. Boyamaya başlamadan hemen önce, yeni palet seçilmelidir.
OldPal := SelectPalette(Canvas.Handle, NewPalette, False);
RealizePalette(Canvas.Handle);
SelectPalette(Canvas.Handle, OldPal, False);
3. İşlem tamamlandıktan sonra palet yok edilmelidir.
4. Renk değeri almak için, RGB fonksiyonu yerine PaletteRGB fonksiyonu kullanılmalıdır.
function CreateIdentityPalette(const aRGB; nColors : Integer) : HPALETTE;
type
QA = Array[0..255] of TRGBQUAD;
var
Palette : PLOGPALETTE;
PalSize : Word;
ScreenDC : HDC;
I : Integer;
nStaticColors : Integer;
nUsableColors : Integer;
begin
PalSize := SizeOf(TLOGPALETTE) + SizeOf(TPALETTEENTRY) * 256;
GetMem(Palette, PalSize);
try
with Palette^ do
begin
palVersion := $0300;
palNumEntries := 256;
ScreenDC := GetDC(0);
try
if (GetSystemPaletteUse(ScreenDC) = SYSPAL_NOSTATIC)
then
begin
{$R-}
for i := 0 to (nColors-1) do
with palPalEntry[i], QA(aRGB)[I] do
begin
peRed := rgbRed;
peGreen := rgbGreen;
peBlue := rgbBlue;
peFlags := PC_NOCOLLAPSE;
end;
for i := nColors to 255 do
palPalEntry[i].peFlags := PC_NOCOLLAPSE;
I := 255;
with palPalEntry[i] do
begin
peRed := 255;
peGreen := 255;
peBlue := 255;
peFlags := 0;
end;
with palPalEntry[0] do
begin
peRed := 0;
peGreen := 0;
peBlue := 0;
peFlags := 0;
end;
{$R+}
end
else
begin
nStaticColors := GetDeviceCaps(ScreenDC, NUMRESERVED);
GetSystemPaletteEntries(ScreenDC, 0, 256, palPalEntry);
{$R-}
nStaticColors := nStaticColors shr 1;
for i:= 0 to (nStaticColors-1) do
palPalEntry[i].peFlags := 0;
nUsableColors := nColors - nStaticColors;
for I := nStaticColors to (nUsableColors-1) do
with palPalEntry[i], QA(aRGB)[i] do
begin
peRed := rgbRed;
peGreen := rgbGreen;
peBlue := rgbBlue;
peFlags := PC_NOCOLLAPSE;
end;
for i := nUsableColors to (255-nStaticColors) do
palPalEntry[i].peFlags := PC_NOCOLLAPSE;
for i := (256 - nStaticColors) to 255 do
palPalEntry[i].peFlags := 0;
end;
finally
ReleaseDC(0, ScreenDC);
end;
end;
Result := CreatePalette(Palette^);
finally
FreeMem(Palette, PalSize);
end;
end;
procedure ClearSystemPalette;
var
Palette : PLOGPALETTE;
PalSize : Word;
ScreenDC : HDC;
I : Word;
const
ScreenPal : HPALETTE = 0;
begin
PalSize := SizeOf(TLOGPALETTE) + SizeOf(TPALETTEENTRY) * 255;
GetMem(Palette, PalSize);
try
FillChar(Palette^, PalSize, 0);
Palette^.palVersion := $0300;
Palette^.palNumEntries := 256;
{$R-}
For I := 0 to 255 do
With Palette^.palPalEntry[I] do
peFlags := PC_NOCOLLAPSE;
{$R+}
ScreenDC := GetDC(0);
try
ScreenPal := CreatePalette(Palette^);
if ScreenPal <> 0
then
begin
ScreenPal := SelectPalette(ScreenDC,ScreenPal,FALSE);
RealizePalette(ScreenDC);
ScreenPal := SelectPalette(ScreenDC,ScreenPal,FALSE);
DeleteObject(ScreenPal);
end;
finally
ReleaseDC(0, ScreenDC);
end;
finally
FreeMem(Palette, PalSize);
end;
end;
Müzik CD si çalınırken, Track sayısının okunması
Çalınmakta olan müzik CD'sinin, hangi Track da olduğunun anlaşılması için aşağıdaki kod örneği kullanılabilir.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls, MPlayer,mmsystem;
type
TForm1 = class(TForm)
Timer1: TTimer;
Label1: TLabel;
Label2: TLabel;
MediaPlayer1: TMediaPlayer;
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Timer1Timer(Sender: TObject);
var Trk, Min, Sec: Word;
begin
with MediaPlayer1 do
begin
Trk:= MCI_TMSF_TRACK(Position);
Min:=MCI_TMSF_MINUTE(Position);
Sec:=MCI_TMSF_SECOND(Position);
Label1.Caption:=Format('%.2d',[Trk]);
Label2.Caption:=Format('%.2d:%.2d',[Min,Sec]);
end;
end;
end.
Ekran çözünürlüğü değiştirme
Bilgisayarda kullanılan ekran çözünürlüğü değerleri, normalde masa üstüne sağ fare tuşu ile tıklanarak açılan PopUp menüden, özellikler seçeneği kullanılarak yapılır. Bu işlemin kod ile yapılması gerekirse;
Desteklenen ekran çözünürlükleri şu şekilde tespit edilebilir.
unit unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Edit1: TEdit;
ListBox1: TListBox;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var
DC : THandle;
Bits : Integer;
HRes : Integer;
VRes : Integer;
DM : TDevMode;
ModeNum : LongInt;
Ok : Bool;
begin
DC := Canvas.Handle;
Bits := GetDeviceCaps(DC, BITSPIXEL);
HRes := GetDeviceCaps(DC, HORZRES);
VRes := GetDeviceCaps(DC, VERTRES);
Edit1.Text := Format('%d bits, %d x %d',[Bits, HRes, VRes]);
ModeNum := 0;
EnumDisplaySettings(Nil, ModeNum, DM);
ListBox1.Items.Add(Format('%d bits, %d x %d',
[DM.dmBitsPerPel, DM.dmPelsWidth, DM.dmPelsHeight]));
Ok := True;
While Ok do
Begin
Inc(ModeNum);
Ok := EnumDisplaySettings(Nil, ModeNum, DM);
If Ok Then ListBox1.Items.Add(Format('%d bits, %d x %d',
[DM.dmBitsPerPel, DM.dmPelsWidth, DM.dmPelsHeight]));
End;
end;
end.
Çözünürlükleri listelemenin bir adım ilerisi, istenen çözünürlüğü seçip uygulamaktır. Aşağıdaki unit de tespit edilen çözünürlüklerden seçilen sisteme uygulanmaktadır.
Ubit1Pas.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
ListBox1: TListBox;
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure ListBox1Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
var
i : Integer;
DevMode : TDevMode;
begin
i := 0;
while EnumDisplaySettings(nil,i,Devmode) do begin
with Devmode do
ListBox1.Items.Add(Format('%dx%d %d Colors',[dmPelsWidth,dmPelsHeight,1 shl dmBitsperPel]));
Inc(i);
end;
end;
procedure TForm1.ListBox1Click(Sender: TObject);
begin
Button1.Enabled := Listbox1.ItemIndex >= 0;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
DevMode : TDevMode;
begin
EnumDisplaySettings(nil,Listbox1.ItemIndex,Devmode);
ChangeDisplaySettings(DevMode,0);
end;
end.
Unit1.dfm
object Form1: TForm1
Left = 334
Top = 191
Width = 306
Height = 320
Caption = 'Ekran çözünürlükleri'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -14
Font.Name = 'MS Sans Serif'
Font.Style = []
OnCreate = FormCreate
PixelsPerInch = 120
TextHeight = 16
object ListBox1: TListBox
Left = 20
Top = 10
Width = 267
Height = 218
ItemHeight = 16
TabOrder = 0
OnClick = ListBox1Click
end
object Button1: TButton
Left = 110
Top = 241
Width = 92
Height = 32
Caption = 'Değiştir'
Enabled = False
TabOrder = 1
OnClick = Button1Click
end
end
Bmp resminin panoya yapıştırılmsı ve Panodan kopyalaması
Pano kullanımının bir başka örneğinin uygulandığı, kod örneğinde, BMP formatındaki bir resmin, panoya kopyalanması ve panodan alınması gösterilmektedir.
Unit1.pas
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls,
clipbrd;
type
TForm1 = class(TForm)
BaseKeyPanel: TPanel;
Image2: TImage;
Button1: TButton;
Image1: TImage;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
Var
BitMap : TBitmap;
begin
BitMap:=TBitMap.Create;
BitMap.Height:=BaseKeyPanel.Height;
BitMap.Width:=BaseKeyPanel.Width;
BitBlt(BitMap.Canvas.Handle, 0 {Left}, 0{Top},
BaseKeyPanel.Width, image1.Height,
GetDC(BaseKeyPanel.Handle), 0, 0, SRCCOPY);
Clipboard.Assign(BitMap);
bitmap.free;
End;
procedure TForm1.Button2Click(Sender: TObject);
Var
BitMap : TBitmap;
begin
BitMap:=TBitMap.Create;
bitmap.assign(clipboard);
Image2.Canvas.Draw(0, 0, Bitmap);
bitmap.free;
end;
end.
Form1.dfm
object Form1: TForm1
Left = 200
Top = 111
Width = 554
Height = 316
Caption = 'Form1'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -13
Font.Name = 'MS Sans Serif'
Font.Style = []
PixelsPerInch = 120
TextHeight = 16
object Image2: TImage
Left = 184
Top = 64
Width = 105
Height = 105
end
object BaseKeyPanel: TPanel
Left = 48
Top = 80
Width = 105
Height = 81
Caption = 'BaseKeyPanel'
TabOrder = 0
object Image1: TImage
Left = 1
Top = 1
Width = 103
Height = 79
Align = alClient
end
end
object Button1: TButton
Left = 48
Top = 32
Width = 75
Height = 25
Caption = 'Button1'
TabOrder = 1
OnClick = Button1Click
end
object Button2: TButton
Left = 192
Top = 32
Width = 75
Height = 25
Caption = 'Button2'
TabOrder = 2
OnClick = Button2Click
end
end
Bir EXE den ikonun alınp başka bir yere çizilmesi
Herhangi bir program dosyasında kullanılan ikonun, alınmasını sağlayan bir fonksiyon.
implementation
USES ShellApi;
{$R *.DFM}
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;
end.
İkon resminin, buton üzerinde kullanılması
Not : image bileşenlerinin picture bilgileri, silinmiştir.
object Form1: TForm1
Left = 200
Top = 108
Width = 278
Height = 372
Caption = 'Form1'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
PixelsPerInch = 96
TextHeight = 13
object SpeedButton1: TSpeedButton
Left = 8
Top = 16
Width = 65
Height = 57
end
object FileListBox1: TFileListBox
Left = 80
Top = 16
Width = 169
Height = 313
ItemHeight = 13
TabOrder = 0
OnClick = FileListBox1Click
end
end
unit1.pas
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics,
Controls, Forms, Dialogs, Buttons, StdCtrls, FileCtrl;
type
TForm1 = class(TForm)
FileListBox1: TFileListBox;
SpeedButton1: TSpeedButton;
procedure FileListBox1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses shellapi;
{$R *.DFM}
procedure TFORM1.FileListBox1Click(Sender: TObject);
var
MyIcon: TIcon;
MyBitMap : TBitmap;
strFileName:STRING;
cStrFileName:PCHAR;
begin
MyIcon := TIcon.Create;
MyBitMap := TBitmap.Create;
try
{ get the file name and the icon associated with it}
strFileName := FileListBox1.Items[FileListBox1.ItemIndex];
StrPCopy(cStrFileName, strFileName);
MyIcon.Handle := ExtractIcon(hInstance, cStrFileName, 0);
{ draw the icon onto the bitmap for the speed button }
SpeedButton1.Glyph := MyBitMap;
SpeedButton1.Glyph.Width := MyIcon.Width;
SpeedButton1.Glyph.Height := MyIcon.Height;
SpeedButton1.Glyph.Canvas.Draw(0,0, MyIcon);
finally
MyIcon.Free;
MyBitMap.Free;
end;
end;
end.
Grafik çizme işlemi
Unit1.pas
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls;
type
TForm1 = class(TForm)
Image1: TImage;
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure grapf;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure tform1.grapf;
var
x,l: Integer;
y,a: Double;
begin
Image1.Picture.Bitmap := TBitmap.Create;
Image1.Picture.Bitmap.Width := Image1.Width;
Image1.Picture.Bitmap.Height := Image1.Height; {These three lines could
go in Form1.Create instead}
l := Image1.Picture.Bitmap.Width;
for x := 0 to l do
begin
a := (x/l) * 2 * Pi; {Convert position on X to angle between 0 & 2Pi}
y := Sin(a); {Your function would go here}
y := y * (Image1.Picture.Bitmap.Height / 2); {Scale Y so it fits}
y := y * -1; {Invert Y, the screen top is 0 !}
y := y + (Image1.Picture.Bitmap.Height / 2); {Add offset for middle 0}
Image1.Picture.Bitmap.Canvas.Pixels[Trunc(x), Trunc(y)] := clBlack;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
grapf
end;
end.
Hareketli grafik çizimi
Unit1.pas
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
PaintBox1: TPaintBox;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
BitMap : TBitmap;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
Bitmap := TBitmap.Create;
Bitmap.Width := 400;
Bitmap.Height := 400;
PaintBox1.Width := 200;
PaintBox1.Height := 200;
With Bitmap.Canvas do
begin
Pen.Color := clNavy;
Ellipse(0,0,399,399);
end;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
Bitmap.Free;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Limit : Word;
I : Word;
PBBottom, PBRight : Word;
begin
PBBottom := PaintBox1.Height - 1;
PBRight := PaintBox1.Width - 1;
Limit := Bitmap.Width - PaintBox1.Width;
For I := 0 to Limit do
PaintBox1.Canvas.CopyRect(Rect(0,0,PBRight,PBBottom),
Bitmap.Canvas, Rect(I,0,I+PBRight,PBBottom));
end;
end.
Unit1.dfm
object Form1: TForm1
Left = 200
Top = 108
Width = 240
Height = 238
Caption = 'Form1'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OnCreate = FormCreate
OnDestroy = FormDestroy
PixelsPerInch = 96
TextHeight = 13
object PaintBox1: TPaintBox
Left = 64
Top = 24
Width = 105
Height = 105
end
object Button1: TButton
Left = 80
Top = 144
Width = 75
Height = 25
Caption = 'Button1'
TabOrder = 0
OnClick = Button1Click
end
end
Panoya resim kopyalama
bütün formu panoya kopyalar
procedure TForm1.Button2Click(Sender: TObject);
//uses clipbrd
Var
Image : TImage;
BitMap : TBitmap;
Begin
Image:=TImage.Create(Self);
BitMap:=TBitMap.Create;
BitMap.Width:=ClientWidth;
BitMap.Height:=ClientHeight;
BitBlt(BitMap.Canvas.Handle, 0, 0, ClientWidth, ClientHeight, GetDC(Handle),
0, 0, SRCCOPY);
Image.Picture.Graphic:=BitMap;
Clipboard.Assign(Image.Picture);
BitMap.Free;
Image.Free
end;
Bir remin şeffaf olarak başka bir resim üzerine yapıştırılması
Unit1.pas
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Image1: TImage;
ColorDialog1: TColorDialog;
Panel1: TPanel;
Button2: TButton;
Image2: TImage;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure DrawTransparent(t: TCanvas; x,y: Integer; s: TBitmap; TrCol: TColor);
end;
var
Form1: TForm1;
bmp:tbitmap;
clr:tcolor;
implementation
{$R *.DFM}
procedure tform1.DrawTransparent(t: TCanvas; x,y: Integer; s: TBitmap; TrCol: TColor);
var
bmpXOR, bmpAND, bmpINVAND, bmpTarget: TBitmap;
oldcol: Longint;
begin
try
bmpAND := TBitmap.Create;
bmpAND.Width := s.Width;
bmpAND.Height := s.Height;
bmpAND.Monochrome := True;
oldcol := SetBkColor(s.Canvas.Handle, ColorToRGB(TrCol));
BitBlt(bmpAND.Canvas.Handle, 0,0,s.Width,s.Height, s.Canvas.Handle, 0,0, SRCCOPY);
SetBkColor(s.Canvas.Handle, oldcol);
bmpINVAND := TBitmap.Create;
bmpINVAND.Width := s.Width;
bmpINVAND.Height := s.Height;
bmpINVAND.Monochrome := True;
BitBlt(bmpINVAND.Canvas.Handle, 0,0,s.Width,s.Height, bmpAND.Canvas.Handle, 0,0, NOTSRCCOPY);
bmpXOR := TBitmap.Create;
bmpXOR.Width := s.Width;
bmpXOR.Height := s.Height;
BitBlt(bmpXOR.Canvas.Handle, 0,0,s.Width,s.Height, s.Canvas.Handle, 0,0, SRCCOPY);
BitBlt(bmpXOR.Canvas.Handle, 0,0,s.Width,s.Height, bmpINVAND.Canvas.Handle, 0,0, SRCAND);
bmpTarget := TBitmap.Create;
bmpTarget.Width := s.Width;
bmpTarget.Height := s.Height;
BitBlt(bmpTarget.Canvas.Handle, 0,0,s.Width,s.Height, t.Handle, x,y, SRCCOPY);
BitBlt(bmpTarget.Canvas.Handle, 0,0,s.Width,s.Height, bmpAND.Canvas.Handle, 0,0, SRCAND);
BitBlt(bmpTarget.Canvas.Handle, 0,0,s.Width,s.Height, bmpXOR.Canvas.Handle, 0,0, SRCINVERT);
BitBlt(t.Handle, x,y,s.Width,s.Height, bmpTarget.Canvas.Handle, 0,0, SRCCOPY);
finally
bmpXOR.Free;
bmpAND.Free;
bmpINVAND.Free;
bmpTarget.Free;
end;{End of TRY section}
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
DrawTransparent(image1.Canvas, 1,1, bmp, clr);
image1.Invalidate;
image1.repaint;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
bmp:=tbitmap.create;
bmp.width:=image1.width;
bmp.height:=image1.height;
bmp.assign(image2.picture);
// clr:=tcolor.create;;
clr:=clgreen;
panel1.color:=clr;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
bmp.free;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
if colordialog1.execute then
clr:=colordialog1.Color;
panel1.color:=clr;
end;
end.
Unit1.dfm
object Form1: TForm1
Left = 200
Top = 108
Width = 617
Height = 302
Caption = 'Form1'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OnCreate = FormCreate
OnDestroy = FormDestroy
PixelsPerInch = 96
TextHeight = 13
object Image1: TImage
Left = 264
Top = 8
Width = 329
Height = 201
Stretch = True
end
object Image2: TImage
Left = 8
Top = 8
Width = 249
Height = 201
Stretch = True
end
object Button1: TButton
Left = 144
Top = 224
Width = 75
Height = 25
Caption = 'Button1'
TabOrder = 0
OnClick = Button1Click
end
object Panel1: TPanel
Left = 304
Top = 216
Width = 113
Height = 41
Caption = 'Panel1'
TabOrder = 1
object Button2: TButton
Left = 22
Top = 8
Width = 75
Height = 25
Caption = 'Button2'
TabOrder = 0
OnClick = Button2Click
end
end
object ColorDialog1: TColorDialog
Ctl3D = True
Left = 112
Top = 352
end
end
Palet değiştirme
Palet.pas
unit palet;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ComCtrls, ExtDlgs;
type
TForm1 = class(TForm)
Button1: TButton;
OpenPictureDialog1: TOpenPictureDialog;
SavePictureDialog1: TSavePictureDialog;
Button2: TButton;
Button3: TButton;
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure ScrambleBitmap;
end;
var
Form1: TForm1;
bitmap:tbitmap;
pal: PLogPalette;
implementation
{$R *.DFM}
procedure Tform1.ScrambleBitmap;
var
hpal: HPALETTE;
i: Integer;
begin
{$R-}
pal := nil;
try
GetMem(pal, sizeof(TLogPalette) + sizeof(TPaletteEntry) * 255);
pal.palVersion := $300;
pal.palNumEntries := 256;
for i := 0 to 255 do
begin
pal.palPalEntry[i].peRed := Random(255);
pal.palPalEntry[i].peGreen :=Random(255);
pal.palPalEntry[i].peBlue := Random(255);
end;
hpal := CreatePalette(pal^);
if hpal <> 0 then
Bitmap.Palette := hpal;
finally
FreeMem(pal);
end;
{$R+}
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
bitmap:=tbitmap.create;
bitmap.loadfromfile('c:program filesborlanddelphi 3imagessplash256colorfinance.bmp');
end;
procedure TForm1.FormPaint(Sender: TObject);
var
x, y: Integer;
begin
y := 0;
while y < Height do
begin
x := 0;
while x < Width do
begin
Canvas.Draw(x, y, Bitmap);
x := x + Bitmap.Width;
end;
y := y + Bitmap.Height;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ScrambleBitmap;
Invalidate;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
if openpicturedialog1.execute then
bitmap.loadfromfile(openpicturedialog1.filename);
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
if savepicturedialog1.execute then begin
bitmap.loadfromfile(savepicturedialog1.filename);
FormPaint(sender);
invalidate;
end;
end;
end.
Palet.dfm
object Form1: TForm1
Left = 200
Top = 108
Width = 696
Height = 480
Caption = 'Form1'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OnCreate = FormCreate
OnPaint = FormPaint
PixelsPerInch = 96
TextHeight = 13
object Button1: TButton
Left = 208
Top = 416
Width = 75
Height = 25
Caption = 'Palet değiştir'
TabOrder = 0
OnClick = Button1Click
end
object Button2: TButton
Left = 24
Top = 416
Width = 75
Height = 25
Caption = 'Resim Aç'
TabOrder = 1
OnClick = Button2Click
end
object Button3: TButton
Left = 112
Top = 416
Width = 81
Height = 25
Caption = 'Resim Kaydet'
TabOrder = 2
OnClick = Button3Click
end
object OpenPictureDialog1: TOpenPictureDialog
Filter =
'All (*.bmp;*.ico;*.emf;*.wmf)|*.bmp;*.ico;*.emf;*.wmf|Bitmaps (*' +
'.bmp)|*.bmp|Icons (*.ico)|*.ico|Enhanced Metafiles (*.emf)|*.emf' +
'|Metafiles (*.wmf)|*.wmf'
Left = 592
Top = 392
end
object SavePictureDialog1: TSavePictureDialog
Filter =
'All (*.bmp;*.ico;*.emf;*.wmf)|*.bmp;*.ico;*.emf;*.wmf|Bitmaps (*' +
'.bmp)|*.bmp|Icons (*.ico)|*.ico|Enhanced Metafiles (*.emf)|*.emf' +
'|Metafiles (*.wmf)|*.wmf'
Left = 512
Top = 392
end
end
Panodaki metnin diskteki bir dosyaya kaydedilmesi
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Clipbrd, StdCtrls ;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
function SaveClipboardTextDataToFile(
sFileTo : string ) : boolean;
var
ps1,
ps2 : PChar;
dwLen : DWord;
tf : TextFile;
hData : THandle;
begin
Result := False;
with Clipboard do
begin
try
Open;
if( HasFormat( CF_TEXT ) ) then
begin
hData :=
GetClipboardData( CF_TEXT );
ps1 := GlobalLock( hData );
dwLen := GlobalSize( hData );
ps2 := StrAlloc( 1 + dwLen );
StrLCopy( ps2, ps1, dwLen );
GlobalUnlock( hData );
AssignFile( tf, sFileTo );
ReWrite( tf );
Write( tf, ps2 );
CloseFile( tf );
StrDispose( ps2 );
Result := True;
end;
finally
Close;
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
SaveClipboardTextDataToFile('c:silclip.asc');
end;
end.
