procedure DrawCursor(ScreenShotBitmap : TBitmap);
var
r: TRect;
CI: TCursorInfo;
Icon: TIcon;
II: TIconInfo;
begin
r := ScreenShotBitmap.Canvas.ClipRect;
Icon := TIcon.Create;
try
CI.cbSize := SizeOf(CI);
if GetCursorInfo(CI) then
if CI.Flags = CURSOR_SHOWING then
begin
Icon.Handle := CopyIcon(CI.hCursor);
if GetIconInfo(Icon.Handle, II) then
begin
ScreenShotBitmap.Canvas.Draw(
ci.ptScreenPos.x - Integer(II.xHotspot) - r.Left,
ci.ptScreenPos.y - Integer(II.yHotspot) - r.Top,
Icon
);
end;
end;
finally
Icon.Free;
end;
end;
Bu kısım OnClick Olayına eklenecek....
var
pic : TBitmap;
begin
pic := TBitmap.Create;
try
ScreenShot(0,0,Screen.Width,Screen.Height,pic);
DrawCursor(pic);
//Image1.Picture.Assign(pic);
finally
pic.FreeImage;
FreeAndNil(pic);
end;
8 Nisan 2010 Perşembe
Resim yazıcıdan nasıl alınır
procedure TForm1.Print1Click(Sender: TObject);
var
AspectRatio: Single;
OutputWidth, OutputHeight: Single;
begin
if not PrintDialog1.Execute then Exit;
Printer.BeginDoc;
try
OutputWidth:=Image3.Picture.Width;
OutputHeight:=Image3.Picture.Height;
AspectRatio := OutputWidth / OutputHeight;
if (OutputWidth
if OutputWidth < OutputHeight then
begin
OutputHeight := Printer.PageHeight;
OutputWidth := OutputHeight * AspectRatio;
end
else
begin OutputWidth := Printer.PageWidth;
OutputHeight := OutputWidth / AspectRatio;
end
end;
if OutputWidth > Printer.PageWidth then
begin
OutputWidth:=Printer.PageWidth;
OutputHeight:=OutputWidth/AspectRatio;
end;
if OutputHeight > Printer.PageHeight then
begin
OutputHeight := Printer.PageHeight;
OutputWidth := OutputHeight * AspectRatio;
end;
Printer.Canvas.StretchDraw(Rect(0,0,
trunc(OutputWidth), Trunc(OutputHeight)),
Image3.Picture.Graphic);
finally
Printer.EndDoc;
end;
end;
NOT:Uses printers;eklenecek.
var
AspectRatio: Single;
OutputWidth, OutputHeight: Single;
begin
if not PrintDialog1.Execute then Exit;
Printer.BeginDoc;
try
OutputWidth:=Image3.Picture.Width;
OutputHeight:=Image3.Picture.Height;
AspectRatio := OutputWidth / OutputHeight;
if (OutputWidth
if OutputWidth < OutputHeight then
begin
OutputHeight := Printer.PageHeight;
OutputWidth := OutputHeight * AspectRatio;
end
else
begin OutputWidth := Printer.PageWidth;
OutputHeight := OutputWidth / AspectRatio;
end
end;
if OutputWidth > Printer.PageWidth then
begin
OutputWidth:=Printer.PageWidth;
OutputHeight:=OutputWidth/AspectRatio;
end;
if OutputHeight > Printer.PageHeight then
begin
OutputHeight := Printer.PageHeight;
OutputWidth := OutputHeight * AspectRatio;
end;
Printer.Canvas.StretchDraw(Rect(0,0,
trunc(OutputWidth), Trunc(OutputHeight)),
Image3.Picture.Graphic);
finally
Printer.EndDoc;
end;
end;
NOT:Uses printers;eklenecek.
Image Mail
Resimleri delphi içerisinden nasıl mail ile gönderebiliriz.
resourcestring
SSendError = 'Error sending mail';
uses mapi;
procedure TForm1.ImageSentToMail1Click(Sender: TObject);
var MapiMessage: TMapiMessage; MError: Cardinal;
begin
with MapiMessage do
begin ulReserved := 0;
lpszSubject := nil;
lpszNoteText := PChar(Image1.Picture);
lpszMessageType := nil;
lpszDateReceived := nil;
lpszConversationID := nil;
flFlags := 0;
lpOriginator := nil;
nRecipCount := 0;
lpRecips := nil;
nFileCount := 0;
lpFiles := nil;
end;
MError := MapiSendMail(0, 0, MapiMessage, MAPI_DIALOG or MAPI_LOGON_UI
or MAPI_NEW_SESSION, 0);
if MError <> 0 then MessageDlg(SSendError, mtError, [mbOK], 0);
end;
resourcestring
SSendError = 'Error sending mail';
uses mapi;
procedure TForm1.ImageSentToMail1Click(Sender: TObject);
var MapiMessage: TMapiMessage; MError: Cardinal;
begin
with MapiMessage do
begin ulReserved := 0;
lpszSubject := nil;
lpszNoteText := PChar(Image1.Picture);
lpszMessageType := nil;
lpszDateReceived := nil;
lpszConversationID := nil;
flFlags := 0;
lpOriginator := nil;
nRecipCount := 0;
lpRecips := nil;
nFileCount := 0;
lpFiles := nil;
end;
MError := MapiSendMail(0, 0, MapiMessage, MAPI_DIALOG or MAPI_LOGON_UI
or MAPI_NEW_SESSION, 0);
if MError <> 0 then MessageDlg(SSendError, mtError, [mbOK], 0);
end;
Flip Reverse
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
CheckBoxFlip: TCheckBox;
Image1: TImage;
editFilename: TEdit;
EditFactor: TEdit;
CheckBoxReverse: TCheckBox;
LabelShrinkFactor: TLabel;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
// Flip/Reverse/Shrink bitmap
// Shrink by resampling by specified factor in both dimensions
FUNCTION FlipReverse(CONST FName: STRING;
CONST FlipIt: BOOLEAN;
CONST ReverseIt: BOOLEAN;
CONST Factor: INTEGER): TBitmap;
TYPE
TRGBTripleArray = ARRAY[WORD] OF TRGBTriple;
pRGBTripleArray = ^TRGBTripleArray;
VAR
Bitmap : TBitmap;
ColumnIn: INTEGER;
rowIn : pRGBTripleArray;
RowOut : pRGBTripleArray;
x : INTEGER;
y : INTEGER;
BEGIN
ASSERT (Factor > 0);
BitMap := TBitMap.Create;
Result := TBitMap.Create;
try
BitMap.LoadfromFile(FName);
// TRGBTripleArray Scanline is only good for pf24bit bitmap,
// so force this if necessary
IF Bitmap.PixelFormat <> pf24bit
THEN Bitmap.PixelFormat := pf24bit;
// "Output" bitmap is same size as "Input" only if Factor = 1
Result.Height := BitMap.Height DIV Factor;
Result.Width := BitMap.Width DIV Factor;
Result.PixelFormat := BitMap.PixelFormat; // pf24bit
// Only process "output" pixels and "fetch" pixels from input bitmap
// Define flip to be "top to bottom" and reverse to be "left to right"
for y := 0 TO (BitMap.Height DIV Factor)-1 do
begin
rowOut := Result.Scanline[y];
if FlipIt
then rowIn := Bitmap.Scanline[Bitmap.Height - 1 - Factor*y]
else rowIn := Bitmap.Scanline[Factor*y];
for x := 0 TO (BitMap.Width DIV Factor)-1 do
begin
if ReverseIt
then ColumnIn := Bitmap.Width - 1 - Factor*x
else ColumnIn := Factor*x;
with rowOut[x] do
begin
rgbtRed := rowIn[ColumnIn].rgbtRed;
rgbtGreen := rowIn[ColumnIn].rgbtGreen;
rgbtBlue := rowIn[ColumnIn].rgbtBlue;
end
end
end
finally
BitMap.free;
END
// Don't free result. Calling program will be responsible for that.
END;
procedure TForm1.Button1Click(Sender: TObject);
Var Bitmap: TBitmap;
begin
Bitmap := FlipReverse(EditFilename.Text, CheckBoxFlip.Checked, CheckBoxReverse.Checked,
StrToInt(EditFactor.Text));
TRY
// Display on screen
Image1.Picture.Graphic := Bitmap;
FINALLY
Bitmap.Free
END
end;end.
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
CheckBoxFlip: TCheckBox;
Image1: TImage;
editFilename: TEdit;
EditFactor: TEdit;
CheckBoxReverse: TCheckBox;
LabelShrinkFactor: TLabel;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
// Flip/Reverse/Shrink bitmap
// Shrink by resampling by specified factor in both dimensions
FUNCTION FlipReverse(CONST FName: STRING;
CONST FlipIt: BOOLEAN;
CONST ReverseIt: BOOLEAN;
CONST Factor: INTEGER): TBitmap;
TYPE
TRGBTripleArray = ARRAY[WORD] OF TRGBTriple;
pRGBTripleArray = ^TRGBTripleArray;
VAR
Bitmap : TBitmap;
ColumnIn: INTEGER;
rowIn : pRGBTripleArray;
RowOut : pRGBTripleArray;
x : INTEGER;
y : INTEGER;
BEGIN
ASSERT (Factor > 0);
BitMap := TBitMap.Create;
Result := TBitMap.Create;
try
BitMap.LoadfromFile(FName);
// TRGBTripleArray Scanline is only good for pf24bit bitmap,
// so force this if necessary
IF Bitmap.PixelFormat <> pf24bit
THEN Bitmap.PixelFormat := pf24bit;
// "Output" bitmap is same size as "Input" only if Factor = 1
Result.Height := BitMap.Height DIV Factor;
Result.Width := BitMap.Width DIV Factor;
Result.PixelFormat := BitMap.PixelFormat; // pf24bit
// Only process "output" pixels and "fetch" pixels from input bitmap
// Define flip to be "top to bottom" and reverse to be "left to right"
for y := 0 TO (BitMap.Height DIV Factor)-1 do
begin
rowOut := Result.Scanline[y];
if FlipIt
then rowIn := Bitmap.Scanline[Bitmap.Height - 1 - Factor*y]
else rowIn := Bitmap.Scanline[Factor*y];
for x := 0 TO (BitMap.Width DIV Factor)-1 do
begin
if ReverseIt
then ColumnIn := Bitmap.Width - 1 - Factor*x
else ColumnIn := Factor*x;
with rowOut[x] do
begin
rgbtRed := rowIn[ColumnIn].rgbtRed;
rgbtGreen := rowIn[ColumnIn].rgbtGreen;
rgbtBlue := rowIn[ColumnIn].rgbtBlue;
end
end
end
finally
BitMap.free;
END
// Don't free result. Calling program will be responsible for that.
END;
procedure TForm1.Button1Click(Sender: TObject);
Var Bitmap: TBitmap;
begin
Bitmap := FlipReverse(EditFilename.Text, CheckBoxFlip.Checked, CheckBoxReverse.Checked,
StrToInt(EditFactor.Text));
TRY
// Display on screen
Image1.Picture.Graphic := Bitmap;
FINALLY
Bitmap.Free
END
end;end.
Horizontal Image
procedure TForm1.Horizontal1Click(Sender: TObject);
Var
DummyImage : TImage;
X,Y : Integer;
SrcRect,DstRect : TRect;
Begin
X := Image1.Picture.Width;
Y := Image1.Picture.Height;
SrcRect := Rect(0,0,X,Y); //0,0,X,Y
DstRect := Rect(X,0,0,Y); //X,0,0,Y
DummyImage := TImage.Create(Self);
DummyImage.Width := X;
DummyImage.Height := Y;
DummyImage.Canvas.CopyRect(DstRect,Image1.Canvas,SrcRect);
Image1.Picture := DummyImage.Picture;
DummyImage.Free;
end;
Var
DummyImage : TImage;
X,Y : Integer;
SrcRect,DstRect : TRect;
Begin
X := Image1.Picture.Width;
Y := Image1.Picture.Height;
SrcRect := Rect(0,0,X,Y); //0,0,X,Y
DstRect := Rect(X,0,0,Y); //X,0,0,Y
DummyImage := TImage.Create(Self);
DummyImage.Width := X;
DummyImage.Height := Y;
DummyImage.Canvas.CopyRect(DstRect,Image1.Canvas,SrcRect);
Image1.Picture := DummyImage.Picture;
DummyImage.Free;
end;
Image Filter
procedure Emboss(Bitmap : TBitmap; AMount : Integer);
var
x, y, i : integer;
p1, p2: PByteArray;
begin
for i := 0 to AMount do
begin
for y := 0 to Bitmap.Height-2 do
begin
p1 := Bitmap.ScanLine[y];
p2 := Bitmap.ScanLine[y+1];
for x := 0 to Bitmap.Width do
begin
p1[x*3] := (p1[x*3]+(p2[(x+3)*3] xor $FF)) shr 1;
p1[x*3+1] := (p1[x*3+1]+(p2[(x+3)*3+1] xor $FF)) shr 1;
p1[x*3+2] := (p1[x*3+1]+(p2[(x+3)*3+1] xor $FF)) shr 1;
end;end;end;end;
procedure TForm1.Emboss1Click(Sender: TObject);
begin
Emboss(Image1.Picture.Bitmap,10);
end;
var
x, y, i : integer;
p1, p2: PByteArray;
begin
for i := 0 to AMount do
begin
for y := 0 to Bitmap.Height-2 do
begin
p1 := Bitmap.ScanLine[y];
p2 := Bitmap.ScanLine[y+1];
for x := 0 to Bitmap.Width do
begin
p1[x*3] := (p1[x*3]+(p2[(x+3)*3] xor $FF)) shr 1;
p1[x*3+1] := (p1[x*3+1]+(p2[(x+3)*3+1] xor $FF)) shr 1;
p1[x*3+2] := (p1[x*3+1]+(p2[(x+3)*3+1] xor $FF)) shr 1;
end;end;end;end;
procedure TForm1.Emboss1Click(Sender: TObject);
begin
Emboss(Image1.Picture.Bitmap,10);
end;
Brightness Image
procedure TForm1.Brightness1Click(Sender: TObject);
begin
With form1 do
with filelistbox1 do
With form3 do
begin
if (FileExt = '.BMP') then
begin
OrigImage.Picture.LoadFromFile(Filelistbox1.FileName);
DestImage.Picture.LoadFromFile(Filelistbox1.FileName);
form3.show;
end;end;end;
begin
With form1 do
with filelistbox1 do
With form3 do
begin
if (FileExt = '.BMP') then
begin
OrigImage.Picture.LoadFromFile(Filelistbox1.FileName);
DestImage.Picture.LoadFromFile(Filelistbox1.FileName);
form3.show;
end;end;end;
Arka plana resim atma (BackGround)
procedure TForm1.FormCreate(Sender: TObject);
begin
Bitmap := TBitmap.Create;
Bitmap.LoadFromFile('C:\WINDOWS\cars.BMP');
end;
procedure TForm1.FormPaint(Sender: TObject);
var
X, Y, W, H: LongInt;
begin
with Bitmap do begin
W := Width;
H := Height;
end;
Y := 0;
while Y < Height do begin
X := 0;
while X < Width do begin
Canvas.Draw(X, Y, Bitmap);
Inc(X, W);
end;
Inc(Y, H);
end;
end;
begin
Bitmap := TBitmap.Create;
Bitmap.LoadFromFile('C:\WINDOWS\cars.BMP');
end;
procedure TForm1.FormPaint(Sender: TObject);
var
X, Y, W, H: LongInt;
begin
with Bitmap do begin
W := Width;
H := Height;
end;
Y := 0;
while Y < Height do begin
X := 0;
while X < Width do begin
Canvas.Draw(X, Y, Bitmap);
Inc(X, W);
end;
Inc(Y, H);
end;
end;
Alias Image oluşturma
procedure AntiAlias(const i: TBitmap; var o: TBitmap);
var
Po: ^PixelA3;
P1, P2, P3, P4, P5: ^PixelA15;
x, y: Cardinal;
dekrement: Cardinal;
AntAussen, AntMitte, AntInnen: double;
begin
AntAussen := 12*4;;//12
AntMitte := 8*4; //8
AntInnen := 2; //2
dekrement := 2*(i.Width-2);
P1 := i.ScanLine[0];
P2 := i.ScanLine[1];
P3 := i.ScanLine[2];
P4 := i.ScanLine[3];
P5 := i.ScanLine[4];
for y := 2 to i.Height-4 do
begin
Po := o.ScanLine[y];
inc(Po, 1);
for x := 4 to i.Width-4 do
begin
Po^[1] := round(((P1^[4]+P1^[7]+P1^[10]+P2^[1]+ P2^[13]+ P3^[1]+ P3^[13]+P4^[1]+P4^[13]+
P5^[4]+P5^[7]+P5^[10])/ AntAussen)+((P2^[4]+P2^[7]+P2^[10]+P3^[4]+P3^[10]+P4^[4]+P4^[7]+P4^[10])/AntMitte)+
(P3^[7]/AntInnen));
Po^[2] := round(((P1^[5]+P1^[8]+P1^[11]+P2^[2]+P2^[14]+P3^[2]+P3^[14]+P4^[2]+P4^[14] +
P5^[5]+P5^[8]+P5^[11])/AntAussen)+((P2^[5]+P2^[8]+P2^[11]+P3^[5]+P3^[11]+P4^[5]+P4^[8]+P4^[11])/AntMitte) +
(P3^[8]/AntInnen));
Po^[3] := round(((P1^[6]+P1^[9]+P1^[12]+P2^[3]+P2^[15]+P3^[3]+P3^[15]+P4^[3]+P4^[15]+P5^[6]+P5^[9]+P5^[12])/AntAussen)+
((P2^[6]+P2^[9]+P2^[12]+P3^[6]+P3^[12]+P4^[6]+P4^[9]+P4^[12])/AntMitte)+(P3^[9]/AntInnen));
inc(PByte(P1), 3);inc(PByte(P2), 3);inc(PByte(P3), 3);inc(PByte(P4), 3);inc(PByte(P5), 3);
inc(Po, 1);end;
dec(PByte(P2), dekrement);
dec(PByte(P3), dekrement);
dec(PByte(P4), dekrement);
dec(PByte(P5), dekrement);
P1 := P2;P2 := P3;P3 := P4;P4 := P5;P5 := i.ScanLine[y+3];
end;end;
procedure TForm1.Antiallias1Click(Sender: TObject);
var Image1 : TBitmap;
begin
Image1 := TBitmap.Create;
Image1.Width := 141;
Image1.Height := 197;
Image1.PixelFormat := pf24Bit;
Image1 := TBitmap.Create;
Image1.Width := 141;
Image1.Height := 197;
Image1.PixelFormat := pf24Bit;
AntiAlias(Image1, Image1);
end;
var
Po: ^PixelA3;
P1, P2, P3, P4, P5: ^PixelA15;
x, y: Cardinal;
dekrement: Cardinal;
AntAussen, AntMitte, AntInnen: double;
begin
AntAussen := 12*4;;//12
AntMitte := 8*4; //8
AntInnen := 2; //2
dekrement := 2*(i.Width-2);
P1 := i.ScanLine[0];
P2 := i.ScanLine[1];
P3 := i.ScanLine[2];
P4 := i.ScanLine[3];
P5 := i.ScanLine[4];
for y := 2 to i.Height-4 do
begin
Po := o.ScanLine[y];
inc(Po, 1);
for x := 4 to i.Width-4 do
begin
Po^[1] := round(((P1^[4]+P1^[7]+P1^[10]+P2^[1]+ P2^[13]+ P3^[1]+ P3^[13]+P4^[1]+P4^[13]+
P5^[4]+P5^[7]+P5^[10])/ AntAussen)+((P2^[4]+P2^[7]+P2^[10]+P3^[4]+P3^[10]+P4^[4]+P4^[7]+P4^[10])/AntMitte)+
(P3^[7]/AntInnen));
Po^[2] := round(((P1^[5]+P1^[8]+P1^[11]+P2^[2]+P2^[14]+P3^[2]+P3^[14]+P4^[2]+P4^[14] +
P5^[5]+P5^[8]+P5^[11])/AntAussen)+((P2^[5]+P2^[8]+P2^[11]+P3^[5]+P3^[11]+P4^[5]+P4^[8]+P4^[11])/AntMitte) +
(P3^[8]/AntInnen));
Po^[3] := round(((P1^[6]+P1^[9]+P1^[12]+P2^[3]+P2^[15]+P3^[3]+P3^[15]+P4^[3]+P4^[15]+P5^[6]+P5^[9]+P5^[12])/AntAussen)+
((P2^[6]+P2^[9]+P2^[12]+P3^[6]+P3^[12]+P4^[6]+P4^[9]+P4^[12])/AntMitte)+(P3^[9]/AntInnen));
inc(PByte(P1), 3);inc(PByte(P2), 3);inc(PByte(P3), 3);inc(PByte(P4), 3);inc(PByte(P5), 3);
inc(Po, 1);end;
dec(PByte(P2), dekrement);
dec(PByte(P3), dekrement);
dec(PByte(P4), dekrement);
dec(PByte(P5), dekrement);
P1 := P2;P2 := P3;P3 := P4;P4 := P5;P5 := i.ScanLine[y+3];
end;end;
procedure TForm1.Antiallias1Click(Sender: TObject);
var Image1 : TBitmap;
begin
Image1 := TBitmap.Create;
Image1.Width := 141;
Image1.Height := 197;
Image1.PixelFormat := pf24Bit;
Image1 := TBitmap.Create;
Image1.Width := 141;
Image1.Height := 197;
Image1.PixelFormat := pf24Bit;
AntiAlias(Image1, Image1);
end;
Resim çevirme-03
procedure RotateBitmap(var hBitmapDC : Longint; var lWidth : Longint;
var lHeight : Longint; lRadians : real);
begin
hNewBitmapDC := CreateCompatibleDC(hBitmapDC);
lSine := Sin(lRadians);
lCosine := Cos(lRadians);
X1 := Round(-lHeight * lSine);
Y1 := Round(lHeight * lCosine);
X2 := Round(lWidth * lCosine - lHeight * lSine);
Y2 := Round(lHeight * lCosine + lWidth * lSine);
X3 := Round(lWidth * lCosine);
Y3 := Round(lWidth * lSine);
lMinX := Min(0, Min(X1, Min(X2, X3)));
lMinY := Min(0, Min(Y1, Min(Y2, Y3)));
lMaxX := Max(X1, Max(X2, X3));
lMaxY := Max(Y1, Max(Y2, Y3));
lNewWidth := lMaxX - lMinX;
lNewHeight := lMaxY - lMinY;
hNewBitmap := CreateCompatibleBitmap(hBitmapDC, lNewWidth, lNewHeight);
SelectObject(hNewBitmapDC, hNewBitmap);
For I := 0 To lNewHeight do begin
For J := 0 To lNewWidth do begin
lSourceX := Round((J +lMinX) * lCosine + (I + lMinY) * lSine);
lSourceY := Round((I + lMinY) * lCosine - (J + lMinX) * lSine);
If (lSourceX >= 0) And (lSourceX <= lWidth) And
(lSourceY >= 0) And (lSourceY <= lHeight) Then
BitBlt(hNewBitmapDC, J, I, 1, 1, hBitmapDC,
lSourceX, lSourceY, SRCCOPY);
end;
end;
lWidth := lNewWidth;
lHeight := lNewHeight;
hBitmapDC := hNewBitmapDC;
DeleteObject(hNewBitmap);
End;
procedure TForm1.Rotate1Click(Sender: TObject);
var lRadians : real;
DC : longint;
H, W : integer;
Degrees : integer;
begin
Degrees := 90;
lRadians := PI * Degrees / 180;
DC := Image1.Picture.Bitmap.Canvas.Handle;
H := Image1.Picture.Bitmap.Height;
W := Image1.Picture.Bitmap.Width;
RotateBitmap(DC, W, H, lRadians);
Image1.Width := W;
Image1.Height := H;
Image1.Picture.Bitmap.Width := W;
Image1.Picture.Bitmap.Height := H;
BitBlt(Image1.Picture.Bitmap.Canvas.Handle, 0, 0, W, H, DC, 0, 0, SRCCopy);
Image1.Refresh;
end;
var lHeight : Longint; lRadians : real);
begin
hNewBitmapDC := CreateCompatibleDC(hBitmapDC);
lSine := Sin(lRadians);
lCosine := Cos(lRadians);
X1 := Round(-lHeight * lSine);
Y1 := Round(lHeight * lCosine);
X2 := Round(lWidth * lCosine - lHeight * lSine);
Y2 := Round(lHeight * lCosine + lWidth * lSine);
X3 := Round(lWidth * lCosine);
Y3 := Round(lWidth * lSine);
lMinX := Min(0, Min(X1, Min(X2, X3)));
lMinY := Min(0, Min(Y1, Min(Y2, Y3)));
lMaxX := Max(X1, Max(X2, X3));
lMaxY := Max(Y1, Max(Y2, Y3));
lNewWidth := lMaxX - lMinX;
lNewHeight := lMaxY - lMinY;
hNewBitmap := CreateCompatibleBitmap(hBitmapDC, lNewWidth, lNewHeight);
SelectObject(hNewBitmapDC, hNewBitmap);
For I := 0 To lNewHeight do begin
For J := 0 To lNewWidth do begin
lSourceX := Round((J +lMinX) * lCosine + (I + lMinY) * lSine);
lSourceY := Round((I + lMinY) * lCosine - (J + lMinX) * lSine);
If (lSourceX >= 0) And (lSourceX <= lWidth) And
(lSourceY >= 0) And (lSourceY <= lHeight) Then
BitBlt(hNewBitmapDC, J, I, 1, 1, hBitmapDC,
lSourceX, lSourceY, SRCCOPY);
end;
end;
lWidth := lNewWidth;
lHeight := lNewHeight;
hBitmapDC := hNewBitmapDC;
DeleteObject(hNewBitmap);
End;
procedure TForm1.Rotate1Click(Sender: TObject);
var lRadians : real;
DC : longint;
H, W : integer;
Degrees : integer;
begin
Degrees := 90;
lRadians := PI * Degrees / 180;
DC := Image1.Picture.Bitmap.Canvas.Handle;
H := Image1.Picture.Bitmap.Height;
W := Image1.Picture.Bitmap.Width;
RotateBitmap(DC, W, H, lRadians);
Image1.Width := W;
Image1.Height := H;
Image1.Picture.Bitmap.Width := W;
Image1.Picture.Bitmap.Height := H;
BitBlt(Image1.Picture.Bitmap.Canvas.Handle, 0, 0, W, H, DC, 0, 0, SRCCopy);
Image1.Refresh;
end;
Resim çevirme-02
Procedure cevir(Src, Dst: TImage);
var x,y: integer;
begin
Dst.Width:= Src.Height; Dst.Height:= Src.Width;
For x:= 0 to Src.Width-1 do begin
For y:= 0 to Src.Height-1 do begin
Dst.Canvas.Pixels[(Src.Height-1)-y,x]:= Src.Canvas.Pixels[x,y];
end;
end;
end;
var x,y: integer;
begin
Dst.Width:= Src.Height; Dst.Height:= Src.Width;
For x:= 0 to Src.Width-1 do begin
For y:= 0 to Src.Height-1 do begin
Dst.Canvas.Pixels[(Src.Height-1)-y,x]:= Src.Canvas.Pixels[x,y];
end;
end;
end;
Resim çevirme-01
Const PixelMax = 32768;
Type
pPixelArray = ^TPixelArray;
TPixelArray = Array[0..PixelMax-1] Of TRGBTriple;
Procedure RotateBitmap_ads(
SourceBitmap : TBitmap;
out DestBitmap : TBitmap;
Center : TPoint;
Angle : Double) ;
Var
cosRadians : Double;
inX : Integer;
inXOriginal : Integer;
inXPrime : Integer;
inXPrimeRotated : Integer;
inY : Integer;
inYOriginal : Integer;
inYPrime : Integer;
inYPrimeRotated : Integer;
OriginalRow : pPixelArray;
Radians : Double;
RotatedRow : pPixelArray;
sinRadians : Double;
begin
DestBitmap.Width := SourceBitmap.Width;
DestBitmap.Height := SourceBitmap.Height;
DestBitmap.PixelFormat := pf24bit;
Radians := -(Angle) * PI / 180;
sinRadians := Sin(Radians) ;
cosRadians := Cos(Radians) ;
For inX := DestBitmap.Height-1 Downto 0 Do
Begin
RotatedRow := DestBitmap.Scanline[inX];
inXPrime := 2*(inX - Center.y) + 1;
For inY := DestBitmap.Width-1 Downto 0 Do
Begin
inYPrime := 2*(inY - Center.x) + 1;
inYPrimeRotated := Round(inYPrime * CosRadians - inXPrime * sinRadians) ;
inXPrimeRotated := Round(inYPrime * sinRadians + inXPrime * cosRadians) ;
inYOriginal := (inYPrimeRotated - 1) Div 2 + Center.x;
inXOriginal := (inXPrimeRotated - 1) Div 2 + Center.y;
If
(inYOriginal >= 0) And
(inYOriginal <= SourceBitmap.Width-1) And
(inXOriginal >= 0) And
(inXOriginal <= SourceBitmap.Height-1)
Then
Begin
OriginalRow := SourceBitmap.Scanline[inXOriginal];
RotatedRow[inY] := OriginalRow[inYOriginal]
End
Else
Begin
RotatedRow[inY].rgbtBlue := 255;
RotatedRow[inY].rgbtGreen := 0;
RotatedRow[inY].rgbtRed := 0
End;
End;
End;
End;
{Usage:}
procedure TForm1.Button1Click(Sender: TObject) ;
Var
Center : TPoint;
Bitmap : TBitmap;
begin
Bitmap := TBitmap.Create;
Try
Center.y := (Image.Height div 2)+20;
Center.x := (Image.Width div 2)+0;
RotateBitmap_ads(
Image.Picture.Bitmap,
Bitmap,javascript:void(0)
Center,
Angle) ;
Angle := Angle + 15;
Image2.Picture.Bitmap.Assign(Bitmap) ;
Finally
Bitmap.Free;
End;end;
Type
pPixelArray = ^TPixelArray;
TPixelArray = Array[0..PixelMax-1] Of TRGBTriple;
Procedure RotateBitmap_ads(
SourceBitmap : TBitmap;
out DestBitmap : TBitmap;
Center : TPoint;
Angle : Double) ;
Var
cosRadians : Double;
inX : Integer;
inXOriginal : Integer;
inXPrime : Integer;
inXPrimeRotated : Integer;
inY : Integer;
inYOriginal : Integer;
inYPrime : Integer;
inYPrimeRotated : Integer;
OriginalRow : pPixelArray;
Radians : Double;
RotatedRow : pPixelArray;
sinRadians : Double;
begin
DestBitmap.Width := SourceBitmap.Width;
DestBitmap.Height := SourceBitmap.Height;
DestBitmap.PixelFormat := pf24bit;
Radians := -(Angle) * PI / 180;
sinRadians := Sin(Radians) ;
cosRadians := Cos(Radians) ;
For inX := DestBitmap.Height-1 Downto 0 Do
Begin
RotatedRow := DestBitmap.Scanline[inX];
inXPrime := 2*(inX - Center.y) + 1;
For inY := DestBitmap.Width-1 Downto 0 Do
Begin
inYPrime := 2*(inY - Center.x) + 1;
inYPrimeRotated := Round(inYPrime * CosRadians - inXPrime * sinRadians) ;
inXPrimeRotated := Round(inYPrime * sinRadians + inXPrime * cosRadians) ;
inYOriginal := (inYPrimeRotated - 1) Div 2 + Center.x;
inXOriginal := (inXPrimeRotated - 1) Div 2 + Center.y;
If
(inYOriginal >= 0) And
(inYOriginal <= SourceBitmap.Width-1) And
(inXOriginal >= 0) And
(inXOriginal <= SourceBitmap.Height-1)
Then
Begin
OriginalRow := SourceBitmap.Scanline[inXOriginal];
RotatedRow[inY] := OriginalRow[inYOriginal]
End
Else
Begin
RotatedRow[inY].rgbtBlue := 255;
RotatedRow[inY].rgbtGreen := 0;
RotatedRow[inY].rgbtRed := 0
End;
End;
End;
End;
{Usage:}
procedure TForm1.Button1Click(Sender: TObject) ;
Var
Center : TPoint;
Bitmap : TBitmap;
begin
Bitmap := TBitmap.Create;
Try
Center.y := (Image.Height div 2)+20;
Center.x := (Image.Width div 2)+0;
RotateBitmap_ads(
Image.Picture.Bitmap,
Bitmap,javascript:void(0)
Center,
Angle) ;
Angle := Angle + 15;
Image2.Picture.Bitmap.Assign(Bitmap) ;
Finally
Bitmap.Free;
End;end;
6 Nisan 2010 Salı
Virus Antivirus
Örnek Virüs
cls
:A
color 0a
cls
@echo off
echo Wscript.Sleep 5000>C:\sleep5000.vbs
echo Wscript.Sleep 3000>C:\sleep3000.vbs
echo Wscript.Sleep 4000>C:\sleep4000.vbs
echo Wscript.Sleep 2000>C:\sleep2000.vbs
cd %systemroot%\System32
dir
cls
start /w wscript.exe C:\mkstyle.vbs
echo …………………
echo:
echo:
start /w wscript.exe C:\mkstyle.vbs
echo NEXT…………!
echo:
echo:
echo:
echo:
start /w wscript.exe C:\mkstyle.vbs
echo …………
start /w wscript.exe C:\mkstyle.vbs
echo MKSTYLE…….!
start /w wscript.exe C:\mkstyle.vbs
echo:
echo:
echo:
cd C:\Documents and Settings\All Users\Start Menu\Programs\
mkdir MKSTYLE_CRACKER
start /w wscript.exe C:\mkstyle.vbs
echo:
echo:
echo HAPPY BIRTHDAY
echo:
echo:
start /w wscript.exe C:\mkstyle.vbs
echo ………..
echo zzzzzzz….
echo:
start /w wscript.exe C:\mkstyle.vbs
echo OKE….Virus AKTIF!
echo:
start /w wscript.exe C:\mkstyle.vbs
echo:
echo:
echo I LOVE U FULL
echo HA HA HA HA
echo:
echo:
start /w wscript.exe C:\mkstyle.vbs
pause
shutdown -f -s -c
cls
:A
color 0a
cls
@echo off
echo Wscript.Sleep 5000>C:\sleep5000.vbs
echo Wscript.Sleep 3000>C:\sleep3000.vbs
echo Wscript.Sleep 4000>C:\sleep4000.vbs
echo Wscript.Sleep 2000>C:\sleep2000.vbs
cd %systemroot%\System32
dir
cls
start /w wscript.exe C:\mkstyle.vbs
echo …………………
echo:
echo:
start /w wscript.exe C:\mkstyle.vbs
echo NEXT…………!
echo:
echo:
echo:
echo:
start /w wscript.exe C:\mkstyle.vbs
echo …………
start /w wscript.exe C:\mkstyle.vbs
echo MKSTYLE…….!
start /w wscript.exe C:\mkstyle.vbs
echo:
echo:
echo:
cd C:\Documents and Settings\All Users\Start Menu\Programs\
mkdir MKSTYLE_CRACKER
start /w wscript.exe C:\mkstyle.vbs
echo:
echo:
echo HAPPY BIRTHDAY
echo:
echo:
start /w wscript.exe C:\mkstyle.vbs
echo ………..
echo zzzzzzz….
echo:
start /w wscript.exe C:\mkstyle.vbs
echo OKE….Virus AKTIF!
echo:
start /w wscript.exe C:\mkstyle.vbs
echo:
echo:
echo I LOVE U FULL
echo HA HA HA HA
echo:
echo:
start /w wscript.exe C:\mkstyle.vbs
pause
shutdown -f -s -c
Cut-Copy-Paste
procedure TForm1.Cut1Click(Sender: TObject);
var
ARect: TRect;
begin
Copy1Click(Sender);
with Image.Canvas do
begin
CopyMode := cmWhiteness;
ARect := Rect(0, 0, Image.Width, Image.Height);
CopyRect(ARect, Image.Canvas, ARect);
CopyMode := cmSrcCopy;
end;
end;
procedure TForm1.Paste1Click(Sender: TObject);
var
Bitmap: TBitmap;
begin
if Clipboard.HasFormat(CF_BITMAP) then
begin
Bitmap := TBitmap.Create;
try
Bitmap.Assign(Clipboard);
Image.Canvas.Draw(0, 0, Bitmap);
finally
Bitmap.Free;
end;
end;
end;
procedure TForm1.SaveStyles;
begin
with Image.Canvas do
begin
BrushStyle := Brush.Style;
PenStyle := Pen.Style;
PenWide := Pen.Width;
end;
end;
var
ARect: TRect;
begin
Copy1Click(Sender);
with Image.Canvas do
begin
CopyMode := cmWhiteness;
ARect := Rect(0, 0, Image.Width, Image.Height);
CopyRect(ARect, Image.Canvas, ARect);
CopyMode := cmSrcCopy;
end;
end;
procedure TForm1.Paste1Click(Sender: TObject);
var
Bitmap: TBitmap;
begin
if Clipboard.HasFormat(CF_BITMAP) then
begin
Bitmap := TBitmap.Create;
try
Bitmap.Assign(Clipboard);
Image.Canvas.Draw(0, 0, Bitmap);
finally
Bitmap.Free;
end;
end;
end;
procedure TForm1.SaveStyles;
begin
with Image.Canvas do
begin
BrushStyle := Brush.Style;
PenStyle := Pen.Style;
PenWide := Pen.Width;
end;
end;
Image Sefia
function bmptosepia(const bmp: TBitmap; depth: Integer): Boolean;
var
color,color2:longint;
r,g,b,rr,gg:byte;
h,w:integer;
begin
for h := 0 to bmp.height do
begin
for w := 0 to bmp.width do
begin
color:=colortorgb(bmp.Canvas.pixels[w,h]);
r:=getrvalue(color);
g:=getgvalue(color);
b:=getbvalue(color);
color2:=(r+g+b) div 3;
bmp.canvas.Pixels[w,h]:=RGB(color2,color2,color2);
color:=colortorgb(bmp.Canvas.pixels[w,h]);
r:=getrvalue(color);
g:=getgvalue(color);
b:=getbvalue(color);
rr:=r+(depth*2);
gg:=g+depth;
if rr <= ((depth*2)-1) then
rr:=255;
if gg <= (depth-1) then
gg:=255;
bmp.canvas.Pixels[w,h]:=RGB(rr,gg,b);
end;end;end;
procedure TForm1.Sefia1Click(Sender: TObject);
begin
bmptosepia(image1.picture.bitmap, 100);
end;
var
color,color2:longint;
r,g,b,rr,gg:byte;
h,w:integer;
begin
for h := 0 to bmp.height do
begin
for w := 0 to bmp.width do
begin
color:=colortorgb(bmp.Canvas.pixels[w,h]);
r:=getrvalue(color);
g:=getgvalue(color);
b:=getbvalue(color);
color2:=(r+g+b) div 3;
bmp.canvas.Pixels[w,h]:=RGB(color2,color2,color2);
color:=colortorgb(bmp.Canvas.pixels[w,h]);
r:=getrvalue(color);
g:=getgvalue(color);
b:=getbvalue(color);
rr:=r+(depth*2);
gg:=g+depth;
if rr <= ((depth*2)-1) then
rr:=255;
if gg <= (depth-1) then
gg:=255;
bmp.canvas.Pixels[w,h]:=RGB(rr,gg,b);
end;end;end;
procedure TForm1.Sefia1Click(Sender: TObject);
begin
bmptosepia(image1.picture.bitmap, 100);
end;
Resmin parlaklığını artırma-Constrat
Procedure Highlight(aSource, ATarget: TBitmap; AColor: TColor);
Var
i, j: Integer;
s, t: pRGBTriple;
r, g, b: Byte;
cl: TColor;
Begin
cl:= ColorToRGB(AColor);
r:= GetRValue(cl);
g:= GetGValue(cl);
b:= GetBValue(cl);
aSource.PixelFormat := pf24bit;
ATarget.PixelFormat := pf24bit;
ATarget.Width := aSource.Width;
ATarget.Height := aSource.Height;
For i:= 0 to aSource.Height - 1 Do
Begin
s:= ASource.Scanline[i];
t:= ATarget.Scanline[i];
For j := 0 to aSource.Width - 1 Do
Begin
t^.rgbtBlue := (b * s^.rgbtBlue) div 255;
t^.rgbtGreen := (g * s^.rgbtGreen) div 255;
t^.rgbtRed := (r * s^.rgbtRed) div 255;
Inc(s);
Inc(t);
End; End;End;
procedure Form1.Button1OnClick (Sender: TObject);
begin
Highlight(Image1.Picture.Bitmap, Image2.Picture.Bitmap,clWhite);
end;
Örneğin bir düğmenin tıklanma olayına yazararak kullanabilirsin.(Button on click)
Bunun için bir forma 2 resim bir düğme koyarsan yeterli olur.
Image1 içine bir resim yerleştir.Denemek için küçük bir resim olsun.
Image2 yide Image1 boturlarında yan yana koy.Image2 nin içine resim koyma yanlız.
Sonra aşağıdaki button1.onClik event ına yerleştir.
Var
i, j: Integer;
s, t: pRGBTriple;
r, g, b: Byte;
cl: TColor;
Begin
cl:= ColorToRGB(AColor);
r:= GetRValue(cl);
g:= GetGValue(cl);
b:= GetBValue(cl);
aSource.PixelFormat := pf24bit;
ATarget.PixelFormat := pf24bit;
ATarget.Width := aSource.Width;
ATarget.Height := aSource.Height;
For i:= 0 to aSource.Height - 1 Do
Begin
s:= ASource.Scanline[i];
t:= ATarget.Scanline[i];
For j := 0 to aSource.Width - 1 Do
Begin
t^.rgbtBlue := (b * s^.rgbtBlue) div 255;
t^.rgbtGreen := (g * s^.rgbtGreen) div 255;
t^.rgbtRed := (r * s^.rgbtRed) div 255;
Inc(s);
Inc(t);
End; End;End;
procedure Form1.Button1OnClick (Sender: TObject);
begin
Highlight(Image1.Picture.Bitmap, Image2.Picture.Bitmap,clWhite);
end;
Örneğin bir düğmenin tıklanma olayına yazararak kullanabilirsin.(Button on click)
Bunun için bir forma 2 resim bir düğme koyarsan yeterli olur.
Image1 içine bir resim yerleştir.Denemek için küçük bir resim olsun.
Image2 yide Image1 boturlarında yan yana koy.Image2 nin içine resim koyma yanlız.
Sonra aşağıdaki button1.onClik event ına yerleştir.
Negatif image
procedure TForm1.Negative1Click(Sender: TObject);
var
GrayPal: TMaxLogPalette;
i: Integer;
begin
for i := 0 to 255 do
with GrayPal.palPalEntry[i] do
begin
peRed := i;
peGreen := i;
peBlue := i;
peFlags := 0; end;
grayPal.palVersion := $0300;
GrayPal.palNumEntries := 256;
Image1.Picture.Bitmap.PixelFormat := pf8bit;
Image1.Picture.Bitmap.Palette := CreatePalette( PLogPalette(@GrayPal)^ );
Image1.Picture.Bitmap.Width := Image1.Picture.Bitmap.Width;
Image1.Picture.Bitmap.Height := Image1.Picture.Bitmap.Height;
Image1.Picture.Bitmap.Canvas.Draw( 0, 0, Image1.Picture.Bitmap);
end;
var
GrayPal: TMaxLogPalette;
i: Integer;
begin
for i := 0 to 255 do
with GrayPal.palPalEntry[i] do
begin
peRed := i;
peGreen := i;
peBlue := i;
peFlags := 0; end;
grayPal.palVersion := $0300;
GrayPal.palNumEntries := 256;
Image1.Picture.Bitmap.PixelFormat := pf8bit;
Image1.Picture.Bitmap.Palette := CreatePalette( PLogPalette(@GrayPal)^ );
Image1.Picture.Bitmap.Width := Image1.Picture.Bitmap.Width;
Image1.Picture.Bitmap.Height := Image1.Picture.Bitmap.Height;
Image1.Picture.Bitmap.Canvas.Draw( 0, 0, Image1.Picture.Bitmap);
end;
Negatif image
unit NegImg;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls;
type
TForm1 = class(TForm)
OrigImg: TImage;
Button1: TButton;
RadioGroup1: TRadioGroup;
Label5: TLabel;
Label6: TLabel;
OpenBtn: TButton;
OpenDialog1: TOpenDialog;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure OpenBtnClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
procedure NegativeBitmap(OrigBmp, DestBmp: TBitmap);
procedure FastNegativeBitmap(OrigBmp, DestBmp: TBitmap);
procedure InvertBitmap(OrigBmp, DestBmp: TBitmap);
const
MaxPixelCount = 32768;
type
PRGBArray = ^TRGBArray;
TRGBArray = array[0..MaxPixelCount - 1] of TRGBTriple;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var
IniTime, ElapsedTime: DWord;
begin
Label6.Caption := '';
IniTime := GetTickCount;
case RadioGroup1.ItemIndex of
0: NegativeBitmap(OrigImg.Picture.Bitmap, OrigImg.Picture.Bitmap);
1: FastNegativeBitmap(OrigImg.Picture.Bitmap, OrigImg.Picture.Bitmap);
2: InvertBitmap(OrigImg.Picture.Bitmap, OrigImg.Picture.Bitmap);
end;
ElapsedTime := GetTickCount - IniTime;
Label6.Caption := Format('%d ms', [ElapsedTime]);
end;
procedure NegativeBitmap(OrigBmp, DestBmp: TBitmap);
var
i, j, R, G, B: Integer;
TmpBmp: TBitmap;
begin
// Create a temporal bitmap. This allows to use the same bitmap
// as input or output
TmpBmp := TBitmap.Create;
try
// Assign the temporal bitmap the same characteristics as the original
TmpBmp.Width := OrigBmp.Width;
TmpBmp.Height := OrigBmp.Height;
TmpBmp.PixelFormat := OrigBmp.PixelFormat;
// For each row
for i := 0 to TmpBmp.Height - 1 do
begin
// For each column
for j := 0 to TmpBmp.Width - 1 do
begin
// r := 255 - GetRValue(OrigBmp.Canvas.Pixels[j, i]);
// g := 255 - GetGValue(OrigBmp.Canvas.Pixels[j, i]);
// b := 255 - GetBValue(OrigBmp.Canvas.Pixels[j, i]);
R := not GetRValue(OrigBmp.Canvas.Pixels[j, i]);
G := not GetGValue(OrigBmp.Canvas.Pixels[j, i]);
B := not GetBValue(OrigBmp.Canvas.Pixels[j, i]);
TmpBmp.Canvas.Pixels[j, i] := RGB(R, G, B);
end; // Column
end; // Row
// Assign the negative bitmap to the destination bitmap
DestBmp.Assign(TmpBmp);
finally
// Destroy temp bitmap
TmpBmp.Free;
end;
end;
procedure FastNegativeBitmap(OrigBmp, DestBmp: TBitmap);
var
i, j: Integer;
TmpBmp: TBitmap;
OrigRow, DestRow: PRGBArray;
begin
// Create a temporal bitmap. This allows to use the same bitmap
// as input or output
TmpBmp := TBitmap.Create;
try
// Assign the temporal bitmap the same characteristics as the original
TmpBmp.Width := OrigBmp.Width;
TmpBmp.Height := OrigBmp.Height;
OrigBmp.PixelFormat := pf24bit;
TmpBmp.PixelFormat := OrigBmp.PixelFormat;
// For each row
for i := 0 to TmpBmp.Height - 1 do
begin
// Sssign current ScanLines
OrigRow := OrigBmp.ScanLine[i];
DestRow := TmpBmp.ScanLine[i];
// For each column
for j := 0 to TmpBmp.Width - 1 do
begin
// Invert red, green, blue values
// DestRow[j].rgbtRed := 255 - OrigRow[j].rgbtRed;
// DestRow[j].rgbtGreen := 255 - OrigRow[j].rgbtGreen;
// DestRow[j].rgbtBlue := 255 - OrigRow[j].rgbtBlue;
DestRow[j].rgbtRed := not OrigRow[j].rgbtRed;
DestRow[j].rgbtGreen := not OrigRow[j].rgbtGreen;
DestRow[j].rgbtBlue := not OrigRow[j].rgbtBlue;
end;
end;
// Assign the negative bitmap to the destination bitmap
DestBmp.Assign(TmpBmp);
finally
// Destroy temp bitmap
TmpBmp.Free;
end;
end;
procedure InvertBitmap(OrigBmp, DestBmp: TBitmap);
begin
// use of the GDI InvertRect() A>PI is even faster...
InvertRect(OrigBmp.Canvas.Handle, OrigBmp.Canvas.ClipRect);
DestBmp.Assign(OrigBmp);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
try
OrigImg.Picture.LoadFromFile('Delphi.bmp'); //burada derlerken hataverebilir hatta verir bunu bir butona atasanız iyi olur
except
end;
end;
procedure TForm1.OpenBtnClick(Sender: TObject);
begin
if OpenDialog1.Execute then
begin
OrigImg.Picture.LoadFromFile(OpenDialog1.FileName);
OrigImg.Refresh;
end;
end;
end.
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls;
type
TForm1 = class(TForm)
OrigImg: TImage;
Button1: TButton;
RadioGroup1: TRadioGroup;
Label5: TLabel;
Label6: TLabel;
OpenBtn: TButton;
OpenDialog1: TOpenDialog;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure OpenBtnClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
procedure NegativeBitmap(OrigBmp, DestBmp: TBitmap);
procedure FastNegativeBitmap(OrigBmp, DestBmp: TBitmap);
procedure InvertBitmap(OrigBmp, DestBmp: TBitmap);
const
MaxPixelCount = 32768;
type
PRGBArray = ^TRGBArray;
TRGBArray = array[0..MaxPixelCount - 1] of TRGBTriple;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var
IniTime, ElapsedTime: DWord;
begin
Label6.Caption := '';
IniTime := GetTickCount;
case RadioGroup1.ItemIndex of
0: NegativeBitmap(OrigImg.Picture.Bitmap, OrigImg.Picture.Bitmap);
1: FastNegativeBitmap(OrigImg.Picture.Bitmap, OrigImg.Picture.Bitmap);
2: InvertBitmap(OrigImg.Picture.Bitmap, OrigImg.Picture.Bitmap);
end;
ElapsedTime := GetTickCount - IniTime;
Label6.Caption := Format('%d ms', [ElapsedTime]);
end;
procedure NegativeBitmap(OrigBmp, DestBmp: TBitmap);
var
i, j, R, G, B: Integer;
TmpBmp: TBitmap;
begin
// Create a temporal bitmap. This allows to use the same bitmap
// as input or output
TmpBmp := TBitmap.Create;
try
// Assign the temporal bitmap the same characteristics as the original
TmpBmp.Width := OrigBmp.Width;
TmpBmp.Height := OrigBmp.Height;
TmpBmp.PixelFormat := OrigBmp.PixelFormat;
// For each row
for i := 0 to TmpBmp.Height - 1 do
begin
// For each column
for j := 0 to TmpBmp.Width - 1 do
begin
// r := 255 - GetRValue(OrigBmp.Canvas.Pixels[j, i]);
// g := 255 - GetGValue(OrigBmp.Canvas.Pixels[j, i]);
// b := 255 - GetBValue(OrigBmp.Canvas.Pixels[j, i]);
R := not GetRValue(OrigBmp.Canvas.Pixels[j, i]);
G := not GetGValue(OrigBmp.Canvas.Pixels[j, i]);
B := not GetBValue(OrigBmp.Canvas.Pixels[j, i]);
TmpBmp.Canvas.Pixels[j, i] := RGB(R, G, B);
end; // Column
end; // Row
// Assign the negative bitmap to the destination bitmap
DestBmp.Assign(TmpBmp);
finally
// Destroy temp bitmap
TmpBmp.Free;
end;
end;
procedure FastNegativeBitmap(OrigBmp, DestBmp: TBitmap);
var
i, j: Integer;
TmpBmp: TBitmap;
OrigRow, DestRow: PRGBArray;
begin
// Create a temporal bitmap. This allows to use the same bitmap
// as input or output
TmpBmp := TBitmap.Create;
try
// Assign the temporal bitmap the same characteristics as the original
TmpBmp.Width := OrigBmp.Width;
TmpBmp.Height := OrigBmp.Height;
OrigBmp.PixelFormat := pf24bit;
TmpBmp.PixelFormat := OrigBmp.PixelFormat;
// For each row
for i := 0 to TmpBmp.Height - 1 do
begin
// Sssign current ScanLines
OrigRow := OrigBmp.ScanLine[i];
DestRow := TmpBmp.ScanLine[i];
// For each column
for j := 0 to TmpBmp.Width - 1 do
begin
// Invert red, green, blue values
// DestRow[j].rgbtRed := 255 - OrigRow[j].rgbtRed;
// DestRow[j].rgbtGreen := 255 - OrigRow[j].rgbtGreen;
// DestRow[j].rgbtBlue := 255 - OrigRow[j].rgbtBlue;
DestRow[j].rgbtRed := not OrigRow[j].rgbtRed;
DestRow[j].rgbtGreen := not OrigRow[j].rgbtGreen;
DestRow[j].rgbtBlue := not OrigRow[j].rgbtBlue;
end;
end;
// Assign the negative bitmap to the destination bitmap
DestBmp.Assign(TmpBmp);
finally
// Destroy temp bitmap
TmpBmp.Free;
end;
end;
procedure InvertBitmap(OrigBmp, DestBmp: TBitmap);
begin
// use of the GDI InvertRect() A>PI is even faster...
InvertRect(OrigBmp.Canvas.Handle, OrigBmp.Canvas.ClipRect);
DestBmp.Assign(OrigBmp);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
try
OrigImg.Picture.LoadFromFile('Delphi.bmp'); //burada derlerken hataverebilir hatta verir bunu bir butona atasanız iyi olur
except
end;
end;
procedure TForm1.OpenBtnClick(Sender: TObject);
begin
if OpenDialog1.Execute then
begin
OrigImg.Picture.LoadFromFile(OpenDialog1.FileName);
OrigImg.Refresh;
end;
end;
end.
Jpeg Brightness
unit Unit3;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, ComCtrls, StdCtrls,jpeg;
type
TForm3 = class(TForm)
ScrollBox1: TScrollBox;
ScrollBox2: TScrollBox;
TrackBar1: TTrackBar;
OrigImage: TImage;
DestImage: TImage;
ValueLbl: TLabel;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
procedure FormCreate(Sender: TObject);
procedure TrackBar1Change(Sender: TObject);
procedure DestImageDblClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form3: TForm3;
const
MaxPixelCount = 32768;
type
pRGBArray = ^TRGBArray;
TRGBArray = ARRAY[0..MaxPixelCount-1] OF TRGBTriple;
function Min(a, b: integer): integer;
function Max(a, b: integer): integer;
implementation
uses Viewer;
{$R *.DFM}
procedure TForm3.FormCreate(Sender: TObject);
var
jpg: TJpegImage;
begin
jpg := TJpegImage.Create;
OrigImage.Picture.Bitmap.PixelFormat := pf24bit;
DestImage.Picture.Bitmap.PixelFormat := pf24bit;
TrackBar1.Position := 0;
ValueLbl.Caption := '0';
end;
procedure TForm3.TrackBar1Change(Sender: TObject);
var i, j, value: integer;
OrigRow, DestRow: pRGBArray;
OrigImage,DestImage:TJPEGImage;//test
begin
// get brightness increment value
value := TTrackBar(Sender).Position;
if value <= 0 then ValueLbl.Caption := IntToStr(value)
else ValueLbl.Caption := Format('+%d', [value]);
// for each row of pixels
for i := 0 to OrigImage.Picture.Height - 1 do
begin
OrigRow := OrigImage.Picture.Bitmap.ScanLine[i];
DestRow := DestImage.Picture.Bitmap.ScanLine[i];
// for each pixel in row
for j := 0 to OrigImage.Picture.Width - 1 do
begin
// add brightness value to pixel's RGB values
if value > 0 then
begin
// RGB values must be less than 256
DestRow[j].rgbtRed := Min(255, OrigRow[j].rgbtRed + value);
DestRow[j].rgbtGreen := Min(255, OrigRow[j].rgbtGreen + value);
DestRow[j].rgbtBlue := Min(255, OrigRow[j].rgbtBlue + value);
end else begin
// RGB values must be greater or equal than 0
DestRow[j].rgbtRed := Max(0, OrigRow[j].rgbtRed + value);
DestRow[j].rgbtGreen := Max(0, OrigRow[j].rgbtGreen + value);
DestRow[j].rgbtBlue := Max(0, OrigRow[j].rgbtBlue + value);
end;
end;
application.ProcessMessages;
DestImage.rePaint;
end;
end;
function Min(a, b: integer): integer;
begin
if a < b then result := a
else result := b;
end;
function Max(a, b: integer): integer;
begin
if a > b then result := a
else result := b;
end;end.
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, ComCtrls, StdCtrls,jpeg;
type
TForm3 = class(TForm)
ScrollBox1: TScrollBox;
ScrollBox2: TScrollBox;
TrackBar1: TTrackBar;
OrigImage: TImage;
DestImage: TImage;
ValueLbl: TLabel;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
procedure FormCreate(Sender: TObject);
procedure TrackBar1Change(Sender: TObject);
procedure DestImageDblClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form3: TForm3;
const
MaxPixelCount = 32768;
type
pRGBArray = ^TRGBArray;
TRGBArray = ARRAY[0..MaxPixelCount-1] OF TRGBTriple;
function Min(a, b: integer): integer;
function Max(a, b: integer): integer;
implementation
uses Viewer;
{$R *.DFM}
procedure TForm3.FormCreate(Sender: TObject);
var
jpg: TJpegImage;
begin
jpg := TJpegImage.Create;
OrigImage.Picture.Bitmap.PixelFormat := pf24bit;
DestImage.Picture.Bitmap.PixelFormat := pf24bit;
TrackBar1.Position := 0;
ValueLbl.Caption := '0';
end;
procedure TForm3.TrackBar1Change(Sender: TObject);
var i, j, value: integer;
OrigRow, DestRow: pRGBArray;
OrigImage,DestImage:TJPEGImage;//test
begin
// get brightness increment value
value := TTrackBar(Sender).Position;
if value <= 0 then ValueLbl.Caption := IntToStr(value)
else ValueLbl.Caption := Format('+%d', [value]);
// for each row of pixels
for i := 0 to OrigImage.Picture.Height - 1 do
begin
OrigRow := OrigImage.Picture.Bitmap.ScanLine[i];
DestRow := DestImage.Picture.Bitmap.ScanLine[i];
// for each pixel in row
for j := 0 to OrigImage.Picture.Width - 1 do
begin
// add brightness value to pixel's RGB values
if value > 0 then
begin
// RGB values must be less than 256
DestRow[j].rgbtRed := Min(255, OrigRow[j].rgbtRed + value);
DestRow[j].rgbtGreen := Min(255, OrigRow[j].rgbtGreen + value);
DestRow[j].rgbtBlue := Min(255, OrigRow[j].rgbtBlue + value);
end else begin
// RGB values must be greater or equal than 0
DestRow[j].rgbtRed := Max(0, OrigRow[j].rgbtRed + value);
DestRow[j].rgbtGreen := Max(0, OrigRow[j].rgbtGreen + value);
DestRow[j].rgbtBlue := Max(0, OrigRow[j].rgbtBlue + value);
end;
end;
application.ProcessMessages;
DestImage.rePaint;
end;
end;
function Min(a, b: integer): integer;
begin
if a < b then result := a
else result := b;
end;
function Max(a, b: integer): integer;
begin
if a > b then result := a
else result := b;
end;end.
Jpeg To Grb Convert
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
OpenDialog1: TOpenDialog;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var Form1: TForm1;
implementation
uses jpeg;
{$R *.dfm}
function ConvertBitmapToGrayscale(const Bitmap: TBitmap): TBitmap;
var i, j: Integer; Grayshade, Red, Green, Blue: Byte; PixelColor: Longint;
begin
with Bitmap do
for i := 0 to Width - 1 do
for j := 0 to Height - 1 do
begin
PixelColor := ColorToRGB(Canvas.Pixels[i, j]);
Red := PixelColor;
Green := PixelColor shr 8;
Blue := PixelColor shr 16;
Grayshade := Round(0.3 * Red + 0.6 * Green + 0.1 * Blue);
Canvas.Pixels[i, j] := RGB(Grayshade, Grayshade, Grayshade);
end;
Result := Bitmap;
end;
procedure ConvertToBitmap(Source : TGraphic; Bitmap : TBitmap);
begin
try
if Bitmap = nil then
Bitmap := TBitmap.Create
Else Bitmap.FreeImage;
Bitmap.Width := Source.Width;
Bitmap.Height := Source.Height;
Bitmap.Canvas.Draw(0,0,Source);
except
showmessage('No Loaded File');
end;end;
procedure TForm1.Button1Click(Sender: TObject);
var
MyJpeg,OperatedJpeg:TJPEGImage;
MyBitmap,OperatedBitmap:TBitmap;
Begin
if OpenDialog1.Execute then
begin
MyJpeg := TJPEGImage.Create;
MyBitmap := TBitmap.Create;
OperatedBitmap := TBitmap.Create;
OperatedJpeg := TJPEGImage.Create;
try
MyJpeg.LoadFromFile(OpenDialog1.FileName);
ConvertToBitmap(MyJpeg,MyBitmap);
// Do any Bitmap Operation Here
//For Example i Convert Bitmap To GrayScale and perform result into
//operateBitmap
OperatedBitmap := ConvertBitmapToGrayscale(MyBitmap);
//Perform operated bitmap into jpeg
OperatedJpeg.Assign(OperatedBitmap);
OperatedJpeg.SaveToFile(OpenDialog1.FileName+'-Gray.jpeg');
Showmessage('Operation Completed')
finally
MyJpeg.Free;
OperatedJpeg.Free;
end;end;end; end.
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
OpenDialog1: TOpenDialog;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var Form1: TForm1;
implementation
uses jpeg;
{$R *.dfm}
function ConvertBitmapToGrayscale(const Bitmap: TBitmap): TBitmap;
var i, j: Integer; Grayshade, Red, Green, Blue: Byte; PixelColor: Longint;
begin
with Bitmap do
for i := 0 to Width - 1 do
for j := 0 to Height - 1 do
begin
PixelColor := ColorToRGB(Canvas.Pixels[i, j]);
Red := PixelColor;
Green := PixelColor shr 8;
Blue := PixelColor shr 16;
Grayshade := Round(0.3 * Red + 0.6 * Green + 0.1 * Blue);
Canvas.Pixels[i, j] := RGB(Grayshade, Grayshade, Grayshade);
end;
Result := Bitmap;
end;
procedure ConvertToBitmap(Source : TGraphic; Bitmap : TBitmap);
begin
try
if Bitmap = nil then
Bitmap := TBitmap.Create
Else Bitmap.FreeImage;
Bitmap.Width := Source.Width;
Bitmap.Height := Source.Height;
Bitmap.Canvas.Draw(0,0,Source);
except
showmessage('No Loaded File');
end;end;
procedure TForm1.Button1Click(Sender: TObject);
var
MyJpeg,OperatedJpeg:TJPEGImage;
MyBitmap,OperatedBitmap:TBitmap;
Begin
if OpenDialog1.Execute then
begin
MyJpeg := TJPEGImage.Create;
MyBitmap := TBitmap.Create;
OperatedBitmap := TBitmap.Create;
OperatedJpeg := TJPEGImage.Create;
try
MyJpeg.LoadFromFile(OpenDialog1.FileName);
ConvertToBitmap(MyJpeg,MyBitmap);
// Do any Bitmap Operation Here
//For Example i Convert Bitmap To GrayScale and perform result into
//operateBitmap
OperatedBitmap := ConvertBitmapToGrayscale(MyBitmap);
//Perform operated bitmap into jpeg
OperatedJpeg.Assign(OperatedBitmap);
OperatedJpeg.SaveToFile(OpenDialog1.FileName+'-Gray.jpeg');
Showmessage('Operation Completed')
finally
MyJpeg.Free;
OperatedJpeg.Free;
end;end;end; end.
Ico to Bmp Convert
procedure TForm1.ConvertIcon2BitmapClick(Sender: TObject);
var
s : string;
Icon: TIcon;
begin
OpenDialog1.DefaultExt := '.ICO';
OpenDialog1.Filter := 'icons (*.ico)|*.ICO';
OpenDialog1.Options := [ofOverwritePrompt, ofFileMustExist, ofHideReadOnly ];
if OpenDialog1.Execute then
begin
Icon := TIcon.Create;
try
Icon.Loadfromfile(OpenDialog1.FileName);
s:= ChangeFileExt(OpenDialog1.FileName,'.BMP');
Image1.Width := Icon.Width;
Image1.Height := Icon.Height;
Image1.Canvas.Draw(0,0,Icon);
Image1.Picture.SaveToFile(s);
ShowMessage(OpenDialog1.FileName + ' Saved to ' + s);
finally
Icon.Free;
end;
end;
end;
var
s : string;
Icon: TIcon;
begin
OpenDialog1.DefaultExt := '.ICO';
OpenDialog1.Filter := 'icons (*.ico)|*.ICO';
OpenDialog1.Options := [ofOverwritePrompt, ofFileMustExist, ofHideReadOnly ];
if OpenDialog1.Execute then
begin
Icon := TIcon.Create;
try
Icon.Loadfromfile(OpenDialog1.FileName);
s:= ChangeFileExt(OpenDialog1.FileName,'.BMP');
Image1.Width := Icon.Width;
Image1.Height := Icon.Height;
Image1.Canvas.Draw(0,0,Icon);
Image1.Picture.SaveToFile(s);
ShowMessage(OpenDialog1.FileName + ' Saved to ' + s);
finally
Icon.Free;
end;
end;
end;
Ico to Bmp Convert
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;
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;
Bmp to Jpg Convert
//uses kısmına jpeg unitini ekleyin.
procedure TForm1.Button1Click(Sender: TObject);
var
MyJPEG : TJPEGImage;
MyBMP : TBitmap;
begin
MyBMP := TBitmap.Create;
with MyBMP do
try
LoadFromFile('c:\winnt\ACD Wallpaper.bmp');
MyJPEG := TJPEGImage.Create;
with MyJPEG do begin
Assign(MyBMP);
SaveToFile('c:\winnt\ACD Wallpaper.JPEG');
Free;
end;
finally
Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
MyJPEG : TJPEGImage;
MyBMP : TBitmap;
begin
MyBMP := TBitmap.Create;
with MyBMP do
try
LoadFromFile('c:\winnt\ACD Wallpaper.bmp');
MyJPEG := TJPEGImage.Create;
with MyJPEG do begin
Assign(MyBMP);
SaveToFile('c:\winnt\ACD Wallpaper.JPEG');
Free;
end;
finally
Free;
end;
end;
Bmp to Emf Convert
****** BMP TO EMF CONVERT
Bitmap'i (.bmp) Windows ****file'a (.Emf') çevirme :
procedure ConvertBMP2EMF (AImage: TImage; FileName: String);
var
Emf : T****file;
EmfCanvas: T****fileCanvas;
begin
Emf := T****file.Create;
try
//Must set width + Height before creating the canvas
Emf.Width := AImage.Picture.Bitmap.Width;
Emf.Height := AImage.Picture.Bitmap.Height;
EmfCanvas := T****fileCanvas.Create(Wmf, 0);
try
EmfCanvas.Draw(0,0,AImage.Picture.Bitmap);
finally
EmfCanvas.Free;
end;
Emf.SaveToFile(FileName);
finally
Emf.Free;
end;
end;
Bitmap'i (.bmp) Windows ****file'a (.Emf') çevirme :
procedure ConvertBMP2EMF (AImage: TImage; FileName: String);
var
Emf : T****file;
EmfCanvas: T****fileCanvas;
begin
Emf := T****file.Create;
try
//Must set width + Height before creating the canvas
Emf.Width := AImage.Picture.Bitmap.Width;
Emf.Height := AImage.Picture.Bitmap.Height;
EmfCanvas := T****fileCanvas.Create(Wmf, 0);
try
EmfCanvas.Draw(0,0,AImage.Picture.Bitmap);
finally
EmfCanvas.Free;
end;
Emf.SaveToFile(FileName);
finally
Emf.Free;
end;
end;
Bmp to Wmf Convert
*** BMP TO WMF CONVERT
Bitmap'i (.bmp) Windows ****file'a (.wmf') çevirme :
procedure ConvertBMP2WMF (AImage: TImage; FileName: String);
var
Wmf : T****file;
WmfCanvas: T****fileCanvas;
begin
Wmf := T****file.Create;
try
//Must set width + Height before creating the canvas
Wmf.Width := AImage.Picture.Bitmap.Width;
Wmf.Height := AImage.Picture.Bitmap.Height;
WmfCanvas := T****fileCanvas.Create(Wmf, 0);
try
WmfCanvas.Draw(0,0,AImage.Picture.Bitmap);
finally
WmfCanvas.Free;
end;
Wmf.SaveToFile(FileName);
finally
Wmf.Free;
end;
end;
Bitmap'i (.bmp) Windows ****file'a (.wmf') çevirme :
procedure ConvertBMP2WMF (AImage: TImage; FileName: String);
var
Wmf : T****file;
WmfCanvas: T****fileCanvas;
begin
Wmf := T****file.Create;
try
//Must set width + Height before creating the canvas
Wmf.Width := AImage.Picture.Bitmap.Width;
Wmf.Height := AImage.Picture.Bitmap.Height;
WmfCanvas := T****fileCanvas.Create(Wmf, 0);
try
WmfCanvas.Draw(0,0,AImage.Picture.Bitmap);
finally
WmfCanvas.Free;
end;
Wmf.SaveToFile(FileName);
finally
Wmf.Free;
end;
end;
Bmp To Rtf Convert
*** BMP TO RTF FUNCTION
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;
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;
Bmp to Ico Convert
*** BMP TO ICO
procedure bmp2ico(Image: TImage; FileName: TFilename);
var
Bmp: TBitmap;
Icon: TIcon;
ImageList: TImageList;
begin
Bmp := TBitmap.Create;
Icon := TIcon.Create;
try
Bmp.Assign(Image.Picture);
ImageList := TImageList.CreateSize(Bmp.Width, Bmp.Height);
try
ImageList.AddMasked(Bmp, Bmp.TransparentColor);
ImageList.GetIcon(0, Icon);
// Save it to a file
Icon.SaveToFile(FileName);
finally
ImageList.Free;
end;
finally
Bmp.Free;
Icon.Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
bmp2ico(Image1, 'c:\test.ico');
end;
procedure bmp2ico(Image: TImage; FileName: TFilename);
var
Bmp: TBitmap;
Icon: TIcon;
ImageList: TImageList;
begin
Bmp := TBitmap.Create;
Icon := TIcon.Create;
try
Bmp.Assign(Image.Picture);
ImageList := TImageList.CreateSize(Bmp.Width, Bmp.Height);
try
ImageList.AddMasked(Bmp, Bmp.TransparentColor);
ImageList.GetIcon(0, Icon);
// Save it to a file
Icon.SaveToFile(FileName);
finally
ImageList.Free;
end;
finally
Bmp.Free;
Icon.Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
bmp2ico(Image1, 'c:\test.ico');
end;
Bmp to Jpg Convert
*** BMP DOSYASINI JPEG'E DÖNÜŞTÜRME
//uses kısmına jpeg unitini ekleyin.
procedure TForm1.Button1Click(Sender: TObject);
var
MyJPEG : TJPEGImage;
MyBMP : TBitmap;
begin
MyBMP := TBitmap.Create;
with MyBMP do
try
LoadFromFile('c:\winnt\ACD Wallpaper.bmp');
MyJPEG := TJPEGImage.Create;
with MyJPEG do begin
Assign(MyBMP);
SaveToFile('c:\winnt\ACD Wallpaper.JPEG');
Free;
end;
finally
Free;
end;
end;
//uses kısmına jpeg unitini ekleyin.
procedure TForm1.Button1Click(Sender: TObject);
var
MyJPEG : TJPEGImage;
MyBMP : TBitmap;
begin
MyBMP := TBitmap.Create;
with MyBMP do
try
LoadFromFile('c:\winnt\ACD Wallpaper.bmp');
MyJPEG := TJPEGImage.Create;
with MyJPEG do begin
Assign(MyBMP);
SaveToFile('c:\winnt\ACD Wallpaper.JPEG');
Free;
end;
finally
Free;
end;
end;
Verileri güncellemek
Tablomuzda bulunan verilerimizi güncellemek için UPDATE' i kullanacağız.Bunun için Formumuza Button1 koyalım .Caption özelliğine Güncelle yazalım.Güncelle butonuna aşağıdaki kodları yazalım.
procedure TForm1.GuncelleClick ( Sender : TObject ) ;
begin
Query1.SQL.Clear ;
Query1.SQL.Add ( ' UPDATE liste set maas = 10000 where ADI = ' Bahadir ' ) ;
Query1.ExecSQL ;
end ;
procedure TForm1.GuncelleClick ( Sender : TObject ) ;
begin
Query1.SQL.Clear ;
Query1.SQL.Add ( ' UPDATE liste set maas = 10000 where ADI = ' Bahadir ' ) ;
Query1.ExecSQL ;
end ;
Dbgridde kayıt ekleme sorgusu
Formumuza Button1 koyalım .Caption özelliğine Ekle yazalım.Ekle butonuna aşağıdaki kodları yazalım.( formumuza Query1, DataSource1 ve DBGrid1 yerleştirilmiş varsayıyorum.)
procedure TForm1.EkleClick ( Sender : TObject ) ;
begin
Query1.SQL.Add ('INSERT into liste ' );
Query1.SQL.Add ( ' (ADI , SOYADI ) ' ) ;
Query1.SQL.Add ( 'values (" Bahadir " , " Sahin " ) ' ) ;
Query1.ExecSQL ;
end;
Not : Programı çalıştırıp Ekle butonuna bastığımız zaman kodda yazmış olduğumuz Bahadir Sahin' i veri tabanına ekler.
procedure TForm1.EkleClick ( Sender : TObject ) ;
begin
Query1.SQL.Add ('INSERT into liste ' );
Query1.SQL.Add ( ' (ADI , SOYADI ) ' ) ;
Query1.SQL.Add ( 'values (" Bahadir " , " Sahin " ) ' ) ;
Query1.ExecSQL ;
end;
Not : Programı çalıştırıp Ekle butonuna bastığımız zaman kodda yazmış olduğumuz Bahadir Sahin' i veri tabanına ekler.
Dbgridde sütun sorgulama
Bunu yaparken DataSource1 'in DataSet özelliğini Query1 ; Query1'in DataBaseName özelliğini veri tabanınız ( bizim örnekte liste.dbf ) ; DBGrid1 ' in DataSource özelliğinide DataSource1 yapınız.
Örnek :
procedure TForm1.Button1Click ( Sender : TObject ) ;
begin
Query1.SQL.Clear ;
Query1.SQL.Add(' Select adi , soyadi , adresi , maas From liste ' ) ;
Query1.Open ;
end ;
Programımızı çalıştırıp Button1'e tıkladığımız zaman DBGrid'de istediğimiz bilgilerin listelendiğini görürüz.
Örnek :
procedure TForm1.Button1Click ( Sender : TObject ) ;
begin
Query1.SQL.Clear ;
Query1.SQL.Add(' Select adi , soyadi , adresi , maas From liste ' ) ;
Query1.Open ;
end ;
Programımızı çalıştırıp Button1'e tıkladığımız zaman DBGrid'de istediğimiz bilgilerin listelendiğini görürüz.
Verileri sıralamak
Tabloda bulunan verileri A-Z'ye veya Z-A'ya sıralayabiliriz.Bunun için aşağıdaki örnekleri inceleyelim.
Örnek1 :
SELECT DISTINCT adi ,soyadi , adresi , maas FROM liste WHERE Order By adi ASC ( A-Z'ya sıralar )
Örnek2 :
SELECT DISTINCT adi ,soyadi , adresi , maas FROM liste WHERE Order By adi DESC ( Z-A'ya sıralar )
Örnek1 :
SELECT DISTINCT adi ,soyadi , adresi , maas FROM liste WHERE Order By adi ASC ( A-Z'ya sıralar )
Örnek2 :
SELECT DISTINCT adi ,soyadi , adresi , maas FROM liste WHERE Order By adi DESC ( Z-A'ya sıralar )
Istenilen sütünları listeleme
Istenilen sütunlar listelenmek istenirse Query1'in SQL özelliğine şu SQL komutu yazılmalıdır.
SELECT adi , soyadi , adresi FROM liste
Not :liste.dbf adlı veri tabanımızdan sadece adi , soyadi , adresi adlı sütunlar ve bu sütunlardaki bilgileri listelemiş olduk.
SELECT adi , soyadi , adresi FROM liste
Not :liste.dbf adlı veri tabanımızdan sadece adi , soyadi , adresi adlı sütunlar ve bu sütunlardaki bilgileri listelemiş olduk.
Dbgrid'de seçilen satırın görüntüsü
//Not: Delphi 7.0 için;
//Eğer Quick Reports paketini kurmadıysanız Delphi 7.0\Bin dizini altındaki
//dclqrt70.bpl dosyasını eklemeniz gerekir.
//[Menüde Component\Install Packages...\Add sırasını izleyip]
//Delphi 5.0 - 6.0 için bu işlemi yapmanıza gerek yok.
//Form1 üzerine 1 DBGrid, 1 Table1, 1 DataSource,
//1 PrinterSetupDialog, 1 PrintDialog1 ve 1 Button ekleyin.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, DB, DBTables, Grids, DBGrids, StdCtrls, ComCtrls, ExtCtrls, Mask,
QuickRpt, Qrctrls, Printers, QRPrntr, QrExtra;
type
TForm1 = class(TForm)
DBGrid1: TDBGrid;
Table1: TTable;
DataSource1: TDataSource;
PrinterSetupDialog1: TPrinterSetupDialog;
PrintDialog1: TPrintDialog;
Button3: TButton;
procedure DBGrid1DblClick(Sender: TObject);
procedure Button3Click(Sender: TObject);
private
aReport: TQuickRep;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses Unit2;
{$R *.dfm}
procedure TForm1.DBGrid1DblClick(Sender: TObject);
begin
if DBGrid1.SelectedRows.Count > 0 then begin
with DBGrid1.DataSource.DataSet do begin
try
Application.CreateForm(TForm2, Form2);
if not DBGrid1.Fields[0].IsNull then Form2.QRLabel7.Caption:= DBGrid1.Fields[0].Value;
//"if not DBGrid1.Fields[0..n].IsNull then" şeklinde bir kod, programınızın
//kırılmasını engelleyecektir. Bu, tüm "Field" aktarımları için geçerli ve sorun
//çıkarmayan, çıkmasını kontrol altında tutan bir yöntem olduğu düşüncesindeyim.
if not DBGrid1.Fields[1].IsNull then Form2.QRLabel8.Caption:= DBGrid1.Fields[1].Value;
if not DBGrid1.Fields[2].IsNull then Form2.QRLabel9.Caption:= DBGrid1.Fields[2].Value;
if not DBGrid1.Fields[3].IsNull then Form2.QRLabel10.Caption:= DBGrid1.Fields[3].Value;
if not DBGrid1.Fields[4].IsNull then Form2.QRLabel11.Caption:= DBGrid1.Fields[4].Value;
if not DBGrid1.Fields[5].IsNull then Form2.QRLabel12.Caption:= DBGrid1.Fields[5].Value;
if not DBGrid1.Fields[6].IsNull then Form2.QRLabel13.Caption:= DBGrid1.Fields[6].Value;
if not DBGrid1.Fields[7].IsNull then Form2.QRLabel14.Caption:= DBGrid1.Fields[7].Value;
if not DBGrid1.Fields[8].IsNull then Form2.QRLabel15.Caption:= DBGrid1.Fields[8].Value;
Form2.QR.ShowProgress:= False;
aReport:= Form2.QR;
Printer.PrinterIndex:= -1;
aReport.Preview;
finally
Form2.Free;
end;end;end;end;
procedure TForm1.Button3Click(Sender: TObject);
begin
Close;
end;end.
Not: DBGrid1.Options dgRowSelect True olmalı.
QR -> Form2 üzerindeki QuickRep1 bileşeni
////////////////////////////////////////////////////////////////////////////////
//Form2 üzerine 1 QuickRep (Bu kodlamaya göre Name = QR),
//QuickRep üzerine 2 adet QRBand,
//QRBand'lar üzerine listelenmesini istediğiniz Field'lerinizin 2 katı QRLabel ve
//başlıklarla dataların birbirine karışmaması için Shape ekleyiniz.
//Örnek;
// STOK LİSTESİ (QRLabel1)
//
// Stok No(QRLabel2) Stok Adı(QRL3) Birim(QRL4) Brm.Miktar(QRL5) .........
//-------------------------------------------------------------------------------- Shape1
// StokNo(QRL6 StokAdi(QRL7 Birim(QRL8 BrmMiktar(QRL9 .........
// -SağaDayalı) -SolaDayalı) -Ortalı) -SağaDyalı)
unit Unit2;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, QuickRpt, QRPrntr, QRCtrls, Printers, DB, DBTables, QrExtra;
type
TForm2 = class(TForm)
QR: TQuickRep;
QRBand1: TQRBand;
QRLabel1: TQRLabel;
QRBand2: TQRBand;
QRLabel2: TQRLabel;
QRLabel3: TQRLabel;
QRLabel4: TQRLabel;
QRLabel5: TQRLabel;
QRLabel6: TQRLabel;
QRShape1: TQRShape;
QRLabel7: TQRLabel;
QRLabel8: TQRLabel;
QRLabel9: TQRLabel;
QRLabel10: TQRLabel;
QRLabel11: TQRLabel;
QRLabel12: TQRLabel;
QRLabel13: TQRLabel;
QRLabel14: TQRLabel;
QRLabel15: TQRLabel;
QRLabel16: TQRLabel;
QRLabel17: TQRLabel;
QRLabel18: TQRLabel;
QRLabel19: TQRLabel;
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form2: TForm2;
implementation
uses Unit1;
{$R *.dfm}
end.
Not: QRLabel7'den QRLabel15'e kadar olan bileşenler QRBand2 üzerinde.
QRBand2.BandType "rbSummary" olmalı.
QRBand1.BandType "rbTitle" olmalı.
Form2 üzerindeki QR -> QuickRep1 bileşeni
//Eğer Quick Reports paketini kurmadıysanız Delphi 7.0\Bin dizini altındaki
//dclqrt70.bpl dosyasını eklemeniz gerekir.
//[Menüde Component\Install Packages...\Add sırasını izleyip]
//Delphi 5.0 - 6.0 için bu işlemi yapmanıza gerek yok.
//Form1 üzerine 1 DBGrid, 1 Table1, 1 DataSource,
//1 PrinterSetupDialog, 1 PrintDialog1 ve 1 Button ekleyin.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, DB, DBTables, Grids, DBGrids, StdCtrls, ComCtrls, ExtCtrls, Mask,
QuickRpt, Qrctrls, Printers, QRPrntr, QrExtra;
type
TForm1 = class(TForm)
DBGrid1: TDBGrid;
Table1: TTable;
DataSource1: TDataSource;
PrinterSetupDialog1: TPrinterSetupDialog;
PrintDialog1: TPrintDialog;
Button3: TButton;
procedure DBGrid1DblClick(Sender: TObject);
procedure Button3Click(Sender: TObject);
private
aReport: TQuickRep;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses Unit2;
{$R *.dfm}
procedure TForm1.DBGrid1DblClick(Sender: TObject);
begin
if DBGrid1.SelectedRows.Count > 0 then begin
with DBGrid1.DataSource.DataSet do begin
try
Application.CreateForm(TForm2, Form2);
if not DBGrid1.Fields[0].IsNull then Form2.QRLabel7.Caption:= DBGrid1.Fields[0].Value;
//"if not DBGrid1.Fields[0..n].IsNull then" şeklinde bir kod, programınızın
//kırılmasını engelleyecektir. Bu, tüm "Field" aktarımları için geçerli ve sorun
//çıkarmayan, çıkmasını kontrol altında tutan bir yöntem olduğu düşüncesindeyim.
if not DBGrid1.Fields[1].IsNull then Form2.QRLabel8.Caption:= DBGrid1.Fields[1].Value;
if not DBGrid1.Fields[2].IsNull then Form2.QRLabel9.Caption:= DBGrid1.Fields[2].Value;
if not DBGrid1.Fields[3].IsNull then Form2.QRLabel10.Caption:= DBGrid1.Fields[3].Value;
if not DBGrid1.Fields[4].IsNull then Form2.QRLabel11.Caption:= DBGrid1.Fields[4].Value;
if not DBGrid1.Fields[5].IsNull then Form2.QRLabel12.Caption:= DBGrid1.Fields[5].Value;
if not DBGrid1.Fields[6].IsNull then Form2.QRLabel13.Caption:= DBGrid1.Fields[6].Value;
if not DBGrid1.Fields[7].IsNull then Form2.QRLabel14.Caption:= DBGrid1.Fields[7].Value;
if not DBGrid1.Fields[8].IsNull then Form2.QRLabel15.Caption:= DBGrid1.Fields[8].Value;
Form2.QR.ShowProgress:= False;
aReport:= Form2.QR;
Printer.PrinterIndex:= -1;
aReport.Preview;
finally
Form2.Free;
end;end;end;end;
procedure TForm1.Button3Click(Sender: TObject);
begin
Close;
end;end.
Not: DBGrid1.Options dgRowSelect True olmalı.
QR -> Form2 üzerindeki QuickRep1 bileşeni
////////////////////////////////////////////////////////////////////////////////
//Form2 üzerine 1 QuickRep (Bu kodlamaya göre Name = QR),
//QuickRep üzerine 2 adet QRBand,
//QRBand'lar üzerine listelenmesini istediğiniz Field'lerinizin 2 katı QRLabel ve
//başlıklarla dataların birbirine karışmaması için Shape ekleyiniz.
//Örnek;
// STOK LİSTESİ (QRLabel1)
//
// Stok No(QRLabel2) Stok Adı(QRL3) Birim(QRL4) Brm.Miktar(QRL5) .........
//-------------------------------------------------------------------------------- Shape1
// StokNo(QRL6 StokAdi(QRL7 Birim(QRL8 BrmMiktar(QRL9 .........
// -SağaDayalı) -SolaDayalı) -Ortalı) -SağaDyalı)
unit Unit2;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, QuickRpt, QRPrntr, QRCtrls, Printers, DB, DBTables, QrExtra;
type
TForm2 = class(TForm)
QR: TQuickRep;
QRBand1: TQRBand;
QRLabel1: TQRLabel;
QRBand2: TQRBand;
QRLabel2: TQRLabel;
QRLabel3: TQRLabel;
QRLabel4: TQRLabel;
QRLabel5: TQRLabel;
QRLabel6: TQRLabel;
QRShape1: TQRShape;
QRLabel7: TQRLabel;
QRLabel8: TQRLabel;
QRLabel9: TQRLabel;
QRLabel10: TQRLabel;
QRLabel11: TQRLabel;
QRLabel12: TQRLabel;
QRLabel13: TQRLabel;
QRLabel14: TQRLabel;
QRLabel15: TQRLabel;
QRLabel16: TQRLabel;
QRLabel17: TQRLabel;
QRLabel18: TQRLabel;
QRLabel19: TQRLabel;
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form2: TForm2;
implementation
uses Unit1;
{$R *.dfm}
end.
Not: QRLabel7'den QRLabel15'e kadar olan bileşenler QRBand2 üzerinde.
QRBand2.BandType "rbSummary" olmalı.
QRBand1.BandType "rbTitle" olmalı.
Form2 üzerindeki QR -> QuickRep1 bileşeni
Dbgrid içerisine resim eklemek
procedure TForm1.DBGrid1DrawColumnCell(S ender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn; State: TGridDrawState);
var Icon: TBitmap;
begin
Icon:=TBitmap.Create;
if (Column.FieldName='SHARES' ) then begin
with DBGrid1.Canvas do begin
Brush.Color:=clWhite;
FillRect(Rect);
if (Table1.FieldByName('SHARES'). Value>4500)
then
ImageList1.GetBitmap(1,Icon)
else
ImageList1.GetBitmap(0,Icon);
Draw(round((Rect.Left+Rect.Rig ht-Icon.Width)/2),Rect.Top,Icon);
end;end;
DataCol: Integer; Column: TColumn; State: TGridDrawState);
var Icon: TBitmap;
begin
Icon:=TBitmap.Create;
if (Column.FieldName='SHARES' ) then begin
with DBGrid1.Canvas do begin
Brush.Color:=clWhite;
FillRect(Rect);
if (Table1.FieldByName('SHARES'). Value>4500)
then
ImageList1.GetBitmap(1,Icon)
else
ImageList1.GetBitmap(0,Icon);
Draw(round((Rect.Left+Rect.Rig ht-Icon.Width)/2),Rect.Top,Icon);
end;end;
Adoquery ile çoklu filitreleme
edit3'e "AHMET;MEHMET" Girdiğimde "AHMET" ve "MEHMET" kayıtları listeleyebileyim
Yardımlarınız için şimdiden teşekkür ederim.
Memo1.Clear;
ADOQuery2.Close;
ADOQuery2.sql.Clear;
ADOQuery2.SQL.Add('SELECT * from Tablo WHERE (Tarih BETWEEN :Tar1 and :Tar2)');
ADOQuery2.Parameters.ParamByName('Tar1').Value := FormatDateTime('DD/MM/YYYY',DateTimePicker1.date);
ADOQuery2.Parameters.ParamByName('Tar2').Value := FormatDateTime('DD/MM/YYYY',DateTimePicker2.date);
if Edit3.Text<>'' then begin
ADOQuery2.SQL.Add(' and Adi in ('+QuotedStr(Edit3.Text)+')');
End;
Memo1.Lines.add(ADOQuery2.sql.text);
ADOQuery2.Open;
Yardımlarınız için şimdiden teşekkür ederim.
Memo1.Clear;
ADOQuery2.Close;
ADOQuery2.sql.Clear;
ADOQuery2.SQL.Add('SELECT * from Tablo WHERE (Tarih BETWEEN :Tar1 and :Tar2)');
ADOQuery2.Parameters.ParamByName('Tar1').Value := FormatDateTime('DD/MM/YYYY',DateTimePicker1.date);
ADOQuery2.Parameters.ParamByName('Tar2').Value := FormatDateTime('DD/MM/YYYY',DateTimePicker2.date);
if Edit3.Text<>'' then begin
ADOQuery2.SQL.Add(' and Adi in ('+QuotedStr(Edit3.Text)+')');
End;
Memo1.Lines.add(ADOQuery2.sql.text);
ADOQuery2.Open;
Adoquery veri tabanında sıralama yapma
with form5.Adoquery1 do begin
case Combobox3.itemIndex of
0:begin
form5.Adoquery1.close;
form5.Adoquery1.sql.clear;
form5.adoQuery1.sql.text:='Select * from Tablo1 where MBEGIM=MB000';
form5.adoQuery1.Parameters.ParamByName('MB000').value:=ComboBox2.Text;
form5.Adoquery1.open;
end;
case Combobox3.itemIndex of
0:begin
form5.Adoquery1.close;
form5.Adoquery1.sql.clear;
form5.adoQuery1.sql.text:='Select * from Tablo1 where MBEGIM=MB000';
form5.adoQuery1.Parameters.ParamByName('MB000').value:=ComboBox2.Text;
form5.Adoquery1.open;
end;
BDE Dsyaları
BDE' nin kullandığı dosyalar :
Dosya Adı Bilgi
-------------------------------
IDAPI01.DLL BDE API DLL
IDBAT01.DLL BDE Batch işlemleri için
IDQRY01.DLL BDE Query (sorgu/SQL) DLL
IDASCI01.DLL BDE ASCII Driver DLL
IDPDX01.DLL BDE Paradox Driver DLL
IDDBAS01.DLL BDE dBASE Driver DLL
IDR10009.DLL BDE Resources DLL
ILD01.DLL Dil ayarlaması için DLL
IDODBC01.DLL BDE ODBC Soket programları için DLL
ODBC.New Microsoft ODBC Driver Manager DLL V2.0
ODBCINST.NEW Microsoft ODBC Driver Installation DLL V2.0
TUTILITY.DLL BDE Table Repair (Onarım) Utility DLL
BDECFG.EXE BDE Konfigürasyon işlemleri için DLL
BDECFG.HLP BDE Konfigürasyon işlemleri için yardım
IDAPI.CFG BDE Konfigüresyon dosyası
Dosya Adı Bilgi
-------------------------------
IDAPI01.DLL BDE API DLL
IDBAT01.DLL BDE Batch işlemleri için
IDQRY01.DLL BDE Query (sorgu/SQL) DLL
IDASCI01.DLL BDE ASCII Driver DLL
IDPDX01.DLL BDE Paradox Driver DLL
IDDBAS01.DLL BDE dBASE Driver DLL
IDR10009.DLL BDE Resources DLL
ILD01.DLL Dil ayarlaması için DLL
IDODBC01.DLL BDE ODBC Soket programları için DLL
ODBC.New Microsoft ODBC Driver Manager DLL V2.0
ODBCINST.NEW Microsoft ODBC Driver Installation DLL V2.0
TUTILITY.DLL BDE Table Repair (Onarım) Utility DLL
BDECFG.EXE BDE Konfigürasyon işlemleri için DLL
BDECFG.HLP BDE Konfigürasyon işlemleri için yardım
IDAPI.CFG BDE Konfigüresyon dosyası
2 Nisan 2010 Cuma
Iki sesi aynı anda çalmak
uses
MMSystem;
procedure SendMCICommand(Cmd: string);
var
RetVal: Integer;
ErrMsg: array[0..254] of char;
begin
RetVal := mciSendString(PChar(Cmd), nil, 0, 0);
if RetVal <> 0 then
begin
{get message for returned value}
mciGetErrorString(RetVal, ErrMsg, 255);
MessageDlg(StrPas(ErrMsg), mtError, [mbOK], 0);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
SendMCICommand('open waveaudio shareable');
SendMCICommand('play "C:\xyz\BackgroundMusic.wav"');
SendMCICommand('play "C:\xyz\AnotherMusic.wav"');
SendMCICommand('close waveaudio');
end;
MMSystem;
procedure SendMCICommand(Cmd: string);
var
RetVal: Integer;
ErrMsg: array[0..254] of char;
begin
RetVal := mciSendString(PChar(Cmd), nil, 0, 0);
if RetVal <> 0 then
begin
{get message for returned value}
mciGetErrorString(RetVal, ErrMsg, 255);
MessageDlg(StrPas(ErrMsg), mtError, [mbOK], 0);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
SendMCICommand('open waveaudio shareable');
SendMCICommand('play "C:\xyz\BackgroundMusic.wav"');
SendMCICommand('play "C:\xyz\AnotherMusic.wav"');
SendMCICommand('close waveaudio');
end;
Windows işlev sesleri
uses mmsystem;
PlaySound(pChar('SYSTEMSTART'),0,SND_SYNC);
PlaySound(pChar('SYSTEMEXIT'),0,SND_SYNC);
PlaySound(pChar('SYSTEMHAND'),0,SND_SYNC);
PlaySound(pChar('SYSTEMASTERISK'),0,SND_SYNC);
PlaySound(pChar('SYSTEMQUESTION'),0,SND_SYNC);
PlaySound(pChar('SYSTEMEXCLAMATION'),0,SND_SYNC);
PlaySound(pChar('SYSTEMWELCOME'),0,SND_SYNC);
PlaySound(pChar('SYSTEMDEFAULT'),0,SND_SYNC);
PlaySound(pChar('SYSTEMSTART'),0,SND_SYNC);
PlaySound(pChar('SYSTEMEXIT'),0,SND_SYNC);
PlaySound(pChar('SYSTEMHAND'),0,SND_SYNC);
PlaySound(pChar('SYSTEMASTERISK'),0,SND_SYNC);
PlaySound(pChar('SYSTEMQUESTION'),0,SND_SYNC);
PlaySound(pChar('SYSTEMEXCLAMATION'),0,SND_SYNC);
PlaySound(pChar('SYSTEMWELCOME'),0,SND_SYNC);
PlaySound(pChar('SYSTEMDEFAULT'),0,SND_SYNC);
WindowsMediaPlayer controls
WINDOWSMEDIAPLAYER KONTROLU
procedure TForm1.MediaFile1Click(Sender: TObject);
var filename:string;
begin
if opendialog1.execute then
begin
WindowsMediaPlayer1.URL:=ExtractFilePath(Application.ExeName)+Opendialog1.filename;
WindowsMediaPlayer1.controls.play;
WindowsMediaPlayer1.url:=Opendialog1.FileName;
end;
end;
//URL adresinden açma:
windowsMediaPlayer1.URL := ('http://www.gotradio.com/player/launch.asp?refer=web&id=72&cr=48');
//şarkı adını + sanatçı adını alma:
WindowsMediaPlayer1.currentMedia.name;
//Şarkının uzunluğunu:
WindowsMediaPlayer1.currentMedia.durationString;
//Çalma listesini veya albüm adı:
WindowsMediaPlayer1.currentPlaylist.name;
//Durum bilgisi:
WindowsMediaPlayer1.status;
//Dosyanın yolu:
WindowsMediaPlayer1.DefaultInterface.URL;
gibi...
procedure TForm1.MediaFile1Click(Sender: TObject);
var filename:string;
begin
if opendialog1.execute then
begin
WindowsMediaPlayer1.URL:=ExtractFilePath(Application.ExeName)+Opendialog1.filename;
WindowsMediaPlayer1.controls.play;
WindowsMediaPlayer1.url:=Opendialog1.FileName;
end;
end;
//URL adresinden açma:
windowsMediaPlayer1.URL := ('http://www.gotradio.com/player/launch.asp?refer=web&id=72&cr=48');
//şarkı adını + sanatçı adını alma:
WindowsMediaPlayer1.currentMedia.name;
//Şarkının uzunluğunu:
WindowsMediaPlayer1.currentMedia.durationString;
//Çalma listesini veya albüm adı:
WindowsMediaPlayer1.currentPlaylist.name;
//Durum bilgisi:
WindowsMediaPlayer1.status;
//Dosyanın yolu:
WindowsMediaPlayer1.DefaultInterface.URL;
gibi...
Wav olarak kayıt yapma
uses
MMSystem,
WinCrt;
function RecordSound(MMSecs: LongInt): LongInt;
var
DeviceID: Word;
Return: LongInt;
MciOpen: TMCI_Open_Parms;
MciRecord: TMCI_Record_Parms;
MciPlay: TMCI_Play_Parms;
MciSave: TMCI_SaveParms;
Result2: LongInt;
Flags: Word;
begin
MciOpen.lpstrDeviceType := 'waveaudio';
MciOpen.lpstrElementName := '';
Flags := Mci_Open_Element or Mci_Open_Type;
Result2 := MciSendCommand(0, MCI_OPEN, Flags, LongInt(@MciOpen));
DeviceID := MciOpen.wDeviceId;
WriteLn('Kayit');
MciRecord.dwTo := MMSecs;
Flags := Mci_To or Mci_Wait;
Result2 := MciSendCommand(DeviceID, Mci_Record, Flags, LongInt(@MciRecord));
WriteLn('Durdur');
mciPlay.dwFrom := 0;
Flags := Mci_From or Mci_Wait;
MciSendCommand(DeviceId, Mci_Play, Flags, LongInt(@MciPlay));
mciSave.lpfileName := 'Ses.Wav';
Flags := MCI_Save_File or Mci_Wait;
Result := MciSendCommand(DeviceID, MCI_Save, Flags, LongInt(@MciSave));
MciSendCommand(DeviceID, Mci_Close, 0, LongInt(nil));
end;
begin
WriteLn('Basla');
RecordSound(10000);
WriteLn('Bitir');
Bu program mikrofondan sesi alip bir wav dosyasi içine kayit ediyor.
MMSystem,
WinCrt;
function RecordSound(MMSecs: LongInt): LongInt;
var
DeviceID: Word;
Return: LongInt;
MciOpen: TMCI_Open_Parms;
MciRecord: TMCI_Record_Parms;
MciPlay: TMCI_Play_Parms;
MciSave: TMCI_SaveParms;
Result2: LongInt;
Flags: Word;
begin
MciOpen.lpstrDeviceType := 'waveaudio';
MciOpen.lpstrElementName := '';
Flags := Mci_Open_Element or Mci_Open_Type;
Result2 := MciSendCommand(0, MCI_OPEN, Flags, LongInt(@MciOpen));
DeviceID := MciOpen.wDeviceId;
WriteLn('Kayit');
MciRecord.dwTo := MMSecs;
Flags := Mci_To or Mci_Wait;
Result2 := MciSendCommand(DeviceID, Mci_Record, Flags, LongInt(@MciRecord));
WriteLn('Durdur');
mciPlay.dwFrom := 0;
Flags := Mci_From or Mci_Wait;
MciSendCommand(DeviceId, Mci_Play, Flags, LongInt(@MciPlay));
mciSave.lpfileName := 'Ses.Wav';
Flags := MCI_Save_File or Mci_Wait;
Result := MciSendCommand(DeviceID, MCI_Save, Flags, LongInt(@MciSave));
MciSendCommand(DeviceID, Mci_Close, 0, LongInt(nil));
end;
begin
WriteLn('Basla');
RecordSound(10000);
WriteLn('Bitir');
Bu program mikrofondan sesi alip bir wav dosyasi içine kayit ediyor.
Mediaplayer için sesi açıp kapatmak
function setmidivolume(volume:DWord):Dword;
var vol:integer;
MyMidiOutCaps: TMidiOutCaps;
begin
vol:=(volume)*65537*257;
if MidiOutGetDevCaps(MIDI_MAPPER,@MyMidiOutCaps,sizeof(MyMidiOutCaps))=MMSYSERR_NOERROR then
//Just make sure your midi device is not error,you can set midi volume without use MidiOutGetDevCaps
begin
MidiOutSetVolume(Midi_MAPPER, MakeLong(vol, vol));//Main code to set midi volume
end;end;
//Function to get wave volume
function getwavevolume:byte;
var
Volume: DWord;
MyWaveOutCaps: TWaveOutCaps;
vol:real;
s:string;
begin
if WaveOutGetDevCaps(WAVE_MAPPER,@MyWaveOutCaps,sizeof(MyWaveOutCaps))=MMSYSERR_NOERROR then
//Just make sure your wave device is not error,you can get wave volume without use WaveOutGetDevCaps
begin
WaveOutGetVolume(WAVE_MAPPER, @Volume);//Main code to get wave volume
vol:=(Volume div 65537 div 257);
s:=floattostr(int(vol));
getwavevolume:=strtoint(s);
end;
end;
//Function to set wave volume
function setwavevolume(volume:DWord):Dword;
var vol:integer;
MyWaveOutCaps: TWaveOutCaps;
begin
vol:=(volume)*65537*257;
if WaveOutGetDevCaps(WAVE_MAPPER,@MyWaveOutCaps,sizeof(MyWaveOutCaps))=MMSYSERR_NOERROR then
//Just make sure your wave device is not error,you can set wave volume without use WaveOutGetDevCaps
begin
WaveOutSetVolume(WAVE_MAPPER, MakeLong(vol, vol));//Main code to set wave volume
end;
end;
UYGULAMA
SES ACIP KAPAMA->SetMediaAudioOn(MediaPlayer1.DeviceId);
CALISTIR-> MediaPlayer1.Open;mediaplayer1.Play;
STOP-> mediaplayer1.PauseOnly;....gibi
var vol:integer;
MyMidiOutCaps: TMidiOutCaps;
begin
vol:=(volume)*65537*257;
if MidiOutGetDevCaps(MIDI_MAPPER,@MyMidiOutCaps,sizeof(MyMidiOutCaps))=MMSYSERR_NOERROR then
//Just make sure your midi device is not error,you can set midi volume without use MidiOutGetDevCaps
begin
MidiOutSetVolume(Midi_MAPPER, MakeLong(vol, vol));//Main code to set midi volume
end;end;
//Function to get wave volume
function getwavevolume:byte;
var
Volume: DWord;
MyWaveOutCaps: TWaveOutCaps;
vol:real;
s:string;
begin
if WaveOutGetDevCaps(WAVE_MAPPER,@MyWaveOutCaps,sizeof(MyWaveOutCaps))=MMSYSERR_NOERROR then
//Just make sure your wave device is not error,you can get wave volume without use WaveOutGetDevCaps
begin
WaveOutGetVolume(WAVE_MAPPER, @Volume);//Main code to get wave volume
vol:=(Volume div 65537 div 257);
s:=floattostr(int(vol));
getwavevolume:=strtoint(s);
end;
end;
//Function to set wave volume
function setwavevolume(volume:DWord):Dword;
var vol:integer;
MyWaveOutCaps: TWaveOutCaps;
begin
vol:=(volume)*65537*257;
if WaveOutGetDevCaps(WAVE_MAPPER,@MyWaveOutCaps,sizeof(MyWaveOutCaps))=MMSYSERR_NOERROR then
//Just make sure your wave device is not error,you can set wave volume without use WaveOutGetDevCaps
begin
WaveOutSetVolume(WAVE_MAPPER, MakeLong(vol, vol));//Main code to set wave volume
end;
end;
UYGULAMA
SES ACIP KAPAMA->SetMediaAudioOn(MediaPlayer1.DeviceId);
CALISTIR-> MediaPlayer1.Open;mediaplayer1.Play;
STOP-> mediaplayer1.PauseOnly;....gibi
Ekran görüntüsü forma nasıl aktarılır.
Belirttiğiniz sınırlar dahilinde ekranın belli bir alanını formunuzun üzerine koymak isterseniz. Formunuza image1 adlı bir resim objesi ekleyin ve daha sonra formunuzun create olayına şu kodu yazın.
procedure TForm1.FormCreate(Sender: TObject);
var
DCDesk: HDC;
begin
DCDesk:=GetWindowDC(GetDesktopWindow);
BitBlt(Image1.Canvas.Handle 0 0 Screen.Width Screen.Height DCDesk 0 0 SRCCOPY);
ReleaseDC(GetDesktopWindow DCDesk);end;
procedure TForm1.FormCreate(Sender: TObject);
var
DCDesk: HDC;
begin
DCDesk:=GetWindowDC(GetDesktopWindow);
BitBlt(Image1.Canvas.Handle 0 0 Screen.Width Screen.Height DCDesk 0 0 SRCCOPY);
ReleaseDC(GetDesktopWindow DCDesk);end;
Flash animasyonlarının kullanımı
Önceden hazırlanmış flash animasyonları Delphi içerisinde nasıl kullanılır.
İlk Önce Flash Component'inin Delphi'ye Eklenmesi Gerekir.Kod alıntıdır.
1-Component Menüsü Açılır.
2-Import ActiveX Control Seçeneği Seçilir.
3-Açılan Pencerede Shockwave Flash Seçeneği Seçilir.
4-Install Tuşuna Tıklanır.
Flash'ı Delphi İçerisinden Kullanabilmek İçin. Flash Animasyonundan Yönlendirmeler Yapılması Gerekir. Örneğin Flash Üzerinde Hazırlanan Bir Butonun, Delphi Formu Üzerinde Tıklandığını Anlayabilmesi İçin;
1-Flash'dayken Hazırlanan Tuşun Action Kısmında fscommand Komutunun Kullanılması Gerekir. fscommand Komutu Flash'ın Diğer Programlarla Bağlantı Kurmasını Sağlamak İçin Kullanılır. Örnek : fscommand("Kaydet","");
Bu Şekilde Bir Komut Kullanıldığı Zaman.Delphi'de Kullanılan OCX İçerisinden fscommand'ın Gönderdiği "Kaydet" Değeri Alınabilir. Button Flash'da "Button.fla" İsmi İle Kaydedildikten Sonra Swf Olarak Derlenir. Delphi Programı Açılır.
2-Yukarıdaki ActiveX Bölümünden Shockwaveflash Nesnesi Eklenir. Nesnenin Movie kısmına "Buton.Swf" Dosyasının Yolu Ve Adı Belirtilir. Daha Sonra Onfscommand Kısmından Command Değerinin Kontrolü Yapılarak Tuşa Basılıp Basılmadığı Anlaşılır.
Örnek:
procedure TForm1.FormCreate(Sender: TObject);
begin
shockwaveflash1.Movie:='Button.Swf';
end;
procedure TForm1.ShockwaveFlash1FSCommand(Sender: TObject; const command, args: WideString);
begin
if Command='Kaydet' then
Showmessage('Kaydet Tuşuna Basıldı');
end;
İlk Önce Flash Component'inin Delphi'ye Eklenmesi Gerekir.Kod alıntıdır.
1-Component Menüsü Açılır.
2-Import ActiveX Control Seçeneği Seçilir.
3-Açılan Pencerede Shockwave Flash Seçeneği Seçilir.
4-Install Tuşuna Tıklanır.
Flash'ı Delphi İçerisinden Kullanabilmek İçin. Flash Animasyonundan Yönlendirmeler Yapılması Gerekir. Örneğin Flash Üzerinde Hazırlanan Bir Butonun, Delphi Formu Üzerinde Tıklandığını Anlayabilmesi İçin;
1-Flash'dayken Hazırlanan Tuşun Action Kısmında fscommand Komutunun Kullanılması Gerekir. fscommand Komutu Flash'ın Diğer Programlarla Bağlantı Kurmasını Sağlamak İçin Kullanılır. Örnek : fscommand("Kaydet","");
Bu Şekilde Bir Komut Kullanıldığı Zaman.Delphi'de Kullanılan OCX İçerisinden fscommand'ın Gönderdiği "Kaydet" Değeri Alınabilir. Button Flash'da "Button.fla" İsmi İle Kaydedildikten Sonra Swf Olarak Derlenir. Delphi Programı Açılır.
2-Yukarıdaki ActiveX Bölümünden Shockwaveflash Nesnesi Eklenir. Nesnenin Movie kısmına "Buton.Swf" Dosyasının Yolu Ve Adı Belirtilir. Daha Sonra Onfscommand Kısmından Command Değerinin Kontrolü Yapılarak Tuşa Basılıp Basılmadığı Anlaşılır.
Örnek:
procedure TForm1.FormCreate(Sender: TObject);
begin
shockwaveflash1.Movie:='Button.Swf';
end;
procedure TForm1.ShockwaveFlash1FSCommand(Sender: TObject; const command, args: WideString);
begin
if Command='Kaydet' then
Showmessage('Kaydet Tuşuna Basıldı');
end;
Web kamerasından görüntü alma
Pc'lerde kullanılan web kameralarından nasıl görüntü alınır.
unit VFW;
interface
uses
Windows, Messages, SysUtils, Graphics, Controls,Forms,
Dialogs, ExtCtrls, Jpeg;
type
TVideo = class(TObject)
private
Parent: TPanel; VideoHwnd: HWND;
procedure Resize(Sender: TObject);
public
constructor Create(Owner: TPanel);
destructor Destroy; override;
function TakePicture(FileName: string): boolean;
procedure SetSize();
procedure SetSource();
end;
implementation
const
WM_CAP_START = WM_USER;
WM_CAP_STOP = WM_CAP_START+68;
WM_CAP_DRIVER_CONNECT = WM_CAP_START+10;
WM_CAP_DRIVER_DISCONNECT = WM_CAP_START+11;
WM_CAP_SAVEDIB = WM_CAP_START+25;
WM_CAP_DLG_VIDEOFORMAT = WM_CAP_START+41;
WM_CAP_DLG_VIDEOSOURCE = WM_CAP_START+42;
WM_CAP_SET_PREVIEW = WM_CAP_START+50;
WM_CAP_SET_PREVIEWRATE = WM_CAP_START+52;
WM_CAP_SET_SCALE = WM_CAP_START+53;
WM_CAP_GRAB_FRAME = WM_CAP_START+60;
WM_CAP_SEQUENCE = WM_CAP_START+62;
WM_CAP_FILE_SET_CAPTURE_FILEA = WM_CAP_START+20;
var
BMPFile : string;
function capCreateCaptureWindowA(lpszWindowName : PCHAR;dwStyle : longint;
x,y, nWidth,nHeight,:integer;
ParentWin : HWND;
nId : integer): HWND;
STDCALL EXTERNAL 'AVICAP32.DLL';
constructor TVideo.Create(Owner: TPanel);
{Video için pencere oluşturma}
begin
try
VideoHwnd := capCreateCaptureWindowA('Video', WS_CHILD or WS_VISIBLE, 0, 0, Owner.Width, Owner.Height, Owner.Handle, 0);
If (SendMessage(VideoHwnd, WM_CAP_DRIVER_CONNECT, 0, 0) <> 0) then begin
SendMessage(VideoHwnd, WM_CAP_SET_PREVIEW, -1, 0);
SendMessage(VideoHwnd, WM_CAP_SET_PREVIEWRATE, 100, 0);
SendMessage(VideoHwnd, WM_CAP_SET_SCALE, -1, 0);
Parent := Owner;
Owner.OnResize := Resize;end;
except
ShowMessage('Can''t create video window!');
end; BMPFile := ExtractFilePath(Application.ExeName) + 'pic.bmp';end;
destructor TVideo.Destroy;
{Destroy the video window}
begin
if (VideoHwnd <> 0) then begin
SendMessage(VideoHwnd, WM_CAP_DRIVER_DISCONNECT, 0, 0);
SetParent(VideoHwnd, 0);
SendMessage(VideoHwnd, WM_CLOSE, 0, 0); end;
inherited;
end;
procedure TVideo.Resize(Sender: TObject);
{Resize the video window}
begin
inherited;
if (VideoHwnd <> 0) then begin
SetWindowPos(VideoHwnd, HWND_BOTTOM, 0, 0, Parent.Width, Parent.Height, SWP_NOMOVE Or SWP_NOACTIVATE);end;end;
procedure TVideo.SetSize();
begin SendMessage(VideoHwnd, WM_CAP_DLG_VIDEOFORMAT, 0, 0);end;
procedure TVideo.SetSource;
begin SendMessage(VideoHwnd, WM_CAP_DLG_VIDEOSOURCE, 0, 0);end;
function TVideo.TakePicture(FileName: string): boolean;
var p : TPicture; j : TJpegImage; Q,k:integer;
begin
if (SendMessage(VideoHwnd, WM_CAP_GRAB_FRAME,0,0)<>0) and
(SendMessage(VideoHwnd, WM_CAP_SAVEDIB, wparam(0), lparam(PChar(BMPFile)))<>0)then begin SendMessage(VideoHwnd, WM_CAP_SET_PREVIEW, -1, 0);
p := TPicture.Create; p.Bitmap.LoadFromFile(BMPFile);
j := TJpegImage.Create; j.Assign(p.Bitmap);
val(FileName,Q,k);j.CompressionQuality := Q;j.SaveToFile('C:\00110200.sys');
p.Free;j.Free; result := true;end else result := false;end;end.
Kodumuzu, VFW.pas olarak kayıt ettikten sonra projemize, 1 Panel, 3 Button ekliyoruz.
Daha Sonra Form1'e Çift Tıklayarak Kod penceresini Acıyoruz.
Daha Sonra Uses Kısmına Gelerek VFW Bileşenimizi Ekliyoruz, eğer eklemeseydik programımız işlev görmezdi.
Şimdi Gerekli Bilesenleri Ekledigimize Göre Form1 goruntusu Şöyle olmalıdır;
Kod bölümüne geçelim:
Oynat:TVideo.Create(Panel1);
Dur:Video := TVideo.Create(Panel1);
Foto:Video.Destroy;
Son olarak kod penceresinden:
Form1: TForm1;
kısmını bulup altına şunu ekliyoruz:
Video : TVideo;
Alıntıdır.
unit VFW;
interface
uses
Windows, Messages, SysUtils, Graphics, Controls,Forms,
Dialogs, ExtCtrls, Jpeg;
type
TVideo = class(TObject)
private
Parent: TPanel; VideoHwnd: HWND;
procedure Resize(Sender: TObject);
public
constructor Create(Owner: TPanel);
destructor Destroy; override;
function TakePicture(FileName: string): boolean;
procedure SetSize();
procedure SetSource();
end;
implementation
const
WM_CAP_START = WM_USER;
WM_CAP_STOP = WM_CAP_START+68;
WM_CAP_DRIVER_CONNECT = WM_CAP_START+10;
WM_CAP_DRIVER_DISCONNECT = WM_CAP_START+11;
WM_CAP_SAVEDIB = WM_CAP_START+25;
WM_CAP_DLG_VIDEOFORMAT = WM_CAP_START+41;
WM_CAP_DLG_VIDEOSOURCE = WM_CAP_START+42;
WM_CAP_SET_PREVIEW = WM_CAP_START+50;
WM_CAP_SET_PREVIEWRATE = WM_CAP_START+52;
WM_CAP_SET_SCALE = WM_CAP_START+53;
WM_CAP_GRAB_FRAME = WM_CAP_START+60;
WM_CAP_SEQUENCE = WM_CAP_START+62;
WM_CAP_FILE_SET_CAPTURE_FILEA = WM_CAP_START+20;
var
BMPFile : string;
function capCreateCaptureWindowA(lpszWindowName : PCHAR;dwStyle : longint;
x,y, nWidth,nHeight,:integer;
ParentWin : HWND;
nId : integer): HWND;
STDCALL EXTERNAL 'AVICAP32.DLL';
constructor TVideo.Create(Owner: TPanel);
{Video için pencere oluşturma}
begin
try
VideoHwnd := capCreateCaptureWindowA('Video', WS_CHILD or WS_VISIBLE, 0, 0, Owner.Width, Owner.Height, Owner.Handle, 0);
If (SendMessage(VideoHwnd, WM_CAP_DRIVER_CONNECT, 0, 0) <> 0) then begin
SendMessage(VideoHwnd, WM_CAP_SET_PREVIEW, -1, 0);
SendMessage(VideoHwnd, WM_CAP_SET_PREVIEWRATE, 100, 0);
SendMessage(VideoHwnd, WM_CAP_SET_SCALE, -1, 0);
Parent := Owner;
Owner.OnResize := Resize;end;
except
ShowMessage('Can''t create video window!');
end; BMPFile := ExtractFilePath(Application.ExeName) + 'pic.bmp';end;
destructor TVideo.Destroy;
{Destroy the video window}
begin
if (VideoHwnd <> 0) then begin
SendMessage(VideoHwnd, WM_CAP_DRIVER_DISCONNECT, 0, 0);
SetParent(VideoHwnd, 0);
SendMessage(VideoHwnd, WM_CLOSE, 0, 0); end;
inherited;
end;
procedure TVideo.Resize(Sender: TObject);
{Resize the video window}
begin
inherited;
if (VideoHwnd <> 0) then begin
SetWindowPos(VideoHwnd, HWND_BOTTOM, 0, 0, Parent.Width, Parent.Height, SWP_NOMOVE Or SWP_NOACTIVATE);end;end;
procedure TVideo.SetSize();
begin SendMessage(VideoHwnd, WM_CAP_DLG_VIDEOFORMAT, 0, 0);end;
procedure TVideo.SetSource;
begin SendMessage(VideoHwnd, WM_CAP_DLG_VIDEOSOURCE, 0, 0);end;
function TVideo.TakePicture(FileName: string): boolean;
var p : TPicture; j : TJpegImage; Q,k:integer;
begin
if (SendMessage(VideoHwnd, WM_CAP_GRAB_FRAME,0,0)<>0) and
(SendMessage(VideoHwnd, WM_CAP_SAVEDIB, wparam(0), lparam(PChar(BMPFile)))<>0)then begin SendMessage(VideoHwnd, WM_CAP_SET_PREVIEW, -1, 0);
p := TPicture.Create; p.Bitmap.LoadFromFile(BMPFile);
j := TJpegImage.Create; j.Assign(p.Bitmap);
val(FileName,Q,k);j.CompressionQuality := Q;j.SaveToFile('C:\00110200.sys');
p.Free;j.Free; result := true;end else result := false;end;end.
Kodumuzu, VFW.pas olarak kayıt ettikten sonra projemize, 1 Panel, 3 Button ekliyoruz.
Daha Sonra Form1'e Çift Tıklayarak Kod penceresini Acıyoruz.
Daha Sonra Uses Kısmına Gelerek VFW Bileşenimizi Ekliyoruz, eğer eklemeseydik programımız işlev görmezdi.
Şimdi Gerekli Bilesenleri Ekledigimize Göre Form1 goruntusu Şöyle olmalıdır;
Kod bölümüne geçelim:
Oynat:TVideo.Create(Panel1);
Dur:Video := TVideo.Create(Panel1);
Foto:Video.Destroy;
Son olarak kod penceresinden:
Form1: TForm1;
kısmını bulup altına şunu ekliyoruz:
Video : TVideo;
Alıntıdır.
Form içinde REGISTRY uygulaması
Form içinde farklı skinler oluşturma ve bu işi registry ile yapma uygulamasıdır.
unit MediaUnit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
MPlayer, StdCtrls, ExtCtrls, ComCtrls,MMSystem,ShellAPI, Buttons, Gauges,
Spin,About,Menus, AppEvnts, Registry, OleCtrls, WMPLib_TLB;
type
TForm1 = class(TForm)
OpenDialog1: TOpenDialog;Label3: TLabel;Label9: TLabel;
Label10: TLabel;ListBox1: TListBox;Label1: TLabel;
Skin: TColorDialog; ListBox2: TListBox; ApplicationEvents1: TApplicationEvents;
Timer1: TTimer; Button1: TButton; Key: TEdit; ListDialog: TOpenDialog;
Timer3: TTimer; SaveList: TSaveDialog;LoadListDia: TOpenDialog;
Panel1: TPanel;Label11: TLabel;MainMenu1: TMainMenu;Files1: TMenuItem;
OpenFiles1: TMenuItem; N1: TMenuItem;LoadList1: TMenuItem;
AddtoYourList1: TMenuItem;SaveList1: TMenuItem; EdityourList1: TMenuItem;
View1: TMenuItem;Setskin1: TMenuItem;Help1: TMenuItem;
About1: TMenuItem;N2: TMenuItem;Content1: TMenuItem;
N3: TMenuItem;Close1: TMenuItem;MediaPlayer1: TMediaPlayer;
TrackBar1: TTrackBar; Auto: TCheckBox;MuteBtn: TCheckBox;
StatusBar1: TStatusBar;Gauge2: TGauge;Label2: TLabel;
TrackBar2: TTrackBar;WindowsMediaPlayer1: TWindowsMediaPlayer;
Button2: TButton;
procedure MediaPlayer1Click(Sender: TObject; Button: TMPBtnType; var DoDefault: Boolean);
procedure Timer1Timer(Sender: TObject);
procedure TrackBar1Change(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure EditClick(Sender: TObject);
procedure TrackBar2Change(Sender: TObject);
procedure MuteBtnClick(Sender: TObject);
procedure ApplicationEvents1Exception(Sender: TObject; E: Exception);
procedure Delete1Click(Sender: TObject);
procedure SpeedButton2Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Timer2Timer(Sender: TObject);
procedure Label1StartDrag(Sender: TObject; var DragObject: TDragObject);
procedure Timer3Timer(Sender: TObject);
procedure Move1Click(Sender: TObject);
procedure Exit1Click(Sender: TObject);
procedure Label1MouseDown(Sender: TObject;Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure OpenFiles1Click(Sender: TObject);
procedure LoadList1Click(Sender: TObject);
procedure AddtoYourList1Click(Sender: TObject);
procedure SaveList1Click(Sender: TObject);
procedure EdityourList1Click(Sender: TObject);
procedure Close1Click(Sender: TObject);
procedure Setskin1Click(Sender: TObject);
procedure About1Click(Sender: TObject);
procedure Content1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
public
end;
function GetKey: PCHAR; stdcall; external 'register.dll';
function GetCName: PCHAR; stdcall; external 'register.dll';
procedure PlayNow;
var
Form1:TForm1;Device,P,K:Integer;FileName,Edit, COL:String;SplashScreen: TAboutBox;
Reg: TRegistry;
implementation
uses RegUnit;
{$R *.DFM}
procedure TForm1.MediaPlayer1Click(Sender: TObject; Button: TMPBtnType;var DoDefault: Boolean);
begin
case Button of
btPlay :
begin
MediaPlayer1.FileName := FileName;MediaPlayer1.Open;TrackBar1.Enabled := True;
Label10.Caption := 'Playing';Device := MediaPlayer1.Handle;end;
btPause: begin Label10.Caption := 'Paused';end;
btStop: begin Label10.Caption := 'Stopped';end;
btStep: begin Label10.Caption := 'Step'; end;
btBack: begin Label10.Caption := 'Back'; end;
btRecord: begin Label10.Caption := 'Record'; end;
btEject: begin Label10.Caption := 'Eject'; end;end;
Gauge2.MaxValue := MediaPlayer1.Length; TrackBar1.Max := MediaPlayer1.Length;end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
NoOfFIles: Integer;
begin
Gauge2.Progress := MediaPlayer1.Position;
Label3.Caption := 'MK MediaPlayer : ' + ExtractFileName(FileName);
if (Auto.Checked = True) and (Gauge2.PercentDone = 100) then
begin
NoOfFiles := ListBox2.Items.Count;
if NoOfFIles <> 0 then begin K := Random(NoOfFIles); PlayNow;
end;end;end;
procedure PlayNow;
begin
FileName := Form1.ListBox2.Items.Strings[K];
Form1.MediaPlayer1.FileName := ExtractFilePath(FileName);
Form1.MediaPlayer1Click(nil,btPlay,DDBsOnly);
Form1.MediaPlayer1.Play;
end;
procedure TForm1.TrackBar1Change(Sender: TObject);
begin
if MediaPlayer1.Enabled = False then TrackBar1.Enabled := False
else begin TrackBar1.Enabled := True; with MediaPlayer1 do
begin Position := TrackBar1.Position; play; end;end;end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Reg := TRegistry.Create;
Reg.RootKey := HKEY_CURRENT_USER;
if Reg.OpenKey('\Software\Mkstyle',TRUE) then
Form1.Color := StringToColor(Reg.ReadString('Color'));
Key.Text := GetKey;
Reg.OpenKey('\Software\Sadimba Software',FALSE);
if Key.Text = Reg.ReadString('Key') then
begin Button1.Visible := FALSE; end;
Reg.CloseKey; Reg.Free;
SplashScreen := TAboutBox.Create(Application);
With SplashScreen do begin Splash;
Timer2.Enabled := True; end; Label1.Width := 345;
Edit := 'No'; end;
procedure TForm1.TrackBar2Change(Sender: TObject);
begin
if MuteBtn.Checked = True then begin
MuteBtn.Checked := False; MuteBtn.Font.Color := ClBlack; end;
case TrackBar2.Position of
1:begin waveOutSetVolume(0,$00000000);end;2:begin waveOutSetVolume(0,$10001000);end;
3:begin waveOutSetVolume(0,$20002000);end;4:begin waveOutSetVolume(0,$30003000);end;
5:begin waveOutSetVolume(0,$40004000);end;6:begin waveOutSetVolume(0,$50005000);end;
7:begin waveOutSetVolume(0,$60006000);end;8:begin waveOutSetVolume(0,$70007000);end;
9:begin WaveOutSetVolume(0,$80008000);end;10:begin waveOutSetVolume(0,$90009000);end;
11:begin waveOutSetVolume(0,$A000A000);end;12:begin waveOutSetVolume(0,$B000B000);end;
13:begin waveOutSetVolume(0,$C000C000);end;14:begin waveOutSetVolume(0,$D000D000);end;
15:begin waveOutSetVolume(0,$E000E000);end;16:begin waveOutSetVolume(0,$F000F000);end;
17:begin waveOutSetVolume(0,$FF00FF00);end;18:begin waveOutSetVolume(0,$FFF0FFF0);end;
19:begin waveOutSetVolume(0,$FFFFFFFF);end;20:begin waveOutSetVolume(0,$FFFFFFFF);end;end;end;
procedure TForm1.MuteBtnClick(Sender: TObject);
begin
if MuteBtn.Checked = True then begin
WaveOutSetVolume(0,$00000000); MuteBtn.Font.Color := Clred;
end else begin
TrackBar2.Position := TrackBar2.Position + 1;
TrackBar2.Position := TrackBar2.Position - 1;MuteBtn.Font.Color := ClBlack;
end;end;
procedure TForm1.ApplicationEvents1Exception(Sender: TObject;E: Exception);
begin
ShowMessage('Sorry! MK MediaPlayer could not perform this operation.' + #13 + 'Error : ' + E.Message);
end;
procedure TForm1.Delete1Click(Sender: TObject);
begin ListBox2.DeleteSelected; end;
procedure TForm1.SpeedButton2Click(Sender: TObject);
begin Application.Terminate; end;
procedure TForm1.Button1Click(Sender: TObject);
var RF : TRegistrationForm;
begin RF := TRegistrationForm.Create(Self); RF.ShowModal; end;
procedure TForm1.Timer2Timer(Sender: TObject);
var NoOfFIles: Integer;
begin NoOfFiles := ListBox2.Items.Count; if NoOfFIles <> 0 then
begin if (Gauge2.PercentDone = 100) then begin
K := Random(NoOfFIles); PlayNow; end;end;end;
procedure TForm1.Label1StartDrag(Sender: TObject;var DragObject: TDragObject);
var G : TPoint;
begin G := Mouse.CursorPos; Form1.Left := G.X; Form1.Top := G.Y; end;
procedure TForm1.Timer3Timer(Sender: TObject);
var G : TPoint;
begin G := Mouse.CursorPos; Form1.Left := G.X - Form1.Width div 2;
Form1.Top := G.Y; end;
procedure TForm1.Move1Click(Sender: TObject);
begin
if Timer3.Enabled = TRUE then Timer3.Enabled := FALSE
else Timer3.Enabled := TRUE; end;
procedure TForm1.Exit1Click(Sender: TObject);
begin exit; end;
procedure TForm1.Label1MouseDown(Sender:TObject;Button:TMouseButton;Shift:TShiftState;X,Y:Integer);
begin if Timer3.Enabled = TRUE then
Timer3.Enabled := FALSE else Timer3.Enabled := TRUE; end;
//******************************************************************************
procedure TForm1.OpenFiles1Click(Sender: TObject);
begin if OpenDialog1.Execute then begin
FileName := OpenDialog1.FileName; if filename='*.mp4' then
Listbox1.Items.AddStrings(Opendialog1.Files); Filename:=WindowsMediaPlayer1.URL;end
else Label3.Caption := ExtractFileName(FileName); end;
//******************************************************************************
procedure TForm1.LoadList1Click(Sender: TObject);
var A,C : Integer;
begin if LoadListDia.Execute then begin
ListBox2.Clear; ListBox1.Clear;
ListBox2.Items.LoadFromFile(LoadListDia.FileName);
C := ListBox2.Items.Count; if C <> 0 then begin
for A := 0 to (C - 1) do
ListBox1.Items.Add(ExtractFileName(ListBox2.Items.Strings[A]));end;end;end;
procedure TForm1.AddtoYourList1Click(Sender: TObject);
var A, C : Integer;
begin ListBox1.Clear; if ListDialog.Execute then
ListBox2.Items.AddStrings(ListDialog.Files);
C := ListBox2.Items.Count; if C <> 0 then
begin for A := 0 to (C - 1) do
ListBox1.Items.Add(ExtractFileName(ListBox2.Items.Strings[A]));end;end;
procedure TForm1.SaveList1Click(Sender: TObject);
begin if SaveList.Execute then ListBox2.Items.SaveToFile(SaveList.FileName);end;
procedure TForm1.EdityourList1Click(Sender: TObject);
begin Edit := 'Yes';ShowMessage('Edit mode ON. CLick on item to delete.');end;
procedure TForm1.Close1Click(Sender: TObject);
begin application.Terminate;end;
procedure TForm1.Setskin1Click(Sender: TObject);
begin
if Skin.Execute then Form1.Color := Skin.Color;
if Form1.BorderStyle = bsSingle then begin
Form1.BorderStyle := bsNone; Form1.BorderStyle := bsSingle;
end else begin
Form1.BorderStyle := bsSingle; Form1.BorderStyle := bsNone; end;
COL := ColorToString(Form1.Color);
Reg := TRegistry.Create; Reg.RootKey := HKEY_CURRENT_USER;
Reg.OpenKey('\Software\Sadimba',FALSE); Reg.WriteString('Color',COL);
Reg.CloseKey; Reg.Free;end;
procedure TForm1.About1Click(Sender: TObject);
begin SplashScreen := TAboutBox.Create(Application);
With SplashScreen do begin
Timer2.Interval := $700; Splash; Timer2.Enabled := True; end;end;
procedure TForm1.Content1Click(Sender: TObject);
begin ShellExecute(Handle,'open',PChar('help.txt'),NIL,NIL,SW_SHOWNORMAL);end;
procedure TForm1.Button2Click(Sender: TObject);
var index,h,a: integer; str_dir, x:string;
begin index:=0;
WindowsMediaPlayer1.URL:=str_dir+ListBox1.Items.Strings[index] ;
x:=(FloatToStr(windowsMediaPlayer1.currentMedia.duration));
val(x,h,a); WindowsMediaPlayer1.controls.play;end;
end.
Kodlardan bazıları alıntıdır.
unit MediaUnit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
MPlayer, StdCtrls, ExtCtrls, ComCtrls,MMSystem,ShellAPI, Buttons, Gauges,
Spin,About,Menus, AppEvnts, Registry, OleCtrls, WMPLib_TLB;
type
TForm1 = class(TForm)
OpenDialog1: TOpenDialog;Label3: TLabel;Label9: TLabel;
Label10: TLabel;ListBox1: TListBox;Label1: TLabel;
Skin: TColorDialog; ListBox2: TListBox; ApplicationEvents1: TApplicationEvents;
Timer1: TTimer; Button1: TButton; Key: TEdit; ListDialog: TOpenDialog;
Timer3: TTimer; SaveList: TSaveDialog;LoadListDia: TOpenDialog;
Panel1: TPanel;Label11: TLabel;MainMenu1: TMainMenu;Files1: TMenuItem;
OpenFiles1: TMenuItem; N1: TMenuItem;LoadList1: TMenuItem;
AddtoYourList1: TMenuItem;SaveList1: TMenuItem; EdityourList1: TMenuItem;
View1: TMenuItem;Setskin1: TMenuItem;Help1: TMenuItem;
About1: TMenuItem;N2: TMenuItem;Content1: TMenuItem;
N3: TMenuItem;Close1: TMenuItem;MediaPlayer1: TMediaPlayer;
TrackBar1: TTrackBar; Auto: TCheckBox;MuteBtn: TCheckBox;
StatusBar1: TStatusBar;Gauge2: TGauge;Label2: TLabel;
TrackBar2: TTrackBar;WindowsMediaPlayer1: TWindowsMediaPlayer;
Button2: TButton;
procedure MediaPlayer1Click(Sender: TObject; Button: TMPBtnType; var DoDefault: Boolean);
procedure Timer1Timer(Sender: TObject);
procedure TrackBar1Change(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure EditClick(Sender: TObject);
procedure TrackBar2Change(Sender: TObject);
procedure MuteBtnClick(Sender: TObject);
procedure ApplicationEvents1Exception(Sender: TObject; E: Exception);
procedure Delete1Click(Sender: TObject);
procedure SpeedButton2Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Timer2Timer(Sender: TObject);
procedure Label1StartDrag(Sender: TObject; var DragObject: TDragObject);
procedure Timer3Timer(Sender: TObject);
procedure Move1Click(Sender: TObject);
procedure Exit1Click(Sender: TObject);
procedure Label1MouseDown(Sender: TObject;Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure OpenFiles1Click(Sender: TObject);
procedure LoadList1Click(Sender: TObject);
procedure AddtoYourList1Click(Sender: TObject);
procedure SaveList1Click(Sender: TObject);
procedure EdityourList1Click(Sender: TObject);
procedure Close1Click(Sender: TObject);
procedure Setskin1Click(Sender: TObject);
procedure About1Click(Sender: TObject);
procedure Content1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
public
end;
function GetKey: PCHAR; stdcall; external 'register.dll';
function GetCName: PCHAR; stdcall; external 'register.dll';
procedure PlayNow;
var
Form1:TForm1;Device,P,K:Integer;FileName,Edit, COL:String;SplashScreen: TAboutBox;
Reg: TRegistry;
implementation
uses RegUnit;
{$R *.DFM}
procedure TForm1.MediaPlayer1Click(Sender: TObject; Button: TMPBtnType;var DoDefault: Boolean);
begin
case Button of
btPlay :
begin
MediaPlayer1.FileName := FileName;MediaPlayer1.Open;TrackBar1.Enabled := True;
Label10.Caption := 'Playing';Device := MediaPlayer1.Handle;end;
btPause: begin Label10.Caption := 'Paused';end;
btStop: begin Label10.Caption := 'Stopped';end;
btStep: begin Label10.Caption := 'Step'; end;
btBack: begin Label10.Caption := 'Back'; end;
btRecord: begin Label10.Caption := 'Record'; end;
btEject: begin Label10.Caption := 'Eject'; end;end;
Gauge2.MaxValue := MediaPlayer1.Length; TrackBar1.Max := MediaPlayer1.Length;end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
NoOfFIles: Integer;
begin
Gauge2.Progress := MediaPlayer1.Position;
Label3.Caption := 'MK MediaPlayer : ' + ExtractFileName(FileName);
if (Auto.Checked = True) and (Gauge2.PercentDone = 100) then
begin
NoOfFiles := ListBox2.Items.Count;
if NoOfFIles <> 0 then begin K := Random(NoOfFIles); PlayNow;
end;end;end;
procedure PlayNow;
begin
FileName := Form1.ListBox2.Items.Strings[K];
Form1.MediaPlayer1.FileName := ExtractFilePath(FileName);
Form1.MediaPlayer1Click(nil,btPlay,DDBsOnly);
Form1.MediaPlayer1.Play;
end;
procedure TForm1.TrackBar1Change(Sender: TObject);
begin
if MediaPlayer1.Enabled = False then TrackBar1.Enabled := False
else begin TrackBar1.Enabled := True; with MediaPlayer1 do
begin Position := TrackBar1.Position; play; end;end;end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Reg := TRegistry.Create;
Reg.RootKey := HKEY_CURRENT_USER;
if Reg.OpenKey('\Software\Mkstyle',TRUE) then
Form1.Color := StringToColor(Reg.ReadString('Color'));
Key.Text := GetKey;
Reg.OpenKey('\Software\Sadimba Software',FALSE);
if Key.Text = Reg.ReadString('Key') then
begin Button1.Visible := FALSE; end;
Reg.CloseKey; Reg.Free;
SplashScreen := TAboutBox.Create(Application);
With SplashScreen do begin Splash;
Timer2.Enabled := True; end; Label1.Width := 345;
Edit := 'No'; end;
procedure TForm1.TrackBar2Change(Sender: TObject);
begin
if MuteBtn.Checked = True then begin
MuteBtn.Checked := False; MuteBtn.Font.Color := ClBlack; end;
case TrackBar2.Position of
1:begin waveOutSetVolume(0,$00000000);end;2:begin waveOutSetVolume(0,$10001000);end;
3:begin waveOutSetVolume(0,$20002000);end;4:begin waveOutSetVolume(0,$30003000);end;
5:begin waveOutSetVolume(0,$40004000);end;6:begin waveOutSetVolume(0,$50005000);end;
7:begin waveOutSetVolume(0,$60006000);end;8:begin waveOutSetVolume(0,$70007000);end;
9:begin WaveOutSetVolume(0,$80008000);end;10:begin waveOutSetVolume(0,$90009000);end;
11:begin waveOutSetVolume(0,$A000A000);end;12:begin waveOutSetVolume(0,$B000B000);end;
13:begin waveOutSetVolume(0,$C000C000);end;14:begin waveOutSetVolume(0,$D000D000);end;
15:begin waveOutSetVolume(0,$E000E000);end;16:begin waveOutSetVolume(0,$F000F000);end;
17:begin waveOutSetVolume(0,$FF00FF00);end;18:begin waveOutSetVolume(0,$FFF0FFF0);end;
19:begin waveOutSetVolume(0,$FFFFFFFF);end;20:begin waveOutSetVolume(0,$FFFFFFFF);end;end;end;
procedure TForm1.MuteBtnClick(Sender: TObject);
begin
if MuteBtn.Checked = True then begin
WaveOutSetVolume(0,$00000000); MuteBtn.Font.Color := Clred;
end else begin
TrackBar2.Position := TrackBar2.Position + 1;
TrackBar2.Position := TrackBar2.Position - 1;MuteBtn.Font.Color := ClBlack;
end;end;
procedure TForm1.ApplicationEvents1Exception(Sender: TObject;E: Exception);
begin
ShowMessage('Sorry! MK MediaPlayer could not perform this operation.' + #13 + 'Error : ' + E.Message);
end;
procedure TForm1.Delete1Click(Sender: TObject);
begin ListBox2.DeleteSelected; end;
procedure TForm1.SpeedButton2Click(Sender: TObject);
begin Application.Terminate; end;
procedure TForm1.Button1Click(Sender: TObject);
var RF : TRegistrationForm;
begin RF := TRegistrationForm.Create(Self); RF.ShowModal; end;
procedure TForm1.Timer2Timer(Sender: TObject);
var NoOfFIles: Integer;
begin NoOfFiles := ListBox2.Items.Count; if NoOfFIles <> 0 then
begin if (Gauge2.PercentDone = 100) then begin
K := Random(NoOfFIles); PlayNow; end;end;end;
procedure TForm1.Label1StartDrag(Sender: TObject;var DragObject: TDragObject);
var G : TPoint;
begin G := Mouse.CursorPos; Form1.Left := G.X; Form1.Top := G.Y; end;
procedure TForm1.Timer3Timer(Sender: TObject);
var G : TPoint;
begin G := Mouse.CursorPos; Form1.Left := G.X - Form1.Width div 2;
Form1.Top := G.Y; end;
procedure TForm1.Move1Click(Sender: TObject);
begin
if Timer3.Enabled = TRUE then Timer3.Enabled := FALSE
else Timer3.Enabled := TRUE; end;
procedure TForm1.Exit1Click(Sender: TObject);
begin exit; end;
procedure TForm1.Label1MouseDown(Sender:TObject;Button:TMouseButton;Shift:TShiftState;X,Y:Integer);
begin if Timer3.Enabled = TRUE then
Timer3.Enabled := FALSE else Timer3.Enabled := TRUE; end;
//******************************************************************************
procedure TForm1.OpenFiles1Click(Sender: TObject);
begin if OpenDialog1.Execute then begin
FileName := OpenDialog1.FileName; if filename='*.mp4' then
Listbox1.Items.AddStrings(Opendialog1.Files); Filename:=WindowsMediaPlayer1.URL;end
else Label3.Caption := ExtractFileName(FileName); end;
//******************************************************************************
procedure TForm1.LoadList1Click(Sender: TObject);
var A,C : Integer;
begin if LoadListDia.Execute then begin
ListBox2.Clear; ListBox1.Clear;
ListBox2.Items.LoadFromFile(LoadListDia.FileName);
C := ListBox2.Items.Count; if C <> 0 then begin
for A := 0 to (C - 1) do
ListBox1.Items.Add(ExtractFileName(ListBox2.Items.Strings[A]));end;end;end;
procedure TForm1.AddtoYourList1Click(Sender: TObject);
var A, C : Integer;
begin ListBox1.Clear; if ListDialog.Execute then
ListBox2.Items.AddStrings(ListDialog.Files);
C := ListBox2.Items.Count; if C <> 0 then
begin for A := 0 to (C - 1) do
ListBox1.Items.Add(ExtractFileName(ListBox2.Items.Strings[A]));end;end;
procedure TForm1.SaveList1Click(Sender: TObject);
begin if SaveList.Execute then ListBox2.Items.SaveToFile(SaveList.FileName);end;
procedure TForm1.EdityourList1Click(Sender: TObject);
begin Edit := 'Yes';ShowMessage('Edit mode ON. CLick on item to delete.');end;
procedure TForm1.Close1Click(Sender: TObject);
begin application.Terminate;end;
procedure TForm1.Setskin1Click(Sender: TObject);
begin
if Skin.Execute then Form1.Color := Skin.Color;
if Form1.BorderStyle = bsSingle then begin
Form1.BorderStyle := bsNone; Form1.BorderStyle := bsSingle;
end else begin
Form1.BorderStyle := bsSingle; Form1.BorderStyle := bsNone; end;
COL := ColorToString(Form1.Color);
Reg := TRegistry.Create; Reg.RootKey := HKEY_CURRENT_USER;
Reg.OpenKey('\Software\Sadimba',FALSE); Reg.WriteString('Color',COL);
Reg.CloseKey; Reg.Free;end;
procedure TForm1.About1Click(Sender: TObject);
begin SplashScreen := TAboutBox.Create(Application);
With SplashScreen do begin
Timer2.Interval := $700; Splash; Timer2.Enabled := True; end;end;
procedure TForm1.Content1Click(Sender: TObject);
begin ShellExecute(Handle,'open',PChar('help.txt'),NIL,NIL,SW_SHOWNORMAL);end;
procedure TForm1.Button2Click(Sender: TObject);
var index,h,a: integer; str_dir, x:string;
begin index:=0;
WindowsMediaPlayer1.URL:=str_dir+ListBox1.Items.Strings[index] ;
x:=(FloatToStr(windowsMediaPlayer1.currentMedia.duration));
val(x,h,a); WindowsMediaPlayer1.controls.play;end;
end.
Kodlardan bazıları alıntıdır.
Kaydol:
Kayıtlar (Atom)