Programlama yapalım ve Öğrenelim.

objeleri çalışma zamanında oynatmak yerini değiştirmek

//objeleri çalışma zamanında oynatmak yerini değiştirmek

unit Unit4;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls, ExtCtrls;

type

TForm1 = class(TForm)

Image1: TImage;

Label1: TLabel;

procedure MainMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);

procedure MainMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

private

GrabPt : TPoint;

public

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

{ TForm1 }

procedure TForm1.MainMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);

begin

if ssLeft in Shift then

with Sender as TControl do

SetBounds(Left+X-GrabPt.X,Top+Y-GrabPt.Y,Width,Height);

end;

procedure TForm1.MainMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

begin

GrabPt := Point(X,Y);

end;

end.

Delphi - .....................................

objeleri çalışma zamanında oynatmak yerini değiştirmek

//objeleri çalışma zamanında oynatmak yerini değiştirmek

unit Unit4;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls, ExtCtrls;

type

TForm1 = class(TForm)

Image1: TImage;

Label1: TLabel;

procedure MainMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);

procedure MainMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

private

GrabPt : TPoint;

public

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

{ TForm1 }

procedure TForm1.MainMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);

begin

if ssLeft in Shift then

with Sender as TControl do

SetBounds(Left+X-GrabPt.X,Top+Y-GrabPt.Y,Width,Height);

end;

procedure TForm1.MainMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

begin

GrabPt := Point(X,Y);

end;

end.

Delphi - .....................................

DevX - Delphi ile INF dosyalarını install(yüklemek) etme

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

{

Usage:

InstallINF('C:XYZ.inf', 0) ;

}

uses

ShellAPI;

function InstallINF(const PathName: string; hParent: HWND): Boolean;

var

instance: HINST;

begin

instance := ShellExecute(hParent,

PChar('open'),

PChar('rundll32.exe'),

PChar('setupapi,InstallHinfSection

DefaultInstall 132 ' + PathName),

nil,

SW_HIDE) ;

Result := instance > 32;

end;

Delphi - .....................................

DevX - Delphi ile INF dosyalarını install(yüklemek) etme

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

{

Usage:

InstallINF('C:XYZ.inf', 0) ;

}

uses

ShellAPI;

function InstallINF(const PathName: string; hParent: HWND): Boolean;

var

instance: HINST;

begin

instance := ShellExecute(hParent,

PChar('open'),

PChar('rundll32.exe'),

PChar('setupapi,InstallHinfSection

DefaultInstall 132 ' + PathName),

nil,

SW_HIDE) ;

Result := instance > 32;

end;

Delphi - .....................................

DevX - Programı Taskbarda Gizleme

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

procedure TForm1.FormCreate(Sender: TObject) ;

begin

ShowWindow(Application.Handle, SW_HIDE) ;

SetWindowLong(Application.Handle, GWL_EXSTYLE,

getWindowLong(Application.Handle, GWL_EXSTYLE) or

WS_EX_TOOLWINDOW) ;

ShowWindow(Application.Handle, SW_SHOW) ;

end;

Delphi - .....................................

DevX - Programı Taskbarda Gizleme

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

procedure TForm1.FormCreate(Sender: TObject) ;

begin

ShowWindow(Application.Handle, SW_HIDE) ;

SetWindowLong(Application.Handle, GWL_EXSTYLE,

getWindowLong(Application.Handle, GWL_EXSTYLE) or

WS_EX_TOOLWINDOW) ;

ShowWindow(Application.Handle, SW_SHOW) ;

end;

Delphi - .....................................

DevX - Bul ve Değiştir

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

function SearchAndReplace

(sSrc, sLookFor, sReplaceWith : string) : string;

var

nPos, nLenLookFor : integer;

begin

nPos := Pos(sLookFor, sSrc) ;

nLenLookFor := Length(sLookFor) ;

while (nPos > 0) do begin

Delete(sSrc, nPos, nLenLookFor) ;

Insert(sReplaceWith, sSrc, nPos) ;

nPos := Pos(sLookFor, sSrc) ;

end;

Result := sSrc;

end;

Delphi - .....................................

DevX - Bul ve Değiştir

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

function SearchAndReplace

(sSrc, sLookFor, sReplaceWith : string) : string;

var

nPos, nLenLookFor : integer;

begin

nPos := Pos(sLookFor, sSrc) ;

nLenLookFor := Length(sLookFor) ;

while (nPos > 0) do begin

Delete(sSrc, nPos, nLenLookFor) ;

Insert(sReplaceWith, sSrc, nPos) ;

nPos := Pos(sLookFor, sSrc) ;

end;

Result := sSrc;

end;

Delphi - .....................................

DevX - Kümeden(Array) kayıt silme

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

var

myArray: TStringArray;

...//delete fifth element

DeleteArrayItem(myArray, 5) ;

~~~~~~~~~~~~~~~~~~~~~~~~~

type

TStringArray = array of string;

procedure DeleteArrayItem(var X: TStringArray; const Index: Integer) ;

begin

if Index > High(X) then Exit;

if Index < Low(X) then Exit;

if Index = High(X) then

begin

SetLength(X, Length(X) - 1) ;

Exit;

end;

Finalize(X[Index]) ;

System.Move(X[Index +1], X[Index],(Length(X) - Index -1) * SizeOf(string) + 1) ;

SetLength(X, Length(X) - 1) ;

end;

Delphi - .....................................

DevX - Kümeden(Array) kayıt silme

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

var

myArray: TStringArray;

...//delete fifth element

DeleteArrayItem(myArray, 5) ;

~~~~~~~~~~~~~~~~~~~~~~~~~

type

TStringArray = array of string;

procedure DeleteArrayItem(var X: TStringArray; const Index: Integer) ;

begin

if Index > High(X) then Exit;

if Index < Low(X) then Exit;

if Index = High(X) then

begin

SetLength(X, Length(X) - 1) ;

Exit;

end;

Finalize(X[Index]) ;

System.Move(X[Index +1], X[Index],(Length(X) - Index -1) * SizeOf(string) + 1) ;

SetLength(X, Length(X) - 1) ;

end;

Delphi - .....................................

DevX - Sürücüleri Türleriyle Beraber Listeleme

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

procedure TForm1.Button1Click(Sender: TObject) ;

var

Drive: Char;

DriveLetter: String[4];

begin

for Drive := 'A' to 'Z' do

begin

DriveLetter := Drive + ':';

case GetDriveType(PChar(Drive + ':')) of

DRIVE_REMOVABLE:

Memo1.Lines.Add(DriveLetter + ' Floppy Drive') ;

DRIVE_FIXED:

Memo1.Lines.Add(DriveLetter + ' Fixed Drive') ;

DRIVE_REMOTE:

Memo1.Lines.Add(DriveLetter + ' Network Drive') ;

DRIVE_CDROM:

Memo1.Lines.Add(DriveLetter + ' CD-ROM Drive') ;

DRIVE_RAMDISK:

Memo1.Lines.Add(DriveLetter + ' RAM Disk') ;

end;

Delphi - .....................................

DevX - Sürücüleri Türleriyle Beraber Listeleme

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

procedure TForm1.Button1Click(Sender: TObject) ;

var

Drive: Char;

DriveLetter: String[4];

begin

for Drive := 'A' to 'Z' do

begin

DriveLetter := Drive + ':';

case GetDriveType(PChar(Drive + ':')) of

DRIVE_REMOVABLE:

Memo1.Lines.Add(DriveLetter + ' Floppy Drive') ;

DRIVE_FIXED:

Memo1.Lines.Add(DriveLetter + ' Fixed Drive') ;

DRIVE_REMOTE:

Memo1.Lines.Add(DriveLetter + ' Network Drive') ;

DRIVE_CDROM:

Memo1.Lines.Add(DriveLetter + ' CD-ROM Drive') ;

DRIVE_RAMDISK:

Memo1.Lines.Add(DriveLetter + ' RAM Disk') ;

end;

Delphi - .....................................

DevX - Mouse ve Klavyeyi Etkisiz Hale Getirme

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

function FuncAvail

(_dllname, _funcname: string; var _p: pointer):

boolean;

var _lib: tHandle;

begin

Result := false;

_p := NIL;

if LoadLibrary(PChar(_dllname)) = 0 then exit;

_lib := GetModuleHandle(PChar(_dllname)) ;

if _lib <> 0 then

begin

_p := GetProcAddress(_lib, PChar(_funcname)) ;

if _p <> NIL then Result := true;

end;

procedure TForm1.Button1Click(Sender: TObject) ;

var

xBlockInput : function(Block: BOOL):

BOOL; stdcall;

begin

if FuncAvail

('USER32.DLL', 'BlockInput', @xBlockInput) then

begin

xBlockInput(true) ;

Sleep(5000) ;

xBlockInput(false) ;

end;

Delphi - .....................................

DevX - Mouse ve Klavyeyi Etkisiz Hale Getirme

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

function FuncAvail

(_dllname, _funcname: string; var _p: pointer):

boolean;

var _lib: tHandle;

begin

Result := false;

_p := NIL;

if LoadLibrary(PChar(_dllname)) = 0 then exit;

_lib := GetModuleHandle(PChar(_dllname)) ;

if _lib <> 0 then

begin

_p := GetProcAddress(_lib, PChar(_funcname)) ;

if _p <> NIL then Result := true;

end;

procedure TForm1.Button1Click(Sender: TObject) ;

var

xBlockInput : function(Block: BOOL):

BOOL; stdcall;

begin

if FuncAvail

('USER32.DLL', 'BlockInput', @xBlockInput) then

begin

xBlockInput(true) ;

Sleep(5000) ;

xBlockInput(false) ;

end;

Delphi - .....................................

DevX - Şu anki Memory,etc

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

var MemoryStatus: TMemoryStatus;

begin

Memo1.Lines.Clear;

MemoryStatus.dwLength := SizeOf(MemoryStatus) ;

GlobalMemoryStatus(MemoryStatus) ;

with MemoryStatus do begin

Memo1.Lines.Add(IntToStr(dwLength) +

' Size of ''MemoryStatus'' record') ;

Memo1.Lines.Add(IntToStr(dwMemoryLoad) +

'% memory in use') ;

Memo1.Lines.Add(IntToStr(dwTotalPhys) +

' Total Physical Memory in bytes') ;

Memo1.Lines.Add(IntToStr(dwAvailPhys) +

' Available Physical Memory in bytes') ;

Memo1.Lines.Add(IntToStr(dwTotalPageFile) +

' Total Bytes of Paging File') ;

Memo1.Lines.Add(IntToStr(dwAvailPageFile) +

' Available bytes in paging file') ;

Memo1.Lines.Add(IntToStr(dwTotalVirtual) +

' User Bytes of Address space') ;

Memo1.Lines.Add(IntToStr(dwAvailVirtual) +

' Available User bytes of address space') ;

end;

Delphi - .....................................

DevX - Şu anki Memory,etc

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

var MemoryStatus: TMemoryStatus;

begin

Memo1.Lines.Clear;

MemoryStatus.dwLength := SizeOf(MemoryStatus) ;

GlobalMemoryStatus(MemoryStatus) ;

with MemoryStatus do begin

Memo1.Lines.Add(IntToStr(dwLength) +

' Size of ''MemoryStatus'' record') ;

Memo1.Lines.Add(IntToStr(dwMemoryLoad) +

'% memory in use') ;

Memo1.Lines.Add(IntToStr(dwTotalPhys) +

' Total Physical Memory in bytes') ;

Memo1.Lines.Add(IntToStr(dwAvailPhys) +

' Available Physical Memory in bytes') ;

Memo1.Lines.Add(IntToStr(dwTotalPageFile) +

' Total Bytes of Paging File') ;

Memo1.Lines.Add(IntToStr(dwAvailPageFile) +

' Available bytes in paging file') ;

Memo1.Lines.Add(IntToStr(dwTotalVirtual) +

' User Bytes of Address space') ;

Memo1.Lines.Add(IntToStr(dwAvailVirtual) +

' Available User bytes of address space') ;

end;

Delphi - .....................................

Gerçek Hesap Makinası

unit Calc1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ExtCtrls, StdCtrls, Buttons,Math, jpeg;

type

MakinaDurum = (Bos, Dolu, Hata);

THBKCalc = class(TForm)

SpeedButton1: TSpeedButton;

SpeedButton2: TSpeedButton;

SpeedButton3: TSpeedButton;

SpeedButton4: TSpeedButton;

SpeedButton5: TSpeedButton;

SpeedButton6: TSpeedButton;

SpeedButton7: TSpeedButton;

SpeedButton8: TSpeedButton;

SpeedButton9: TSpeedButton;

SpeedButton10: TSpeedButton;

SpeedButton11: TSpeedButton;

SpeedButton12: TSpeedButton;

SpeedButton13: TSpeedButton;

SpeedButton14: TSpeedButton;

SpeedButton15: TSpeedButton;

SpeedButton16: TSpeedButton;

SpeedButton17: TSpeedButton;

SpeedButton18: TSpeedButton;

SpeedButton20: TSpeedButton;

SpeedButton21: TSpeedButton;

SpeedButton22: TSpeedButton;

SpeedButton23: TSpeedButton;

SpeedButton24: TSpeedButton;

SpeedButton25: TSpeedButton;

SpeedButton26: TSpeedButton;

SpeedButton27: TSpeedButton;

Label1: TLabel;

Label2: TLabel;

Bevel1: TBevel;

Timer1: TTimer;

SpeedButton28: TSpeedButton;

SpeedButton29: TSpeedButton;

SpeedButton31: TSpeedButton;

SpeedButton19: TSpeedButton;

Label3: TLabel;

Bevel2: TBevel;

procedure Timer1Timer(Sender: TObject);

procedure TusHesapla(Tus: Char);

procedure Temizle;

procedure FormKeyPress(Sender: TObject; var Key: Char);

procedure SpeedButton7Click(Sender: TObject);

procedure SpeedButton17Click(Sender: TObject);

procedure SpeedButton31Click(Sender: TObject);

procedure SpeedButton28Click(Sender: TObject);

procedure SpeedButton29Click(Sender: TObject);

procedure SpeedButton21Click(Sender: TObject);

procedure SpeedButton26Click(Sender: TObject);

procedure SpeedButton22Click(Sender: TObject);

procedure SpeedButton24Click(Sender: TObject);

procedure SpeedButton23Click(Sender: TObject);

private

{ Private declarations }

public

Ch :char;

A :String[20];

Durum : MakinaDurum;

Numara : string[15];

Isaret : Char;

Isleyen : Char;

Islenen : Real;

Hafiza : String[15];

Hafizada: Boolean;

{ Public declarations }

end;

var

HBKCalc: THBKCalc;

function GetMak : LongInt; stdcall;

implementation

{$R *.DFM}

procedure THBKCalc.Timer1Timer(Sender: TObject);

begin

Label1.Caption:=TimeToStr(Now);

end;

procedure THBKCalc.Temizle;

begin

Durum := Bos;

Numara := '0';

Isaret := ' ';

Isleyen := '=';

end;

procedure THBKCalc.TusHesapla(Tus: Char);

var

R: Real;

EE:Integer;

procedure Ariza;

begin

Durum := Hata;

Numara := 'Yemez';

Isaret := ' ';

end;

procedure Goster(R: Real);

var

S: string[63];

begin

s:='';

Str(R: 0: 10, S);

if S[1] <> '-' then Isaret := ' ' else

begin

Delete(S, 1, 1);

Isaret := '-';

end;

if Length(S) > 15 + 1 + 10 then Ariza

else

begin

while S[Length(S)] = '0' do Dec(S[0]);

if S[Length(S)] = '.' then Dec(S[0]);

Numara := S;

end;

procedure Al(var R: Real);

var

E: Integer;

begin

Val(Isaret + Numara, R, E);

end;

procedure TestEt;

begin

if Durum = Bos then

begin

Durum := Dolu;

Numara := '0';

Isaret := ' ';

end;

begin

Tus := UpCase(Tus);

if (Durum = Hata) and (Tus <> 'C') then Tus := ' ';

case Tus of

'0'..'9':

begin

TestEt;

if Numara = '0' then Numara := '';

Numara := Numara + Tus;

end;

'.':

begin

TestEt;

if Pos('.', Numara) = 0 then Numara := Numara + '.';

end;

#8, #27:

begin

TestEt;

if Length(Numara) = 1 then Numara := '0' else Dec(Numara[0]);

end;

'k','K':

begin

if Durum = Dolu then

begin

Al(R);

r:=Cos(r*(pi/180));

Goster(r);

end;

's','S':

begin

if Durum = Dolu then

begin

Al(R);

r:=sin(r*(pi/180));

Goster(r);

end;

'x','X':

begin

if Durum = Dolu then

begin

Al(R);

r:=sqr(r);

Goster(r);

end;

'§':

begin

if Durum = Dolu then

begin

Al(R);

r:=1/r;

Goster(r);

end;

'°':

begin

if Durum = Dolu then

begin

Al(R);

r:=sqrt(r);

Goster(r);

end;

'·':

begin

if Durum = Dolu then

begin

Al(R);

r:=0;

Goster(r);

end;

'_', '±': if Isaret = ' ' then Isaret := '-' else Isaret := ' ';

'+', '-', '*', '/', '=', '%', #13,'¹':

begin

if Durum = Dolu then

begin

Durum := Bos;

Al(R);

if Tus = '¹' then

begin

Val(Hafiza,r,ee);

case Isleyen of

'+': Goster(Islenen + R);

'-': Goster(Islenen - R);

'*': Goster(Islenen * R);

'/': if R = 0 then Ariza else Goster(Islenen / R);

end;

if Tus = '%' then

case Isleyen of

'+', '-': R := Islenen * R / 100;

'*', '/': R := R / 100;

end;

case Isleyen of

'+': Goster(Islenen + R);

'-': Goster(Islenen - R);

'*': Goster(Islenen * R);

'/': if R = 0 then Ariza else Goster(Islenen / R);

end;

Isleyen := Tus;

Al(Islenen);

end;

'C':

Temizle;

end;

Label2.Caption:=Isaret+Numara;

end;

procedure THBKCalc.FormKeyPress(Sender: TObject; var Key: Char);

begin

If Key = ',' then

Key:='.'

TusHesapla(Key);

end;

procedure THBKCalc.SpeedButton7Click(Sender: TObject);

begin

TusHesapla( (Sender as TSpeedButton).Caption[1]);

end;

procedure THBKCalc.SpeedButton17Click(Sender: TObject);

begin

TusHesapla('§');

end;

procedure THBKCalc.SpeedButton31Click(Sender: TObject);

begin

TusHesapla('K');

end;

procedure THBKCalc.SpeedButton28Click(Sender: TObject);

begin

TusHesapla('X');

end;

procedure THBKCalc.SpeedButton29Click(Sender: TObject);

begin

TusHesapla('°');

end;

procedure THBKCalc.SpeedButton21Click(Sender: TObject);

begin

TusHesapla(#8);

end;

procedure THBKCalc.SpeedButton26Click(Sender: TObject);

begin

TusHesapla('·');

end;

procedure THBKCalc.SpeedButton22Click(Sender: TObject);

begin

Hafiza:=Isaret+Numara;

If Hafiza <> '' Then Hafizada:=True else

Hafizada := False;

Label3.Visible:=Hafizada;

end;

procedure THBKCalc.SpeedButton24Click(Sender: TObject);

begin

Hafiza:='';

Hafizada:=False;

Label3.Visible:=Hafizada;

end;

procedure THBKCalc.SpeedButton23Click(Sender: TObject);

begin

If Hafizada Then

Begin

Durum:=Dolu;

TusHesapla('¹');

end;

function GetMak: LongInt;

begin

// default value

Result := 100;

try

HBKCalc := THBKCalc.Create (Application);

try

with HBKCalc do

begin

if ShowModal = mrCancel then

Result := 0;

end; // with

finally

HBKCalc.Free;

end;

except

on E: Exception do

MessageDlg ('Error in FormDLL: ' +

E.Message, mtError, [mbOK], 0);

end; // default value

end;

end.

Delphi - .....................................

Gerçek Hesap Makinası

unit Calc1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ExtCtrls, StdCtrls, Buttons,Math, jpeg;

type

MakinaDurum = (Bos, Dolu, Hata);

THBKCalc = class(TForm)

SpeedButton1: TSpeedButton;

SpeedButton2: TSpeedButton;

SpeedButton3: TSpeedButton;

SpeedButton4: TSpeedButton;

SpeedButton5: TSpeedButton;

SpeedButton6: TSpeedButton;

SpeedButton7: TSpeedButton;

SpeedButton8: TSpeedButton;

SpeedButton9: TSpeedButton;

SpeedButton10: TSpeedButton;

SpeedButton11: TSpeedButton;

SpeedButton12: TSpeedButton;

SpeedButton13: TSpeedButton;

SpeedButton14: TSpeedButton;

SpeedButton15: TSpeedButton;

SpeedButton16: TSpeedButton;

SpeedButton17: TSpeedButton;

SpeedButton18: TSpeedButton;

SpeedButton20: TSpeedButton;

SpeedButton21: TSpeedButton;

SpeedButton22: TSpeedButton;

SpeedButton23: TSpeedButton;

SpeedButton24: TSpeedButton;

SpeedButton25: TSpeedButton;

SpeedButton26: TSpeedButton;

SpeedButton27: TSpeedButton;

Label1: TLabel;

Label2: TLabel;

Bevel1: TBevel;

Timer1: TTimer;

SpeedButton28: TSpeedButton;

SpeedButton29: TSpeedButton;

SpeedButton31: TSpeedButton;

SpeedButton19: TSpeedButton;

Label3: TLabel;

Bevel2: TBevel;

procedure Timer1Timer(Sender: TObject);

procedure TusHesapla(Tus: Char);

procedure Temizle;

procedure FormKeyPress(Sender: TObject; var Key: Char);

procedure SpeedButton7Click(Sender: TObject);

procedure SpeedButton17Click(Sender: TObject);

procedure SpeedButton31Click(Sender: TObject);

procedure SpeedButton28Click(Sender: TObject);

procedure SpeedButton29Click(Sender: TObject);

procedure SpeedButton21Click(Sender: TObject);

procedure SpeedButton26Click(Sender: TObject);

procedure SpeedButton22Click(Sender: TObject);

procedure SpeedButton24Click(Sender: TObject);

procedure SpeedButton23Click(Sender: TObject);

private

{ Private declarations }

public

Ch :char;

A :String[20];

Durum : MakinaDurum;

Numara : string[15];

Isaret : Char;

Isleyen : Char;

Islenen : Real;

Hafiza : String[15];

Hafizada: Boolean;

{ Public declarations }

end;

var

HBKCalc: THBKCalc;

function GetMak : LongInt; stdcall;

implementation

{$R *.DFM}

procedure THBKCalc.Timer1Timer(Sender: TObject);

begin

Label1.Caption:=TimeToStr(Now);

end;

procedure THBKCalc.Temizle;

begin

Durum := Bos;

Numara := '0';

Isaret := ' ';

Isleyen := '=';

end;

procedure THBKCalc.TusHesapla(Tus: Char);

var

R: Real;

EE:Integer;

procedure Ariza;

begin

Durum := Hata;

Numara := 'Yemez';

Isaret := ' ';

end;

procedure Goster(R: Real);

var

S: string[63];

begin

s:='';

Str(R: 0: 10, S);

if S[1] <> '-' then Isaret := ' ' else

begin

Delete(S, 1, 1);

Isaret := '-';

end;

if Length(S) > 15 + 1 + 10 then Ariza

else

begin

while S[Length(S)] = '0' do Dec(S[0]);

if S[Length(S)] = '.' then Dec(S[0]);

Numara := S;

end;

procedure Al(var R: Real);

var

E: Integer;

begin

Val(Isaret + Numara, R, E);

end;

procedure TestEt;

begin

if Durum = Bos then

begin

Durum := Dolu;

Numara := '0';

Isaret := ' ';

end;

begin

Tus := UpCase(Tus);

if (Durum = Hata) and (Tus <> 'C') then Tus := ' ';

case Tus of

'0'..'9':

begin

TestEt;

if Numara = '0' then Numara := '';

Numara := Numara + Tus;

end;

'.':

begin

TestEt;

if Pos('.', Numara) = 0 then Numara := Numara + '.';

end;

#8, #27:

begin

TestEt;

if Length(Numara) = 1 then Numara := '0' else Dec(Numara[0]);

end;

'k','K':

begin

if Durum = Dolu then

begin

Al(R);

r:=Cos(r*(pi/180));

Goster(r);

end;

's','S':

begin

if Durum = Dolu then

begin

Al(R);

r:=sin(r*(pi/180));

Goster(r);

end;

'x','X':

begin

if Durum = Dolu then

begin

Al(R);

r:=sqr(r);

Goster(r);

end;

'§':

begin

if Durum = Dolu then

begin

Al(R);

r:=1/r;

Goster(r);

end;

'°':

begin

if Durum = Dolu then

begin

Al(R);

r:=sqrt(r);

Goster(r);

end;

'·':

begin

if Durum = Dolu then

begin

Al(R);

r:=0;

Goster(r);

end;

'_', '±': if Isaret = ' ' then Isaret := '-' else Isaret := ' ';

'+', '-', '*', '/', '=', '%', #13,'¹':

begin

if Durum = Dolu then

begin

Durum := Bos;

Al(R);

if Tus = '¹' then

begin

Val(Hafiza,r,ee);

case Isleyen of

'+': Goster(Islenen + R);

'-': Goster(Islenen - R);

'*': Goster(Islenen * R);

'/': if R = 0 then Ariza else Goster(Islenen / R);

end;

if Tus = '%' then

case Isleyen of

'+', '-': R := Islenen * R / 100;

'*', '/': R := R / 100;

end;

case Isleyen of

'+': Goster(Islenen + R);

'-': Goster(Islenen - R);

'*': Goster(Islenen * R);

'/': if R = 0 then Ariza else Goster(Islenen / R);

end;

Isleyen := Tus;

Al(Islenen);

end;

'C':

Temizle;

end;

Label2.Caption:=Isaret+Numara;

end;

procedure THBKCalc.FormKeyPress(Sender: TObject; var Key: Char);

begin

If Key = ',' then

Key:='.'

TusHesapla(Key);

end;

procedure THBKCalc.SpeedButton7Click(Sender: TObject);

begin

TusHesapla( (Sender as TSpeedButton).Caption[1]);

end;

procedure THBKCalc.SpeedButton17Click(Sender: TObject);

begin

TusHesapla('§');

end;

procedure THBKCalc.SpeedButton31Click(Sender: TObject);

begin

TusHesapla('K');

end;

procedure THBKCalc.SpeedButton28Click(Sender: TObject);

begin

TusHesapla('X');

end;

procedure THBKCalc.SpeedButton29Click(Sender: TObject);

begin

TusHesapla('°');

end;

procedure THBKCalc.SpeedButton21Click(Sender: TObject);

begin

TusHesapla(#8);

end;

procedure THBKCalc.SpeedButton26Click(Sender: TObject);

begin

TusHesapla('·');

end;

procedure THBKCalc.SpeedButton22Click(Sender: TObject);

begin

Hafiza:=Isaret+Numara;

If Hafiza <> '' Then Hafizada:=True else

Hafizada := False;

Label3.Visible:=Hafizada;

end;

procedure THBKCalc.SpeedButton24Click(Sender: TObject);

begin

Hafiza:='';

Hafizada:=False;

Label3.Visible:=Hafizada;

end;

procedure THBKCalc.SpeedButton23Click(Sender: TObject);

begin

If Hafizada Then

Begin

Durum:=Dolu;

TusHesapla('¹');

end;

function GetMak: LongInt;

begin

// default value

Result := 100;

try

HBKCalc := THBKCalc.Create (Application);

try

with HBKCalc do

begin

if ShowModal = mrCancel then

Result := 0;

end; // with

finally

HBKCalc.Free;

end;

except

on E: Exception do

MessageDlg ('Error in FormDLL: ' +

E.Message, mtError, [mbOK], 0);

end; // default value

end;

end.

Delphi - .....................................

DevX - Ekran Koruyucu Çalıştırmak/Çalıştırmamak

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

function ActivateScreenSaver

(Activate: boolean): boolean;

var IntActive: byte;

begin

if Activate then

IntActive := 1

else

IntActive := 0;

Result := SystemParametersInfo

(SPI_SETSCREENSAVEACTIVE, IntActive,

nil, 0) ;

end;

Delphi - .....................................

DevX - Ekran Koruyucu Çalıştırmak/Çalıştırmamak

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

function ActivateScreenSaver

(Activate: boolean): boolean;

var IntActive: byte;

begin

if Activate then

IntActive := 1

else

IntActive := 0;

Result := SystemParametersInfo

(SPI_SETSCREENSAVEACTIVE, IntActive,

nil, 0) ;

end;

Delphi - .....................................

DevX - Memo içerisinden Dos'u gösterme

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

procedure RunDosInMemo(DosApp:String;AMemo:TMemo) ;

const

ReadBuffer = 2400;

var

Security : TSecurityAttributes;

ReadPipe,WritePipe : THandle;

start : TStartUpInfo;

ProcessInfo : TProcessInformation;

Buffer : Pchar;

BytesRead : DWord;

Apprunning : DWord;

begin

With Security do begin

nlength := SizeOf(TSecurityAttributes) ;

binherithandle := true;

lpsecuritydescriptor := nil;

end;

if Createpipe (ReadPipe, WritePipe,

@Security, 0) then begin

Buffer := AllocMem(ReadBuffer + 1) ;

FillChar(Start,Sizeof(Start),#0) ;

start.cb := SizeOf(start) ;

start.hStdOutput := WritePipe;

start.hStdInput := ReadPipe;

start.dwFlags := STARTF_USESTDHANDLES +

STARTF_USESHOWWINDOW;

start.wShowWindow := SW_HIDE;

if CreateProcess(nil,

PChar(DosApp),

@Security,

true,

NORMAL_PRIORITY_CLASS,

nil,

start,

ProcessInfo)

then

begin

repeat

Apprunning := WaitForSingleObject

(ProcessInfo.hProcess,100) ;

Application.ProcessMessages;

until (Apprunning <> WAIT_TIMEOUT) ;

Repeat

BytesRead := 0;

ReadFile(ReadPipe,Buffer[0],

ReadBuffer,BytesRead,nil) ;

Buffer[BytesRead]:= #0;

OemToAnsi(Buffer,Buffer) ;

AMemo.Text := AMemo.text + String(Buffer) ;

until (BytesRead < ReadBuffer) ;

end;

FreeMem(Buffer) ;

CloseHandle(ProcessInfo.hProcess) ;

CloseHandle(ProcessInfo.hThread) ;

CloseHandle(ReadPipe) ;

CloseHandle(WritePipe) ;

end;

begin {button 1 code}

RunDosInMemo('chkdsk.exe c:',Memo1) ;

end;

Delphi - .....................................

DevX - Memo içerisinden Dos'u gösterme

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

procedure RunDosInMemo(DosApp:String;AMemo:TMemo) ;

const

ReadBuffer = 2400;

var

Security : TSecurityAttributes;

ReadPipe,WritePipe : THandle;

start : TStartUpInfo;

ProcessInfo : TProcessInformation;

Buffer : Pchar;

BytesRead : DWord;

Apprunning : DWord;

begin

With Security do begin

nlength := SizeOf(TSecurityAttributes) ;

binherithandle := true;

lpsecuritydescriptor := nil;

end;

if Createpipe (ReadPipe, WritePipe,

@Security, 0) then begin

Buffer := AllocMem(ReadBuffer + 1) ;

FillChar(Start,Sizeof(Start),#0) ;

start.cb := SizeOf(start) ;

start.hStdOutput := WritePipe;

start.hStdInput := ReadPipe;

start.dwFlags := STARTF_USESTDHANDLES +

STARTF_USESHOWWINDOW;

start.wShowWindow := SW_HIDE;

if CreateProcess(nil,

PChar(DosApp),

@Security,

true,

NORMAL_PRIORITY_CLASS,

nil,

start,

ProcessInfo)

then

begin

repeat

Apprunning := WaitForSingleObject

(ProcessInfo.hProcess,100) ;

Application.ProcessMessages;

until (Apprunning <> WAIT_TIMEOUT) ;

Repeat

BytesRead := 0;

ReadFile(ReadPipe,Buffer[0],

ReadBuffer,BytesRead,nil) ;

Buffer[BytesRead]:= #0;

OemToAnsi(Buffer,Buffer) ;

AMemo.Text := AMemo.text + String(Buffer) ;

until (BytesRead < ReadBuffer) ;

end;

FreeMem(Buffer) ;

CloseHandle(ProcessInfo.hProcess) ;

CloseHandle(ProcessInfo.hThread) ;

CloseHandle(ReadPipe) ;

CloseHandle(WritePipe) ;

end;

begin {button 1 code}

RunDosInMemo('chkdsk.exe c:',Memo1) ;

end;

Delphi - .....................................

DevX - Başlat Butonunun Resmini değiştirme

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

{We'll need several global variables}

var

Form1: TForm1;

StartButton : hWnd;

OldBitmap : THandle;

NewImage : TPicture;

...

{Now, we put this code in the

OnCreate event of the form:}

procedure TForm1.FormCreate(Sender: TObject) ;

begin

NewImage:=TPicture.create;

NewImage.LoadFromFile('C:WindowsCircles.BMP') ;

StartButton := FindWindowEx

(FindWindow(

'Shell_TrayWnd', nil),

0,'Button', nil) ;

OldBitmap:=SendMessage(StartButton,

BM_SetImage, 0,

NewImage.Bitmap.Handle) ;

end;

...

{And this other in the OnDestroy:}

procedure TForm1.FormDestroy(Sender: TObject) ;

begin

SendMessage(StartButton,BM_SetImage,0,OldBitmap) ;

NewImage.Free;

end;

Delphi - .....................................

DevX - Başlat Butonunun Resmini değiştirme

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

{We'll need several global variables}

var

Form1: TForm1;

StartButton : hWnd;

OldBitmap : THandle;

NewImage : TPicture;

...

{Now, we put this code in the

OnCreate event of the form:}

procedure TForm1.FormCreate(Sender: TObject) ;

begin

NewImage:=TPicture.create;

NewImage.LoadFromFile('C:WindowsCircles.BMP') ;

StartButton := FindWindowEx

(FindWindow(

'Shell_TrayWnd', nil),

0,'Button', nil) ;

OldBitmap:=SendMessage(StartButton,

BM_SetImage, 0,

NewImage.Bitmap.Handle) ;

end;

...

{And this other in the OnDestroy:}

procedure TForm1.FormDestroy(Sender: TObject) ;

begin

SendMessage(StartButton,BM_SetImage,0,OldBitmap) ;

NewImage.Free;

end;

Delphi - .....................................

DevX - Çalışmakda olan programı kapatma

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

//Programın İsmine Göre değil Form Captiona göre uyarlı

function KillApp(const sCapt: PChar) : boolean;

var AppHandle:THandle;

begin

AppHandle:=FindWindow(Nil, sCapt) ;

Result:=PostMessage(AppHandle, WM_QUIT, 0, 0) ;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

if not KillApp('Giriş') then ShowMessage('App not closed') ;

end;

Delphi - .....................................

DevX - Çalışmakda olan programı kapatma

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

//Programın İsmine Göre değil Form Captiona göre uyarlı

function KillApp(const sCapt: PChar) : boolean;

var AppHandle:THandle;

begin

AppHandle:=FindWindow(Nil, sCapt) ;

Result:=PostMessage(AppHandle, WM_QUIT, 0, 0) ;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

if not KillApp('Giriş') then ShowMessage('App not closed') ;

end;

Delphi - .....................................

DevX- Ses Ayarını Kontrol Etme

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

uses MMSystem;

type

TVolumeRec = record

case Integer of

0: (LongVolume: Longint) ;

1: (LeftVolume, RightVolume : Word) ;

end;

const DeviceIndex=5

{0:Wave

1:MIDI

2:CDAudio

3:Line-In

4:Microphone

5:Master

6:PC-loudspeaker}

procedure SetVolume(aVolume:Byte) ;

var Vol: TVolumeRec;

begin

Vol.LeftVolume := aVolume shl 8;

Vol.RightVolume:= Vol.LeftVolume;

auxSetVolume(UINT(DeviceIndex), Vol.LongVolume) ;

end;

function GetVolume:Cardinal;

var Vol: TVolumeRec;

begin

AuxGetVolume(UINT(DeviceIndex),@Vol.LongVolume) ;

Result:=(Vol.LeftVolume + Vol.RightVolume) shr 9;

end;

Delphi - .....................................

DevX- Ses Ayarını Kontrol Etme

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

uses MMSystem;

type

TVolumeRec = record

case Integer of

0: (LongVolume: Longint) ;

1: (LeftVolume, RightVolume : Word) ;

end;

const DeviceIndex=5

{0:Wave

1:MIDI

2:CDAudio

3:Line-In

4:Microphone

5:Master

6:PC-loudspeaker}

procedure SetVolume(aVolume:Byte) ;

var Vol: TVolumeRec;

begin

Vol.LeftVolume := aVolume shl 8;

Vol.RightVolume:= Vol.LeftVolume;

auxSetVolume(UINT(DeviceIndex), Vol.LongVolume) ;

end;

function GetVolume:Cardinal;

var Vol: TVolumeRec;

begin

AuxGetVolume(UINT(DeviceIndex),@Vol.LongVolume) ;

Result:=(Vol.LeftVolume + Vol.RightVolume) shr 9;

end;

Delphi - .....................................

DevX - Windows Kopyalama-Silme-Taşıma Dialoglarını kullanma

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

uses ShellAPI;

procedure TForm1.Button1Click(Sender: TObject) ;

var

Fos : TSHFileOpStruct;

Buf : array[0..4096] of char;

p : pchar;

sDest : string;

begin

FillChar(Buf, sizeof(Buf), #0) ;

p := @buf;

p := StrECopy(p, 'C:FirstFile.ext1') + 1;

p := StrECopy(p, 'C:SecondFile.ext2') + 1;

StrECopy(p, 'C:ThirdFile.ext3') ;

sDest := 'e:';

FillChar(Fos, sizeof(Fos), #0) ;

with Fos do begin

Wnd := Handle;

wFunc := FO_COPY;

pFrom := @Buf;

pTo := sDest;

fFlags := 0;

end;

if ((SHFileOperation(Fos) <> 0) or

(Fos.fAnyOperationsAborted <> false)) then

ShowMessage('Cancelled')

end;

Delphi - .....................................

DevX - Windows Kopyalama-Silme-Taşıma Dialoglarını kullanma

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

uses ShellAPI;

procedure TForm1.Button1Click(Sender: TObject) ;

var

Fos : TSHFileOpStruct;

Buf : array[0..4096] of char;

p : pchar;

sDest : string;

begin

FillChar(Buf, sizeof(Buf), #0) ;

p := @buf;

p := StrECopy(p, 'C:FirstFile.ext1') + 1;

p := StrECopy(p, 'C:SecondFile.ext2') + 1;

StrECopy(p, 'C:ThirdFile.ext3') ;

sDest := 'e:';

FillChar(Fos, sizeof(Fos), #0) ;

with Fos do begin

Wnd := Handle;

wFunc := FO_COPY;

pFrom := @Buf;

pTo := sDest;

fFlags := 0;

end;

if ((SHFileOperation(Fos) <> 0) or

(Fos.fAnyOperationsAborted <> false)) then

ShowMessage('Cancelled')

end;

Delphi - .....................................

DevX - Form Başlık Çubugunun Etkili/etkisiz haldeki dönüşümü

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

//belki anlatamadım kusurumuma bakmayın

procedure TForm1.Timer1Timer(Sender: TObject);

begin

FlashWindow (Handle, True) ;

end;

Delphi - .....................................

DevX - Form Başlık Çubugunun Etkili/etkisiz haldeki dönüşümü

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

//belki anlatamadım kusurumuma bakmayın

procedure TForm1.Timer1Timer(Sender: TObject);

begin

FlashWindow (Handle, True) ;

end;

Delphi - .....................................

DevX - Yazı Tipini Yükleme

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

procedure TForm1.FormCreate(Sender: TObject) ;

begin

AddFontResource('c:FONTSMyFont.TTF') ;

SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0) ;

end;

{Before application terminates we must free it:}

procedure TForm1.FormClose

(Sender: TObject; var Action: TCloseAction) ;

begin

RemoveFontResource('C:FONTSMyFont.TTF') ;

SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0) ;

end;

Delphi - .....................................

DevX - Yazı Tipini Yükleme

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

procedure TForm1.FormCreate(Sender: TObject) ;

begin

AddFontResource('c:FONTSMyFont.TTF') ;

SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0) ;

end;

{Before application terminates we must free it:}

procedure TForm1.FormClose

(Sender: TObject; var Action: TCloseAction) ;

begin

RemoveFontResource('C:FONTSMyFont.TTF') ;

SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0) ;

end;

Delphi - .....................................

DevX - Windows Uygulamalarını Farklı bir şekilde taşıma

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

SystemParametersInfo(SPI_SETDRAGFULLWINDOWS, 1, nil, 0) ;

//To disable this option call the function:

SystemParametersInfo(SPI_SETDRAGFULLWINDOWS, 0, nil, 0) ;

Delphi - .....................................

DevX - Windows Uygulamalarını Farklı bir şekilde taşıma

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

SystemParametersInfo(SPI_SETDRAGFULLWINDOWS, 1, nil, 0) ;

//To disable this option call the function:

SystemParametersInfo(SPI_SETDRAGFULLWINDOWS, 0, nil, 0) ;

Delphi - .....................................

DevX - Açıkdaki Başka Bir Uygulamaya karakter gönderme

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

procedure TForm1.Button2Click(Sender: TObject);

var g,d:integer;

begin

{Find the main window of the Application}

g:=FindWindow('Notepad',nil) ;

{Find the window of the application's text box}

d:=ChildWindowFromPoint(g,point(50,50)) ;

{Now send it a character!!}

SendMessage(d,WM_CHAR,Ord('A'),0) ;

end;

Delphi - .....................................

DevX - Açıkdaki Başka Bir Uygulamaya karakter gönderme

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

procedure TForm1.Button2Click(Sender: TObject);

var g,d:integer;

begin

{Find the main window of the Application}

g:=FindWindow('Notepad',nil) ;

{Find the window of the application's text box}

d:=ChildWindowFromPoint(g,point(50,50)) ;

{Now send it a character!!}

SendMessage(d,WM_CHAR,Ord('A'),0) ;

end;

Delphi - .....................................

DevX - LPT,Com,Port... Listeleme

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

procedure TForm1.Button1Click(Sender: TObject) ;

var

istr: string;

isize, j: dword;

begin

setlength(istr, 4000) ;

isize := QueryDosDevice(nil, @istr[1], 4000) ;

for j := 1 to isize do

if istr[j] = #0 then istr[j] := #10;

memo1.lines.CommaText := istr;

end;

Delphi - .....................................

DevX - LPT,Com,Port... Listeleme

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

procedure TForm1.Button1Click(Sender: TObject) ;

var

istr: string;

isize, j: dword;

begin

setlength(istr, 4000) ;

isize := QueryDosDevice(nil, @istr[1], 4000) ;

for j := 1 to isize do

if istr[j] = #0 then istr[j] := #10;

memo1.lines.CommaText := istr;

end;

Delphi - .....................................

rs232 komponent kullanmadan

unit com;

interface

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, StdCtrls, CPDrv, Math, ExtCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

procedure Button1Click(Sender: TObject);

procedure open_rs232;

function receive_data(d_ptr: pointer; len : DWORD): DWORD;

procedure receive_string(var s:string);

function receive_byte : byte;

function receive_char : char;

procedure send_data(d_ptr: Pointer; len : DWORD);

procedure send_string(s: String);

procedure send_byte(b : byte);

procedure send_char(ch : char);

procedure send_LFCR;

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

fhandle : HFILE;

implementation

uses Unit2, Unit3;

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);

begin

open_rs232;

end;

procedure TForm1.open_rs232;

var

dcb : TDCB;

tms: TCOMMTIMEOUTS;

begin

fhandle := CreateFile(PChar('COM1'),

GENERIC_READ or GENERIC_WRITE,

nil,

OPEN_EXISTING,

FILE_ATTRIBUTE_NORMAL,

0);

if(fhandle = INVALID_HANDLE_VALUE) then

begin

ShowMessage('Com portu açılamadı');

exit;

end;

GetCommState(fhandle, dcb);

dcb.DCBlength := sizeof(dcb);

dcb.BaudRate := CBR_9600;

dcb.Flags := $00000001; // binary...

dcb.ByteSize := 8; // 8 bit...

dcb.Parity := 0; // parity none...

dcb.StopBits := 0; // 1 stop bit...

SetCommState(fhandle,dcb);

tms.ReadIntervalTimeout := 10;

tms.ReadTotalTimeoutMultiplier := 0;

tms.ReadTotalTimeoutConstant := 1;

tms.WriteTotalTimeoutMultiplier := 0;

tms.WriteTotalTimeoutConstant := 10;

SetCommTimeOuts(fhandle, tms);

end;

function TForm1.receive_data(d_ptr: pointer; len : DWORD): DWORD;

var

nToRead, nRead: DWORD;

ptr : pchar;

begin

nToRead := len;

ptr := d_ptr;

ReadFile(fhandle, ptr^, nToRead, nRead, nil);

Result := nRead;

end;

procedure TForm1.receive_string(var s:string);

var

len :DWORD;

begin

// SetLength(s,100);

len := receive_data(@s[1],length(s));

SetLength(s,len-1);

end;

function TForm1.receive_byte;

var

b :byte;

begin

receive_data(@b,1);

Result := b;

end;

function TForm1.receive_char;

var

ch : char;

begin

receive_data(@ch,1);

Result := ch;

end;

procedure TForm1.send_data(d_ptr: pointer; len : DWORD);

var

nToWrite, nWrite : DWORD;

ptr : pchar;

begin

nToWrite := len;

ptr := d_ptr;

WriteFile(fhandle, ptr^, nToWrite, nWrite,nil);

end;

procedure TForm1.send_string(s: string);

begin

send_data(pchar(s),length(s));

end;

procedure TForm1.send_byte(b : byte);

begin

send_data(@b,1);

end;

procedure TForm1.send_char(ch: char);

begin

send_data(@ch,1);

end;

procedure TForm1.send_LFCR;

var

d :byte;

begin

d := 10;

send_data(@d,1);

d := 13;

send_data(@d,1);

end;

end.

Delphi - .....................................

rs232 komponent kullanmadan

unit com;

interface

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, StdCtrls, CPDrv, Math, ExtCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

procedure Button1Click(Sender: TObject);

procedure open_rs232;

function receive_data(d_ptr: pointer; len : DWORD): DWORD;

procedure receive_string(var s:string);

function receive_byte : byte;

function receive_char : char;

procedure send_data(d_ptr: Pointer; len : DWORD);

procedure send_string(s: String);

procedure send_byte(b : byte);

procedure send_char(ch : char);

procedure send_LFCR;

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

fhandle : HFILE;

implementation

uses Unit2, Unit3;

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);

begin

open_rs232;

end;

procedure TForm1.open_rs232;

var

dcb : TDCB;

tms: TCOMMTIMEOUTS;

begin

fhandle := CreateFile(PChar('COM1'),

GENERIC_READ or GENERIC_WRITE,

nil,

OPEN_EXISTING,

FILE_ATTRIBUTE_NORMAL,

0);

if(fhandle = INVALID_HANDLE_VALUE) then

begin

ShowMessage('Com portu açılamadı');

exit;

end;

GetCommState(fhandle, dcb);

dcb.DCBlength := sizeof(dcb);

dcb.BaudRate := CBR_9600;

dcb.Flags := $00000001; // binary...

dcb.ByteSize := 8; // 8 bit...

dcb.Parity := 0; // parity none...

dcb.StopBits := 0; // 1 stop bit...

SetCommState(fhandle,dcb);

tms.ReadIntervalTimeout := 10;

tms.ReadTotalTimeoutMultiplier := 0;

tms.ReadTotalTimeoutConstant := 1;

tms.WriteTotalTimeoutMultiplier := 0;

tms.WriteTotalTimeoutConstant := 10;

SetCommTimeOuts(fhandle, tms);

end;

function TForm1.receive_data(d_ptr: pointer; len : DWORD): DWORD;

var

nToRead, nRead: DWORD;

ptr : pchar;

begin

nToRead := len;

ptr := d_ptr;

ReadFile(fhandle, ptr^, nToRead, nRead, nil);

Result := nRead;

end;

procedure TForm1.receive_string(var s:string);

var

len :DWORD;

begin

// SetLength(s,100);

len := receive_data(@s[1],length(s));

SetLength(s,len-1);

end;

function TForm1.receive_byte;

var

b :byte;

begin

receive_data(@b,1);

Result := b;

end;

function TForm1.receive_char;

var

ch : char;

begin

receive_data(@ch,1);

Result := ch;

end;

procedure TForm1.send_data(d_ptr: pointer; len : DWORD);

var

nToWrite, nWrite : DWORD;

ptr : pchar;

begin

nToWrite := len;

ptr := d_ptr;

WriteFile(fhandle, ptr^, nToWrite, nWrite,nil);

end;

procedure TForm1.send_string(s: string);

begin

send_data(pchar(s),length(s));

end;

procedure TForm1.send_byte(b : byte);

begin

send_data(@b,1);

end;

procedure TForm1.send_char(ch: char);

begin

send_data(@ch,1);

end;

procedure TForm1.send_LFCR;

var

d :byte;

begin

d := 10;

send_data(@d,1);

d := 13;

send_data(@d,1);

end;

end.

Delphi - .....................................

Terminalden girilen veri aninda gorunmuyorsa!?

//bir arkadas bugun sordu da aslinda basit olmasina karsin

//muhim bisii. o yuzden buraya da yazayim dedim...

//BDE kullanarak yaptiginiz multi-terminal programlarda

//database in transisolation seviyesini dirtyread e ayarlayin.

//ozellikle paradox ve dbase kullananlar... o zaman A terminalinden

//girilen veri B terminalinde aninda gorunmuyor veya B den girilen

//A dan gorunmuyor gibi problemleriniz bitecektir.

DB_Modul.Database.TransIsolation:=tiDirtyRead;

//tabii yine de biraz paraya kiyip sql server/oracle gibi daha

//makul cozumler bulmak ta mumkun...

//kolay gele...

//Ersin Kecis.

//ersinkecis@hotmail.com

Delphi - .....................................

Terminalden girilen veri aninda gorunmuyorsa!?

//bir arkadas bugun sordu da aslinda basit olmasina karsin

//muhim bisii. o yuzden buraya da yazayim dedim...

//BDE kullanarak yaptiginiz multi-terminal programlarda

//database in transisolation seviyesini dirtyread e ayarlayin.

//ozellikle paradox ve dbase kullananlar... o zaman A terminalinden

//girilen veri B terminalinde aninda gorunmuyor veya B den girilen

//A dan gorunmuyor gibi problemleriniz bitecektir.

DB_Modul.Database.TransIsolation:=tiDirtyRead;

//tabii yine de biraz paraya kiyip sql server/oracle gibi daha

//makul cozumler bulmak ta mumkun...

//kolay gele...

//Ersin Kecis.

//ersinkecis@hotmail.com

Delphi - .....................................

Internet BROWSER calistirma

//bu kodla sadece internet explorer degil default browser

//olarak ne ayarliysa o browser' i calistirabilirsiniz...

uses Registry,ShellAPI;

function BrowseURL(const URL:string):boolean;

var Browser:string;

begin

Result:=True;

Browser:='';

with TRegistry.Create do

try

RootKey:=HKEY_CLASSES_ROOT;

Access:=KEY_QUERY_VALUE;

if OpenKey('htmlfileshellopencommand',False)then

Browser:=ReadString('');

CloseKey;

finally

Free;

end;

if Browser=''then begin Result:=False;Exit;end;

Browser:=Copy(Browser,Pos('"', Browser)+1,Length(Browser));

Browser:=Copy(Browser,1,Pos('"', Browser)-1) ;

ShellExecute(0,'open',PChar(Browser),PChar(URL),nil,SW_SHOW);

end;

//kullanimi:

BrowseURL('.....................................');

Delphi - .....................................

Internet BROWSER calistirma

//bu kodla sadece internet explorer degil default browser

//olarak ne ayarliysa o browser' i calistirabilirsiniz...

uses Registry,ShellAPI;

function BrowseURL(const URL:string):boolean;

var Browser:string;

begin

Result:=True;

Browser:='';

with TRegistry.Create do

try

RootKey:=HKEY_CLASSES_ROOT;

Access:=KEY_QUERY_VALUE;

if OpenKey('htmlfileshellopencommand',False)then

Browser:=ReadString('');

CloseKey;

finally

Free;

end;

if Browser=''then begin Result:=False;Exit;end;

Browser:=Copy(Browser,Pos('"', Browser)+1,Length(Browser));

Browser:=Copy(Browser,1,Pos('"', Browser)-1) ;

ShellExecute(0,'open',PChar(Browser),PChar(URL),nil,SW_SHOW);

end;

//kullanimi:

BrowseURL('.....................................');

Delphi - .....................................

QuantumGrid'den Otomotik Export

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

uses cxExportGrid4Link

procedure Tform1.Excel1Click(Sender: TObject);

begin

savedialog1.DefaultExt:='XLS';

If savedialog1.Execute Then

begin

try

ExportGrid4ToExcel(savedialog1.FileName,cxgrid1,true,true,true);

except

ShowMessage('Hata!Dosya oluşturulamadı.');

exit;

end;

procedure Tform1.Metin1Click(Sender: TObject);

begin

savedialog1.DefaultExt:='TXT';

If savedialog1.Execute Then

begin

try

ExportGrid4ToText(savedialog1.FileName,cxgrid1,true,true,';','','','txt');

except

ShowMessage('Hata!Dosya oluşturulamadı.');

exit;

end;

procedure Tform1.Html1Click(Sender: TObject);

begin

savedialog1.DefaultExt:='htm';

If savedialog1.Execute Then

begin

try

ExportGrid4ToHTML(savedialog1.FileName,cxgrid1,true,true,'htm');

except

ShowMessage('Hata!Dosya oluşturulamadı.');

exit;

end;

procedure Tform1.XML1Click(Sender: TObject);

begin

savedialog1.DefaultExt:='xml';

If savedialog1.Execute Then

begin

try

ExportGrid4ToXML(savedialog1.FileName,cxgrid1,true,true);

except

ShowMessage('Hata!Dosya oluşturulamadı.');

exit;

end;

Delphi - .....................................

QuantumGrid'den Otomotik Export

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

uses cxExportGrid4Link

procedure Tform1.Excel1Click(Sender: TObject);

begin

savedialog1.DefaultExt:='XLS';

If savedialog1.Execute Then

begin

try

ExportGrid4ToExcel(savedialog1.FileName,cxgrid1,true,true,true);

except

ShowMessage('Hata!Dosya oluşturulamadı.');

exit;

end;

procedure Tform1.Metin1Click(Sender: TObject);

begin

savedialog1.DefaultExt:='TXT';

If savedialog1.Execute Then

begin

try

ExportGrid4ToText(savedialog1.FileName,cxgrid1,true,true,';','','','txt');

except

ShowMessage('Hata!Dosya oluşturulamadı.');

exit;

end;

procedure Tform1.Html1Click(Sender: TObject);

begin

savedialog1.DefaultExt:='htm';

If savedialog1.Execute Then

begin

try

ExportGrid4ToHTML(savedialog1.FileName,cxgrid1,true,true,'htm');

except

ShowMessage('Hata!Dosya oluşturulamadı.');

exit;

end;

procedure Tform1.XML1Click(Sender: TObject);

begin

savedialog1.DefaultExt:='xml';

If savedialog1.Execute Then

begin

try

ExportGrid4ToXML(savedialog1.FileName,cxgrid1,true,true);

except

ShowMessage('Hata!Dosya oluşturulamadı.');

exit;

end;

Delphi - .....................................

AdoQuery de parambyname metodu

{Mehmet TEPE

Çözüm Yazılım

EDU}

procedure TForm1.Button1Click(Sender: TObject);

begin

adoquery1.Close;

adoquery1.SQL.Clear;

adoquery1.SQL.Add('select * from tablo1 where adi=:adi');

adoquery1.Parameters.ParamByName('adi').Value:=edit1.Text;

adoquery1.Open;

end;

Delphi - .....................................

AdoQuery de parambyname metodu

{Mehmet TEPE

Çözüm Yazılım

EDU}

procedure TForm1.Button1Click(Sender: TObject);

begin

adoquery1.Close;

adoquery1.SQL.Clear;

adoquery1.SQL.Add('select * from tablo1 where adi=:adi');

adoquery1.Parameters.ParamByName('adi').Value:=edit1.Text;

adoquery1.Open;

end;

Delphi - .....................................

Internet Explorer çalıştırma

{Mehmet TEPE

Çözüm Bilgisayar

EDU}

var

ie:variant; {unit'in uses bloguna comobj eklemeyi unutma..}

begin

ie:=createoleobject('internetexplorer.application');

ie.navigate('http://www.tepenet.net');

ie.width:=500;

ie.width:=600;

ie.visible:=true;

end;

Delphi - .....................................

Internet Explorer çalıştırma

{Mehmet TEPE

Çözüm Bilgisayar

EDU}

var

ie:variant; {unit'in uses bloguna comobj eklemeyi unutma..}

begin

ie:=createoleobject('internetexplorer.application');

ie.navigate('http://www.tepenet.net');

ie.width:=500;

ie.width:=600;

ie.visible:=true;

end;

Delphi - .....................................

İnternete Baglanabilirmiyiz?

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

procedure TForm1.Button1Click(Sender: TObject) ;

function FuncAvail(_dllname, _funcname: string;

var _p: pointer): boolean;

{return True if _funcname exists in _dllname}

var _lib: tHandle;

begin

Result := false;

if LoadLibrary(PChar(_dllname)) = 0 then exit;

_lib := GetModuleHandle(PChar(_dllname)) ;

if _lib <> 0 then begin

_p := GetProcAddress(_lib, PChar(_funcname)) ;

if _p <> NIL then Result := true;

end;

{

Call SHELL32.DLL for Win > Win98

otherwise call URL.dll

}

{buton code:}

var

InetIsOffline : function(dwFlags: DWORD):

BOOL; stdcall;

begin

if FuncAvail('URL.DLL', 'InetIsOffline',

@InetIsOffline) then

if InetIsOffLine(0) = true

then ShowMessage('Not connected')

else ShowMessage('Connected!') ;

end;

Delphi - .....................................

İnternete Baglanabilirmiyiz?

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

procedure TForm1.Button1Click(Sender: TObject) ;

function FuncAvail(_dllname, _funcname: string;

var _p: pointer): boolean;

{return True if _funcname exists in _dllname}

var _lib: tHandle;

begin

Result := false;

if LoadLibrary(PChar(_dllname)) = 0 then exit;

_lib := GetModuleHandle(PChar(_dllname)) ;

if _lib <> 0 then begin

_p := GetProcAddress(_lib, PChar(_funcname)) ;

if _p <> NIL then Result := true;

end;

{

Call SHELL32.DLL for Win > Win98

otherwise call URL.dll

}

{buton code:}

var

InetIsOffline : function(dwFlags: DWORD):

BOOL; stdcall;

begin

if FuncAvail('URL.DLL', 'InetIsOffline',

@InetIsOffline) then

if InetIsOffLine(0) = true

then ShowMessage('Not connected')

else ShowMessage('Connected!') ;

end;

Delphi - .....................................

Download a file from the Internet with progress indicator

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

uses ExtActns, ...

type

TfrMain = class(TForm)

...

private

procedure URL_OnDownloadProgress

(Sender: TDownLoadURL;

Progress, ProgressMax: Cardinal;

StatusCode: TURLDownloadStatus;

StatusText: String; var Cancel: Boolean) ;

...

implementation

...

procedure TfrMain.URL_OnDownloadProgress;

begin

ProgressBar1.Max:= ProgressMax;

ProgressBar1.Position:= Progress;

end;

function DoDownload;

begin

with TDownloadURL.Create(self) do

try

URL:='http://z.about.com/6/g/delphi/b/index.xml';

FileName := 'c:ADPHealines.xml';

OnDownloadProgress := URL_OnDownloadProgress;

ExecuteTarget(nil) ;

finally

Free;

end;

{

Note:

URL property points to Internet

FileName is the local file

}

Delphi - .....................................

Download a file from the Internet with progress indicator

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

uses ExtActns, ...

type

TfrMain = class(TForm)

...

private

procedure URL_OnDownloadProgress

(Sender: TDownLoadURL;

Progress, ProgressMax: Cardinal;

StatusCode: TURLDownloadStatus;

StatusText: String; var Cancel: Boolean) ;

...

implementation

...

procedure TfrMain.URL_OnDownloadProgress;

begin

ProgressBar1.Max:= ProgressMax;

ProgressBar1.Position:= Progress;

end;

function DoDownload;

begin

with TDownloadURL.Create(self) do

try

URL:='http://z.about.com/6/g/delphi/b/index.xml';

FileName := 'c:ADPHealines.xml';

OnDownloadProgress := URL_OnDownloadProgress;

ExecuteTarget(nil) ;

finally

Free;

end;

{

Note:

URL property points to Internet

FileName is the local file

}

Delphi - .....................................

İnternet Sıkkullananlara url ekleme

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

function GetIEFavourites

(const favpath: string):TStrings;

var

searchrec:TSearchrec;

str:TStrings;

path,dir,filename:String;

Buffer: array[0..2047] of Char;

found:Integer;

begin

str:=TStringList.Create;

try

path:=FavPath+'*.url';

dir:=ExtractFilepath(path) ;

found:=FindFirst(path,faAnyFile,searchrec) ;

while found=0 do begin

SetString(filename, Buffer,

GetPrivateProfileString('InternetShortcut',

PChar('URL'), NIL, Buffer, SizeOf(Buffer),

PChar(dir+searchrec.Name))) ;

str.Add(filename) ;

found:=FindNext(searchrec) ;

end;

found:=FindFirst(dir+'*.*',faAnyFile,searchrec) ;

while found=0 do begin

if ((searchrec.Attr and faDirectory) > 0)

and (searchrec.Name[1]<>'.') then

str.AddStrings(GetIEFavourites

(dir+''+searchrec.name)) ;

found:=FindNext(searchrec) ;

end;

FindClose(searchrec) ;

finally

Result:=str;

end;

procedure TForm1.Button1Click(Sender: TObject) ;

var pidl: PItemIDList;

FavPath: array[0..MAX_PATH] of char;

begin

SHGetSpecialFolderLocation(Handle, CSIDL_FAVORITES, pidl) ;

SHGetPathFromIDList(pidl, favpath) ;

ListBox1.Items:=GetIEFavourites(StrPas(FavPath)) ;

end;

Delphi - .....................................

İnternet Sıkkullananlara url ekleme

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

function GetIEFavourites

(const favpath: string):TStrings;

var

searchrec:TSearchrec;

str:TStrings;

path,dir,filename:String;

Buffer: array[0..2047] of Char;

found:Integer;

begin

str:=TStringList.Create;

try

path:=FavPath+'*.url';

dir:=ExtractFilepath(path) ;

found:=FindFirst(path,faAnyFile,searchrec) ;

while found=0 do begin

SetString(filename, Buffer,

GetPrivateProfileString('InternetShortcut',

PChar('URL'), NIL, Buffer, SizeOf(Buffer),

PChar(dir+searchrec.Name))) ;

str.Add(filename) ;

found:=FindNext(searchrec) ;

end;

found:=FindFirst(dir+'*.*',faAnyFile,searchrec) ;

while found=0 do begin

if ((searchrec.Attr and faDirectory) > 0)

and (searchrec.Name[1]<>'.') then

str.AddStrings(GetIEFavourites

(dir+''+searchrec.name)) ;

found:=FindNext(searchrec) ;

end;

FindClose(searchrec) ;

finally

Result:=str;

end;

procedure TForm1.Button1Click(Sender: TObject) ;

var pidl: PItemIDList;

FavPath: array[0..MAX_PATH] of char;

begin

SHGetSpecialFolderLocation(Handle, CSIDL_FAVORITES, pidl) ;

SHGetPathFromIDList(pidl, favpath) ;

ListBox1.Items:=GetIEFavourites(StrPas(FavPath)) ;

end;

Delphi - .....................................

İnternet Açılış Sayfasını Değiştirme

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

uses Registry;

...

function SetIEHomePage(PageName: string): Boolean;

begin

with TRegistry.Create do

try

RootKey := HKEY_CURRENT_USER;

OpenKey('SoftwareMicrosoftInternet ExplorerMain', False) ;

try

WriteString('Start Page', PageName) ;

Result := True;

except

Result := False;

end;

CloseKey;

finally

Free;

end;

//Usage:

SetIEHomePage('http://delphi.about.com')

Delphi - .....................................

İnternet Açılış Sayfasını Değiştirme

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

uses Registry;

...

function SetIEHomePage(PageName: string): Boolean;

begin

with TRegistry.Create do

try

RootKey := HKEY_CURRENT_USER;

OpenKey('SoftwareMicrosoftInternet ExplorerMain', False) ;

try

WriteString('Start Page', PageName) ;

Result := True;

except

Result := False;

end;

CloseKey;

finally

Free;

end;

//Usage:

SetIEHomePage('http://delphi.about.com')

Delphi - .....................................

Ağ Sürücülerini Listeleme

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

function GetNetworkDriveMappings

(SList: TStrings): integer;

var

i: Char;

ThePath: string;

MaxNetPathLen: DWord;

begin

SList.Clear;

MaxNetPathLen := MAX_PATH;

SetLength(ThePath, MAX_PATH) ;

for i := 'A' to 'Z' do

if WNetGetConnection(PChar('' + i + ':'),

PChar(ThePath),

MaxNetPathLen) = NO_ERROR then

SList.Add(i + ': ' + ThePath) ;

Result := SList.Count;

end;

Delphi - .....................................

Ağ Sürücülerini Listeleme

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

function GetNetworkDriveMappings

(SList: TStrings): integer;

var

i: Char;

ThePath: string;

MaxNetPathLen: DWord;

begin

SList.Clear;

MaxNetPathLen := MAX_PATH;

SetLength(ThePath, MAX_PATH) ;

for i := 'A' to 'Z' do

if WNetGetConnection(PChar('' + i + ':'),

PChar(ThePath),

MaxNetPathLen) = NO_ERROR then

SList.Add(i + ': ' + ThePath) ;

Result := SList.Count;

end;

Delphi - .....................................

Html'den Resim Linklerini Alma

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

uses ... mshtml, ActiveX, COMObj, IdHTTP, idURI;

procedure GetImageLinks(AURL: String; AList: TStrings) ;

var

IDoc : IHTMLDocument2;

strHTML : String;

v : Variant;

x : integer;

ovLinks : OleVariant;

DocURL : String;

URI : TidURI;

ImgURL : String;

idHTTP : TidHTTP;

begin

AList.Clear;

URI := TidURI.Create(AURL) ;

try

DocURL := 'http://' + URI.Host;

if URI.Path <> '/' then

DocURL := DocURL + URI.Path;

finally

URI.Free;

end;

Idoc:=CreateComObject(Class_HTMLDOcument) as IHTMLDocument2;

try

IDoc.designMode:='on';

while IDoc.readyState<>'complete' do

Application.ProcessMessages;

v:=VarArrayCreate([0,0],VarVariant) ;

idHTTP := TidHTTP.Create(nil) ;

try

strHTML := idHTTP.Get(AURL) ;

finally

idHTTP.Free;

end;

v[0]:= strHTML;

IDoc.write(PSafeArray(System.TVarData(v).VArray)) ;

IDoc.designMode:='off';

while IDoc.readyState<>'complete' do

Application.ProcessMessages;

ovLinks := IDoc.all.tags('IMG') ;

if ovLinks.Length > 0 then

begin

for x := 0 to ovLinks.Length-1 do

begin

ImgURL := ovLinks.Item(x).src;

// The stuff below will probably need a little tweaking

// Deteriming and turning realtive URLs into absolute URLs

// is not that difficult but this is all I could come up with

// in such a short notice.

if (ImgURL[1] = '/') then

begin

// more than likely a relative URL so

// append the DocURL

ImgURL := DocURL + ImgUrl;

end

else

begin

if (Copy(ImgURL, 1, 11) = 'about:blank') then

begin

ImgURL := DocURL + Copy(ImgUrl, 12, Length(ImgURL)) ;

end;

AList.Add(ImgURL) ;

end;

finally

IDoc := nil;

end;

//Usage

procedure TForm1.Button1Click(Sender: TObject) ;

begin

GetImageLinks('http://delphi.about.com/library/weekly/aa120704a.htm', Memo1.Lines) ;

end;

Delphi - .....................................

Html'den Resim Linklerini Alma

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

uses ... mshtml, ActiveX, COMObj, IdHTTP, idURI;

procedure GetImageLinks(AURL: String; AList: TStrings) ;

var

IDoc : IHTMLDocument2;

strHTML : String;

v : Variant;

x : integer;

ovLinks : OleVariant;

DocURL : String;

URI : TidURI;

ImgURL : String;

idHTTP : TidHTTP;

begin

AList.Clear;

URI := TidURI.Create(AURL) ;

try

DocURL := 'http://' + URI.Host;

if URI.Path <> '/' then

DocURL := DocURL + URI.Path;

finally

URI.Free;

end;

Idoc:=CreateComObject(Class_HTMLDOcument) as IHTMLDocument2;

try

IDoc.designMode:='on';

while IDoc.readyState<>'complete' do

Application.ProcessMessages;

v:=VarArrayCreate([0,0],VarVariant) ;

idHTTP := TidHTTP.Create(nil) ;

try

strHTML := idHTTP.Get(AURL) ;

finally

idHTTP.Free;

end;

v[0]:= strHTML;

IDoc.write(PSafeArray(System.TVarData(v).VArray)) ;

IDoc.designMode:='off';

while IDoc.readyState<>'complete' do

Application.ProcessMessages;

ovLinks := IDoc.all.tags('IMG') ;

if ovLinks.Length > 0 then

begin

for x := 0 to ovLinks.Length-1 do

begin

ImgURL := ovLinks.Item(x).src;

// The stuff below will probably need a little tweaking

// Deteriming and turning realtive URLs into absolute URLs

// is not that difficult but this is all I could come up with

// in such a short notice.

if (ImgURL[1] = '/') then

begin

// more than likely a relative URL so

// append the DocURL

ImgURL := DocURL + ImgUrl;

end

else

begin

if (Copy(ImgURL, 1, 11) = 'about:blank') then

begin

ImgURL := DocURL + Copy(ImgUrl, 12, Length(ImgURL)) ;

end;

AList.Add(ImgURL) ;

end;

finally

IDoc := nil;

end;

//Usage

procedure TForm1.Button1Click(Sender: TObject) ;

begin

GetImageLinks('http://delphi.about.com/library/weekly/aa120704a.htm', Memo1.Lines) ;

end;

Delphi - .....................................

Web Sayfasını Kaydetme

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

uses ActiveX;

...

procedure WB_SaveAs_HTML

(WB:TWebBrowser; const FileName : string);

var

PersistStream: IPersistStreamInit;

Stream: IStream;

FileStream: TFileStream;

begin

if not Assigned(WB.Document) then

begin

ShowMessage('Document not loaded!');

Exit;

end;

PersistStream := WB.Document as IPersistStreamInit;

FileStream := TFileStream.Create(FileName, fmCreate);

try

Stream := TStreamAdapter.Create(FileStream, soReference)

as IStream;

if Failed(PersistStream.Save(Stream, True)) then

ShowMessage('SaveAs HTML fail!');

finally

FileStream.Free;

end;

end; (* WB_SaveAs_HTML *)

WB_SaveAs_HTML(WebBrowser1,'c:WebBrowser1.html');

Delphi - .....................................

Web Sayfasını Kaydetme

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

uses ActiveX;

...

procedure WB_SaveAs_HTML

(WB:TWebBrowser; const FileName : string);

var

PersistStream: IPersistStreamInit;

Stream: IStream;

FileStream: TFileStream;

begin

if not Assigned(WB.Document) then

begin

ShowMessage('Document not loaded!');

Exit;

end;

PersistStream := WB.Document as IPersistStreamInit;

FileStream := TFileStream.Create(FileName, fmCreate);

try

Stream := TStreamAdapter.Create(FileStream, soReference)

as IStream;

if Failed(PersistStream.Save(Stream, True)) then

ShowMessage('SaveAs HTML fail!');

finally

FileStream.Free;

end;

end; (* WB_SaveAs_HTML *)

WB_SaveAs_HTML(WebBrowser1,'c:WebBrowser1.html');

Delphi - .....................................

Mail Gönderme

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

procedure TMailerForm.btnSendMailClick(Sender: TObject);

begin

StatusMemo.Clear;

//setup SMTP

SMTP.Host := ledHost.Text;

SMTP.Port := 25;

//setup mail message

MailMessage.From.Address := ledFrom.Text;

MailMessage.Recipients.EMailAddresses :=

ledTo.Text + ',' + ledCC.Text;

MailMessage.Subject := ledSubject.Text;

MailMessage.Body.Text := Body.Text;

if FileExists(ledAttachment.Text) then

TIdAttachment.Create(MailMessage.MessageParts,

ledAttachment.Text);

//send mail

try

SMTP.Connect(1000);

SMTP.Send(MailMessage);

except on E:Exception do

StatusMemo.Lines.Insert(0, 'ERROR: ' + E.Message);

end;

finally

if SMTP.Connected then

SMTP.Disconnect;

end;

end; (* btnSendMail Click *)

Delphi - .....................................

Mail Gönderme

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

procedure TMailerForm.btnSendMailClick(Sender: TObject);

begin

StatusMemo.Clear;

//setup SMTP

SMTP.Host := ledHost.Text;

SMTP.Port := 25;

//setup mail message

MailMessage.From.Address := ledFrom.Text;

MailMessage.Recipients.EMailAddresses :=

ledTo.Text + ',' + ledCC.Text;

MailMessage.Subject := ledSubject.Text;

MailMessage.Body.Text := Body.Text;

if FileExists(ledAttachment.Text) then

TIdAttachment.Create(MailMessage.MessageParts,

ledAttachment.Text);

//send mail

try

SMTP.Connect(1000);

SMTP.Send(MailMessage);

except on E:Exception do

StatusMemo.Lines.Insert(0, 'ERROR: ' + E.Message);

end;

finally

if SMTP.Connected then

SMTP.Disconnect;

end;

end; (* btnSendMail Click *)

Delphi - .....................................

Html Dokumanındaki Stringin Rengini Değiştirme

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

uses mshtml;

procedure WBLocateHighlight(WB: TWebBrowser; Text: string) ;

const

prefix = '';

suffix = '';

var

tr: IHTMLTxtRange;

begin

if Assigned(WB.Document) then

begin

tr := ((wb.Document AS IHTMLDocument2).body AS IHTMLBodyElement).createTextRange;

while tr.findText(Text, 1, 0) do

begin

tr.pasteHTML(prefix + tr.htmlText + suffix) ;

tr.scrollIntoView(True) ;

end;

Usage:

WBLocateHighlight(WebBrowser1,'delphi') ;

Delphi - .....................................

Html Dokumanındaki Stringin Rengini Değiştirme

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

uses mshtml;

procedure WBLocateHighlight(WB: TWebBrowser; Text: string) ;

const

prefix = '';

suffix = '';

var

tr: IHTMLTxtRange;

begin

if Assigned(WB.Document) then

begin

tr := ((wb.Document AS IHTMLDocument2).body AS IHTMLBodyElement).createTextRange;

while tr.findText(Text, 1, 0) do

begin

tr.pasteHTML(prefix + tr.htmlText + suffix) ;

tr.scrollIntoView(True) ;

end;

Usage:

WBLocateHighlight(WebBrowser1,'delphi') ;

Delphi - .....................................

Html'yi direk WebBrowser'a yükleme

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

procedure WBLoadHTML(WebBrowser: TWebBrowser; HTMLCode: string) ;

var

sl: TStringList;

ms: TMemoryStream;

begin

WebBrowser.Navigate('about:blank') ;

while WebBrowser.ReadyState < READYSTATE_INTERACTIVE do

Application.ProcessMessages;

if Assigned(WebBrowser.Document) then

begin

sl := TStringList.Create;

try

ms := TMemoryStream.Create;

try

sl.Text := HTMLCode;

sl.SaveToStream(ms) ;

ms.Seek(0, 0) ;

(WebBrowser.Document as IPersistStreamInit).Load(TStreamAdapter.Create(ms)) ;

finally

ms.Free;

end;

finally

sl.Free;

end;

procedure TForm1.FormCreate(Sender: TObject) ;

var

sHTML : string;

begin

sHTML := '<a href="http://delphi.about.com">GOTO</a>' +

'About Delphi Programming';

WBLoadHTML(WebBrowser1,sHTML) ;

end;

Delphi - .....................................

Html'yi direk WebBrowser'a yükleme

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

procedure WBLoadHTML(WebBrowser: TWebBrowser; HTMLCode: string) ;

var

sl: TStringList;

ms: TMemoryStream;

begin

WebBrowser.Navigate('about:blank') ;

while WebBrowser.ReadyState < READYSTATE_INTERACTIVE do

Application.ProcessMessages;

if Assigned(WebBrowser.Document) then

begin

sl := TStringList.Create;

try

ms := TMemoryStream.Create;

try

sl.Text := HTMLCode;

sl.SaveToStream(ms) ;

ms.Seek(0, 0) ;

(WebBrowser.Document as IPersistStreamInit).Load(TStreamAdapter.Create(ms)) ;

finally

ms.Free;

end;

finally

sl.Free;

end;

procedure TForm1.FormCreate(Sender: TObject) ;

var

sHTML : string;

begin

sHTML := '<a href="http://delphi.about.com">GOTO</a>' +

'About Delphi Programming';

WBLoadHTML(WebBrowser1,sHTML) ;

end;

Delphi - .....................................

Word Dosyalarını İExplorerda gösterme

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

procedure TWordPreviewForm.FormCreate(Sender: TObject) ;

begin

//open a Word document in WebBrowser

WebBrowser1.Navigate('c:SomeFolderSomeDocument.doc') ;

end;

procedure TWordPreviewForm.WebBrowser1NavigateComplete2(Sender: TObject;

const pDisp: IDispatch; var URL: OleVariant) ;

begin

with (WebBrowser1.Document AS _Document) do

begin

ActiveWindow.View.ShowAll := False;

ActiveWindow.View.TableGridlines := False;

ActiveWindow.DisplayRulers := False;

ActiveWindow.View.type_ := wdPageView;

end;

Delphi - .....................................

Word Dosyalarını İExplorerda gösterme

********************************************************

*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***

************* 'FORUMLARDAN YARDIM İSTEYİN' *************

********************************************************

procedure TWordPreviewForm.FormCreate(Sender: TObject) ;

begin

//open a Word document in WebBrowser

WebBrowser1.Navigate('c:SomeFolderSomeDocument.doc') ;

end;

procedure TWordPreviewForm.WebBrowser1NavigateComplete2(Sender: TObject;

const pDisp: IDispatch; var URL: OleVariant) ;

begin

with (WebBrowser1.Document AS _Document) do

begin

ActiveWindow.View.ShowAll := False;

ActiveWindow.View.TableGridlines := False;

ActiveWindow.DisplayRulers := False;

ActiveWindow.View.type_ := wdPageView;

end;

Delphi - .....................................

dbgrid ve dblookupcomboboxta mousewheel kontrolü

{ anasayfanıza applicationevents ekleyin(Additional)

applicationsevents'in events -->> onmessage kısmına aşağıdaki kodu

yazın. Artık mouse tekerleği dbgrid ve dblookupcomboboxta düzgün çalışacaktır.

}

procedure Tfrm_Anasayfa.ApplicationEvents1Message(var Msg: tagMSG;

var Handled: Boolean);

var

w: Smallint;

c: TWinControl;

b: Boolean;

begin

if Msg.Message <> WM_MOUSEWHEEL then Exit;

c := Screen.ActiveControl;

b := (c is TDBGrid) or (c is TDBLookupComboBox);

if not b then Exit;

Msg.Message := WM_KEYDOWN;

Msg.lParam := 0;

w := HiWord(Msg.wParam);

if w > 0 then

Msg.wParam := VK_UP

else

Msg.wParam := VK_DOWN;

Handled := False;

end;

Delphi - .....................................

dbgrid ve dblookupcomboboxta mousewheel kontrolü

{ anasayfanıza applicationevents ekleyin(Additional)

applicationsevents'in events -->> onmessage kısmına aşağıdaki kodu

yazın. Artık mouse tekerleği dbgrid ve dblookupcomboboxta düzgün çalışacaktır.

}

procedure Tfrm_Anasayfa.ApplicationEvents1Message(var Msg: tagMSG;

var Handled: Boolean);

var

w: Smallint;

c: TWinControl;

b: Boolean;

begin

if Msg.Message <> WM_MOUSEWHEEL then Exit;

c := Screen.ActiveControl;

b := (c is TDBGrid) or (c is TDBLookupComboBox);

if not b then Exit;

Msg.Message := WM_KEYDOWN;

Msg.lParam := 0;

w := HiWord(Msg.wParam);

if w > 0 then

Msg.wParam := VK_UP

else

Msg.wParam := VK_DOWN;

Handled := False;

end;

Delphi - .....................................

merhaba arkadaşlar dll kod çözücü

Merhaba ARkadaşlar

LKS nin LibCon.dll dosyasını kullanarak program yazmak istiyorum ancak içindeki dll dosyasını fonksiyonlarını bilemediğim için herhangi bir şey yazamıyorum bana bu fonsiyonları öğrenebiliceğim kod çözücü önerebilirmisiniz yada nasıl bulabilirim. yardımlarınızı bekliyorum teşekürler

Delphi - .....................................

merhaba arkadaşlar dll kod çözücü

Merhaba ARkadaşlar

Delphi - .....................................

merhaba arkadaşlar dll kod çözücü

Merhaba ARkadaşlar

Delphi - .....................................

merhaba arkadaşlar dll kod çözücü

Merhaba ARkadaşlar

Delphi - .....................................

List BOx Ile Ilgili

Merhaba

Ben Listboxta item'lerin winamp'ta ki gibi secili olanin font renginin degisebilmesini istiyorum, acaba bu konuda yardimci olabilecek kimse var mi? Lutfen!...

emporio_0@yahoo.com

Delphi - .....................................

List BOx Ile Ilgili

Merhaba

Ben Listboxta item'lerin winamp'ta ki gibi secili olanin font renginin degisebilmesini istiyorum, acaba bu konuda yardimci olabilecek kimse var mi? Lutfen!...

emporio_0@yahoo.com

Delphi - .....................................

ekranın mouse la görüntüsünü almak

//maouse ile ilgili bir kod, bu kodu kendine göre düzenle..

procedure TForm1.Button1Click(Sender: TObject);

var

point:TPoint; // kursor'un bulundugu yer

begin

getcursorpos(point); // kursor'un bulundugu yerin kordinatlarini oku

setcursorpos(350,500); // kursor'u yeni yerine yonlendir.

mouse_event(MOUSEEVENTF_LEFTDOWN,0,0,0,0);// tikla

mouse_event(MOUSEEVENTF_LEFTUP,0,0,0,0); //

setcursorpos(point.x,point.y); // kursor'u eski yerine götürend;

end;

//ekran görüntüsünün alınması ile ilgili bir kod..

procedure TForm1.Button1Click(Sender: TObject);

var width, height : word;

desktop : HDC;

begin

width := Screen.Width;

height := Screen.Height;

desktop := GetWindowDC(GetDesktopWindow);

Image1.Picture.Bitmap.Width := width;

Image1.Picture.Bitmap.Height := height;

BitBlt( Image1.Picture.Bitmap.Canvas.Handle, 0, 0,

width, height, desktop, 0, 0, SRCCOPY );

end;

Delphi - .....................................

ekranın mouse la görüntüsünü almak

//maouse ile ilgili bir kod, bu kodu kendine göre düzenle..

procedure TForm1.Button1Click(Sender: TObject);

var

point:TPoint; // kursor'un bulundugu yer

begin

getcursorpos(point); // kursor'un bulundugu yerin kordinatlarini oku

setcursorpos(350,500); // kursor'u yeni yerine yonlendir.

mouse_event(MOUSEEVENTF_LEFTDOWN,0,0,0,0);// tikla

mouse_event(MOUSEEVENTF_LEFTUP,0,0,0,0); //

setcursorpos(point.x,point.y); // kursor'u eski yerine götürend;

end;

//ekran görüntüsünün alınması ile ilgili bir kod..

procedure TForm1.Button1Click(Sender: TObject);

var width, height : word;

desktop : HDC;

begin

width := Screen.Width;

height := Screen.Height;

desktop := GetWindowDC(GetDesktopWindow);

Image1.Picture.Bitmap.Width := width;

Image1.Picture.Bitmap.Height := height;

BitBlt( Image1.Picture.Bitmap.Canvas.Handle, 0, 0,

width, height, desktop, 0, 0, SRCCOPY );

end;

Delphi - .....................................

Bu kadar da olmazki kardeşim utanın ya

Ya yeter kardeşim artık ya, burası forum değil diye kaç kere yazdık

bu millete iyilik yaramıyo valla, kimi eğitilmek ister, kimi evlenmek ister

kardeşim burası çöp çatan sitesimi ya biraz aşırı konuşmak mı lazım sizle

insanca sözden arar kimse yok mu aranızda yazmayın artık şuraya kod mod,

sıktınız artık, burası kod paylaşma yeri adamların yaptığı terbiyesizliğe bak ya

//Şimdi aranızdan bazıları sen ne yaptın yazı yazı yazarak hani kod diyecek

Herhangi bir yerdeki dosyayi gizlemek

filesetattr('C:deneme.txt',2);

//Lütfen artık şuraya soru moru yazmayın

Delphi - .....................................

Bu kadar da olmazki kardeşim utanın ya

Ya yeter kardeşim artık ya, burası forum değil diye kaç kere yazdık

bu millete iyilik yaramıyo valla, kimi eğitilmek ister, kimi evlenmek ister

kardeşim burası çöp çatan sitesimi ya biraz aşırı konuşmak mı lazım sizle

insanca sözden arar kimse yok mu aranızda yazmayın artık şuraya kod mod,

sıktınız artık, burası kod paylaşma yeri adamların yaptığı terbiyesizliğe bak ya

//Şimdi aranızdan bazıları sen ne yaptın yazı yazı yazarak hani kod diyecek

Herhangi bir yerdeki dosyayi gizlemek

filesetattr('C:deneme.txt',2);

//Lütfen artık şuraya soru moru yazmayın

Delphi - .....................................

oracle, mysql , mssql kac kayit fetch edilsin?

{MY SQL DE KAC SATIR GELSIN ISTIYORSAN}

LIMIT 5000 // query nin son satirina

{SQL SERVER DA}

SET ROWCOUNT 3 // query den once

{Oracle }

rownum <= 5 // query nin son satirina

Delphi - .....................................

oracle, mysql , mssql kac kayit fetch edilsin?

{MY SQL DE KAC SATIR GELSIN ISTIYORSAN}

LIMIT 5000 // query nin son satirina

{SQL SERVER DA}

SET ROWCOUNT 3 // query den once

{Oracle }

rownum <= 5 // query nin son satirina

Delphi - .....................................

FloatsEqual

{

16.01.2005 Pazar 04:03

bu kod jcl kutuphanesinden alintidir..

veritabani okumasi yaparken (daha once kayit edilmis bilgilerden )

// tablo dbase IV formatinda ve alanlar numeric(7,2) yapisinda

if (fielda - fieldb) = fieldc then

....

gibi bir karsilastirma yaptigim zaman

ayni sonuclar olmasina ragmen esit degil diyordu.. netten baktim

boyle bir sey buldum ..

tablodaki ilginclige bakmak isteyen arkadaslar varsa

mail ile gonderebilirim deneme ornegini..

winlinux@mynet.com

saygi , sevgi , linux , delphi ..

}

function FloatsEqual(const X, Y: Float): Boolean;

const

PrecisionTolerance = 0.0000001;

begin

try

if Y = 0 then

Result := (X = Y) or (Abs(1 - Y/X ) <= PrecisionTolerance)

else

Result := (X = Y) or (Abs(1 - X/Y ) <= PrecisionTolerance);

except

Result := False;

end

end;

Delphi - .....................................

FloatsEqual

{

16.01.2005 Pazar 04:03

bu kod jcl kutuphanesinden alintidir..

veritabani okumasi yaparken (daha once kayit edilmis bilgilerden )

// tablo dbase IV formatinda ve alanlar numeric(7,2) yapisinda

if (fielda - fieldb) = fieldc then

....

gibi bir karsilastirma yaptigim zaman

ayni sonuclar olmasina ragmen esit degil diyordu.. netten baktim

boyle bir sey buldum ..

tablodaki ilginclige bakmak isteyen arkadaslar varsa

mail ile gonderebilirim deneme ornegini..

winlinux@mynet.com

saygi , sevgi , linux , delphi ..

}

function FloatsEqual(const X, Y: Float): Boolean;

const

PrecisionTolerance = 0.0000001;

begin

try

if Y = 0 then

Result := (X = Y) or (Abs(1 - Y/X ) <= PrecisionTolerance)

else

Result := (X = Y) or (Abs(1 - X/Y ) <= PrecisionTolerance);

except

Result := False;

end

end;

Delphi - .....................................

Yılan Oyunu

Alıntıdır

unit untGame;

interface

uses

Windows, SysUtils, Classes, Controls, Forms, Menus,

ExtCtrls, StdCtrls, Buttons, ComCtrls, Dialogs,

Graphics;

//BTOdeum;

type

TSnakeDirection = (sdUp, sdDown, sdLeft, sdRight);

TfrmGame = class(TForm)

MenuGame: TMainMenu;

mnuGame: TMenuItem;

mnuNew: TMenuItem;

mnuPause: TMenuItem;

mnuContinue: TMenuItem;

N1: TMenuItem;

mnuExit: TMenuItem;

mnuHelp: TMenuItem;

mnuAbout: TMenuItem;

TmrSnake: TTimer;

mnuOptions: TMenuItem;

mnuAlways: TMenuItem;

N2: TMenuItem;

mnuSettings: TMenuItem;

mnuFinish: TMenuItem;

N3: TMenuItem;

StatusGame: TStatusBar;

Easy1: TMenuItem;

VeryEasy1: TMenuItem;

Medium1: TMenuItem;

Advanced1: TMenuItem;

Expert1: TMenuItem;

Professional1: TMenuItem;

when_to_move_target: TMenuItem;

Sound1: TMenuItem;

Never1: TMenuItem;

N601: TMenuItem;

N801: TMenuItem;

N1001: TMenuItem;

N1201: TMenuItem;

N1401: TMenuItem;

N1601: TMenuItem;

N401: TMenuItem;

ViewHighScores1: TMenuItem;

N4: TMenuItem;

HowtoPlay1: TMenuItem;

Borders1: TMenuItem;

PntGame: TPanel;

PntTarget: TPanel;

procedure PutStatus(S: string; Index: Integer);

procedure mnuExitClick(Sender: TObject);

procedure FormKeyDown(Sender: TObject; var Key: Word;

Shift: TShiftState);

procedure show_panel1;

procedure TmrSnakeTimer(Sender: TObject);

procedure read_inifile;

procedure save_inifile;

procedure FormCreate(Sender: TObject);

procedure mnuAlwaysClick(Sender: TObject);

procedure mnuAboutClick(Sender: TObject);

procedure mnuPauseClick(Sender: TObject);

procedure mnuContinueClick(Sender: TObject);

procedure mnuGameClick(Sender: TObject);

procedure DrawTarget;

procedure mnuNewClick(Sender: TObject);

procedure mnuFinishClick(Sender: TObject);

function NewPointIsValid(X, Y: Integer):Boolean;

function BobyInBody(X, Y: Integer):Boolean;

procedure SetAnyLevelClick(Sender: TObject);

procedure FormClose(Sender: TObject; var Action: TCloseAction);

procedure SetAnyTimeToWait(Sender: TObject);

procedure ViewHighScores1Click(Sender: TObject);

procedure HowtoPlay1Click(Sender: TObject);

procedure SetSoundMenu;

procedure Sound1Click(Sender: TObject);

procedure SetBordersMenu;

procedure Borders1Click(Sender: TObject);

private

cDir : TSnakeDirection;

Parts : array [0..600] of TSpeedButton;

Body_pieces, Level,

CountToWaitBeforeMovingTarget,

TimeToWaitBeforeMovingTarget : Integer;

score : longint;

Playing, Exec, want_sounds, always_on_top,

game_over, game_paused, want_borders : Boolean;

public

{ Public declarations }

end;

var

frmGame: TfrmGame;

const

W: Integer = 16;

H: Integer = 16;

MAX_X: Integer = 30;

MAX_Y: Integer = 20;

TimeToWaitBase = 20; // time to wait values in menu

// start at TimeToWaitBase + 20 (interval between values)

DefaultTimeToWaitBeforeMovingTarget = 120;

Starting_body_pieces = 4; // add 1 (zero based)

implementation

{$R *.DFM}

uses

untMyIniFiles, untHiscores;

{----------------------------------------------------------}

procedure TfrmGame.PutStatus(S: string; Index: Integer);

begin

StatusGame.Panels[Index].Text:=S;

end; { PutStatus }

{----------------------------------------------------------}

procedure TfrmGame.mnuExitClick(Sender: TObject);

begin

Close;

end; { mnuExitClick }

{----------------------------------------------------------}

procedure TfrmGame.FormKeyDown(Sender: TObject; var Key: Word;

Shift: TShiftState);

begin

case Key of

VK_LEFT:

cDir:=sdLeft;

VK_RIGHT:

cDir:=sdRight;

VK_UP:

cDir:=sdUp;

VK_DOWN:

cDir:=sdDown;

end;

end; { FormKeyDown }

{----------------------------------------------------------}

procedure TfrmGame.show_panel1;

var

str1 : string;

begin

str1 := Format('Level %d Score: %d Parts: %d',

[Level, score, Body_pieces + 1 ]);

if want_borders then

str1 := str1 + ' Borders ON'

else

str1 := str1 + ' Borders OFF';

if game_paused then

str1 := str1 + ' Game Paused (press F4)'

else

if game_over then

str1 := 'Game Over (press F1 for new game)'

else

begin

if TimeToWaitBeforeMovingTarget = 0 then

str1 := str1 + ' Target Never Moves'

else

str1 := str1 + ' Move Target in: ' +

inttostr(TimeToWaitBeforeMovingTarget-

CountToWaitBeforeMovingTarget);

end;

PutStatus(str1,0);

end; { show_panel1 }

{----------------------------------------------------------}

procedure TfrmGame.TmrSnakeTimer(Sender: TObject);

{..........................................................}

function PntInTarget(X,Y: Integer):Boolean;

begin

Result:=(PntTarget.Left = X) and (PntTarget.Top = Y);

end; { PntInTarget }

{..........................................................}

procedure CreateNewPart(Index, ALeft, ATop: Integer);

begin

Parts[Index]:=TSpeedButton.Create(Self);

Parts[Index].Parent:=PntGame;

Parts[Index].SetBounds(ALeft,ATop,W,H);

Parts[Index].Enabled:=False;

Parts[Index].Visible:=True;

show_panel1;

end; { CreateNewPart }

{..........................................................}

var

LastSnake, FirstSnake : TSpeedButton;

i, NewLeft, NewTop, W_delta, H_delta : Integer;

begin

if Exec then

Exit;

Exec:=True;

if TimeToWaitBeforeMovingTarget > 0 then

begin

CountToWaitBeforeMovingTarget :=

CountToWaitBeforeMovingTarget + 1 mod TimeToWaitBeforeMovingTarget;

show_panel1;

if CountToWaitBeforeMovingTarget >= TimeToWaitBeforeMovingTarget then

// move the target

DrawTarget;

end;

FirstSnake:=Parts[Body_pieces];

LastSnake:=Parts[0];

W_delta := 0;

H_delta := 0;

case cDir of

sdLeft :

W_delta := -W;

sdRight :

W_delta := W;

sdUp :

H_delta := -H;

sdDown :

H_delta := H;

end; // case

NewLeft:=FirstSnake.Left + W_delta;

NewTop:=FirstSnake.Top + H_delta;

if not want_borders then

begin

if NewLeft < 0 then

NewLeft := (Max_X - 1) * W

else

if NewLeft >= PntGame.Width then

NewLeft := 0;

if NewTop < 0 then

NewTop := (Max_Y - 1) * H

else

if NewTop >= PntGame.Height then

NewTop := 0;

end;

if not NewPointIsValid(NewLeft,NewTop) then

Exit;

if PntInTarget(NewLeft, NewTop) then

begin

Body_pieces:=Body_pieces + 1;

if want_sounds then

//BTBeeper1.BeepFor( 500,10 );

CreateNewPart(Body_pieces,NewLeft,NewTop);

score := score + 10 * Level;

DrawTarget;

Exec:=False;

Exit;

end;

LastSnake.Left:=NewLeft;

LastSnake.Top:=NewTop;

for i:=0 to Body_pieces do

if i < Body_pieces then

Parts :=Parts[i + 1]

else

Parts :=LastSnake;

Exec:=False;

end; { TmrSnakeTimer }

{----------------------------------------------------------}

procedure TfrmGame.read_inifile;

var

ConfigIni : TMyIniFile;

config_filename : string;

begin

config_filename := ChangeFileExt( Application.ExeName, '.ini' );

if FileExists( config_filename ) then

begin

ConfigIni := TMyIniFile.Create( config_filename );

try

Level := ConfigIni.ReadInteger( 'Options', 'Level', level );

TimeToWaitBeforeMovingTarget := ConfigIni.ReadInteger( 'Options', 'When to Move Target',

DefaultTimeToWaitBeforeMovingTarget );

want_sounds := ConfigIni.MyReadBool( 'Options', 'Want Sounds', want_sounds );

want_borders := ConfigIni.MyReadBool( 'Options', 'Want Borders', want_borders );

Always_on_top := ConfigIni.MyReadBool( 'Options', 'Always On Top', always_on_top );

finally

ConfigIni.free;

end;

end; { read_inifile }

{----------------------------------------------------------}

procedure TfrmGame.save_inifile;

var

ConfigIni : TMyIniFile;

config_filename : string;

begin

config_filename := ChangeFileExt( Application.ExeName, '.ini' );

ConfigIni := TMyIniFile.Create( config_filename );

try

ConfigIni.WriteInteger( 'Options', 'Level', level );

ConfigIni.WriteInteger( 'Options', 'When to Move Target', TimeToWaitBeforeMovingTarget );

ConfigIni.MyWriteBool( 'Options', 'Want Sounds', want_sounds );

ConfigIni.MyWriteBool( 'Options', 'Want Borders', want_borders );

ConfigIni.MyWriteBool( 'Options', 'Always On Top', always_on_top );

ConfigIni.UpdateFile;

finally

ConfigIni.free;

end;

end; { save_inifile }

{----------------------------------------------------------}

procedure TfrmGame.FormCreate(Sender: TObject);

begin

Randomize;

Body_pieces:=0;

TimeToWaitBeforeMovingTarget :=

DefaultTimeToWaitBeforeMovingTarget;

game_over := true;

game_paused := false;

playing := false;

score := 0;

PutStatus(Caption,1);

Level:=1; // default level

want_sounds := true; // default is sound on.

want_borders := true;

always_on_top := false;

read_inifile;

show_panel1;

TmrSnake.Interval:=Trunc(500 / Level);

mnuSettings.items[ Level - 1 ].checked := true;

if TimeToWaitBeforeMovingTarget = 0 then

When_to_move_target.items[ 0 ].checked := true

else

When_to_move_target.items[

(TimeToWaitBeforeMovingTarget - TimeToWaitBase) div 20 ].checked := true;

always_on_top := not always_on_top;

mnuAlwaysClick(nil); // this call toggles always on top.

SetSoundMenu;

SetBordersMenu;

// set shortcuts for level menu ... ctrl-1 to ctrl-6

VeryEasy1.ShortCut := ShortCut(Word('1'), [ssCtrl]);

Easy1.ShortCut := ShortCut(Word('2'), [ssCtrl]);

Medium1.ShortCut := ShortCut(Word('3'), [ssCtrl]);

Advanced1.ShortCut := ShortCut(Word('4'), [ssCtrl]);

Expert1.ShortCut := ShortCut(Word('5'), [ssCtrl]);

Professional1.ShortCut := ShortCut(Word('6'), [ssCtrl]);

end; { FormCreate }

{----------------------------------------------------------}

procedure TfrmGame.mnuAlwaysClick(Sender: TObject);

var

Flgs:HWND;

begin

always_on_top := not always_on_top;

mnuAlways.Checked:= always_on_top;

if always_on_top then

Flgs:=HWND_TOPMOST

else

Flgs:=HWND_NOTOPMOST;

SetWindowPos(Handle,Flgs,0,0,0,0,SWP_NOSIZE or SWP_NOMOVE);

end; { mnuAlwaysClick }

{----------------------------------------------------------}

procedure TfrmGame.mnuAboutClick(Sender: TObject);

var

game_in_progress : Boolean;

begin

game_in_progress := (not game_paused) and playing;

if playing then

mnuPauseClick( nil );

MessageBox(Handle,'Snake game, coded by //hIDRA_5.' + #13 +

'with minor mods by PEW','Snake game',

MB_ICONINFORMATION);

if game_in_progress then

mnuContinueClick( nil );

end; { mnuAboutClick }

{----------------------------------------------------------}

procedure TfrmGame.mnuPauseClick(Sender: TObject);

begin

TmrSnake.Enabled:=False;

game_paused := true;

show_panel1;

end; { mnuPauseClick }

{----------------------------------------------------------}

procedure TfrmGame.mnuContinueClick(Sender: TObject);

begin

game_paused := false;

show_panel1;

TmrSnake.Enabled:=True;

end; { mnuContinueClick }

{----------------------------------------------------------}

procedure TfrmGame.mnuGameClick(Sender: TObject);

begin

mnuPause.Enabled:=TmrSnake.Enabled and Playing;

mnuContinue.Enabled:=not mnuPause.Enabled and Playing;

mnuFinish.Enabled:=Playing;

end; { mnuGameClick }

{----------------------------------------------------------}

procedure TfrmGame.DrawTarget;

{..........................................................}

function ValidPoint(X,Y: Integer):Boolean;

var

i:Integer;

begin

Result:=True;

for i:=0 to Body_pieces do

if (Parts .Left = X) and

(Parts .Top = Y) then

begin

Result:=False;

Break;

end;

end; { ValidPoint }

{..........................................................}

var

X,Y,OldX,OldY:Integer;

begin

PntTarget.Visible:=False;

// reset the counter to move the target.

CountToWaitBeforeMovingTarget := 0;

OldX:=PntTarget.Left;

OldY:=PntTarget.Top;

repeat

begin

X:=Random(MAX_X);

Y:=Random(MAX_Y);

end;

until ValidPoint(X*W,Y*H) and ((OldX <> X) or (OldY <> Y));

PntTarget.Left:=X * W;

PntTarget.Top:=Y * H;

PntTarget.Visible:=True;

end; { DrawTarget }

{----------------------------------------------------------}

procedure TfrmGame.mnuNewClick(Sender: TObject);

var

j:Integer;

begin

TmrSnake.Enabled:=False;

CountToWaitBeforeMovingTarget := 0;

if Playing then

mnuFinishClick(Self);

if Body_pieces > 0 then

for j:=0 to Body_pieces do

FreeAndNil(Parts[j]);

Body_pieces := starting_body_pieces;

cDir:=sdRight;

for j:=0 to Body_pieces do

begin

Parts[j]:=TSpeedButton.Create(Self);

Parts[j].Parent:=PntGame;

Parts[j].SetBounds(j * W,0,W,H);

Parts[j].Enabled:=False;

Parts[j].Visible:=True;

end;

DrawTarget;

Exec:=False;

game_over := false;

game_paused := false;

Playing:=True;

score := 0;

show_panel1;

TmrSnake.Enabled:=True;

end; { mnuNewClick }

{----------------------------------------------------------}

procedure TfrmGame.mnuFinishClick(Sender: TObject);

var

i:Integer;

begin

TmrSnake.Enabled:=False;

game_over := true;

Playing:=False;

PntTarget.Visible:=False;

Exec:=False;

for i:=0 to Body_pieces do

FreeAndNil(Parts );

end; { mnuFinishClick }

{----------------------------------------------------------}

function TfrmGame.NewPointIsValid(X, Y: Integer):Boolean;

var

R,R1:Boolean;

rank : integer;

begin

R:=(X >= 0) and (X < PntGame.Width) and

(Y >= 0) and (Y < PntGame.Height);

R1:=BobyInBody(X,Y);

if not R or R1 then

begin

TmrSnake.Enabled:=False;

// 'Game Over' sounds nicer than 'You lose', don't you think?

if not R then

ShowMessage( 'The Snake hit one of the walls.' + #13 +

'Game Over' )

else

ShowMessage( 'The Snake hit itself.' + #13 +

'Game Over' );

mnuFinishClick(Self);

frmHiScTab := TfrmHiScTab.create( nil );

try

frmHiScTab.AddScore( level, score, rank );

if rank = 0 then

showmessage( 'Your score was: ' + inttostr(score) + #13 +

'I''m sorry, you didn''t make the High Score Table.' )

else

showmessage( 'That score ranked #' + inttostr( rank ));

frmHiScTab.ShowModal;

finally

frmHisctab.release;

end;

Result:=False;

show_panel1;

end

else

Result:=True;

end; { NewPointIsValid }

{----------------------------------------------------------}

function TfrmGame.BobyInBody(X, Y: Integer): Boolean;

var

j:Integer;

begin

Result:=False;

for j:=0 to Body_pieces do

if (Parts[j].Left = X) and (Parts[j].Top = Y) then

begin

Result:=True;

Break;

end;

end; { BobyInBody }

{----------------------------------------------------------}

procedure TfrmGame.SetAnyLevelClick(Sender: TObject);

var

game_in_progress : Boolean;

begin

game_in_progress := (not game_paused) and playing;

if playing then

mnuPauseClick( nil );

// unchecked the current level

mnuSettings.items[ Level - 1 ].checked := false;

// set the new level

Level := tMenuItem(Sender).MenuIndex + 1;

// check the new level

tMenuItem(Sender).checked := true;

TmrSnake.Interval:=Trunc(500 / Level);

// redraw the panel because the level has changed

show_panel1;

if game_in_progress then

mnuContinueClick( nil );

end; { SetAnyLevelClick }

{----------------------------------------------------------}

procedure TfrmGame.FormClose(Sender: TObject; var Action: TCloseAction);

begin

save_inifile;

Action := caFree;

end; { FormClose }

{----------------------------------------------------------}

procedure TfrmGame.SetAnyTimeToWait(Sender: TObject);

var

game_in_progress : Boolean;

begin

game_in_progress := (not game_paused) and playing;

if playing then

mnuPauseClick( nil );

// uncheck it

if TimeToWaitBeforeMovingTarget = 0 then

When_to_move_target.items[ 0 ].checked := false

else

When_to_move_target.items[

(TimeToWaitBeforeMovingTarget - TimeToWaitBase) div 20 ].checked := false;

// set the interval

if tmenuitem(sender).MenuIndex = 0 then

TimeToWaitBeforeMovingTarget := 0

else

TimeToWaitBeforeMovingTarget := TimeToWaitBase + tmenuitem(sender).MenuIndex * 20;

// checked the new one.

tmenuitem(sender).checked := true;

show_panel1;

if game_in_progress then

mnuContinueClick( nil );

end; { SetAnyTimeToWait }

{----------------------------------------------------------}

procedure TfrmGame.ViewHighScores1Click(Sender: TObject);

var

game_in_progress : boolean;

begin

game_in_progress := (not game_paused) and playing;

if playing then

mnuPauseClick( nil );

frmHiScTab := TfrmHiScTab.create( nil );

try

frmHiScTab.display_table( 0 );

frmHiScTab.ShowModal;

finally

frmHisctab.release;

end;

if game_in_progress then

mnuContinueClick( nil );

end; { ViewHighScores1Click }

{----------------------------------------------------------}

procedure TfrmGame.HowtoPlay1Click(Sender: TObject);

var

game_in_progress : boolean;

begin

game_in_progress := (not game_paused) and playing;

if playing then

mnuPauseClick( nil );

showmessage( 'How to Play' + #13 +

'===========' + #13 +

'The rules are very simple:' + #13 +

'* Use the cursor keys to move the snake around the screen to eat the green target. When one target is eaten, another will appear.' + #13 +

'* Each time the snake eats a target it grows one square longer and 10 x Level will be added to your score.' + #13 +

'* If the snake hits itself or a wall (with borders on) then the game ends.' + #13 +

'* The borders are toggled (on/off) with ctrl-B. When borders are Off, you can move through the walls. When borders are On, hitting a wall ends the game.' + #13 +

'* The target moves at intervals set in the "Options / When to move target..." menu.' + #13 +

'* There are 6 levels; set with ctrl-1 (Very Easy) thru ctrl-6 (Professional).' + #13 +

'* Sound is switched toggled (on/off) with ctrl-S.' + #13 +

'* The game is paused with F3 and continued with F4.' + #13 +

'* F2 finishes the game (ends it), without exiting.' + #13 +

'* The top 10 scores and recorded in the Hall of Fame. Press F5 to view it.' + #13 +

'* Alt-F4 Exits the Game.' );

if game_in_progress then

mnuContinueClick( nil );

end; { HowtoPlay1Click }

{----------------------------------------------------------}

procedure TfrmGame.SetSoundMenu;

begin

Sound1.Checked := want_sounds;

if want_sounds then

Sound1.caption := 'Sound (is on)'

else

Sound1.caption := 'Sound (is off)';

end; { SetSoundMenu }

{----------------------------------------------------------}

procedure TfrmGame.Sound1Click(Sender: TObject);

var

game_in_progress : Boolean;

begin

game_in_progress := (not game_paused) and playing;

if playing then

mnuPauseClick( nil );

want_sounds := not want_sounds;

SetSoundMenu;

if game_in_progress then

mnuContinueClick( nil );

end; { Sound1Click }

{----------------------------------------------------------}

procedure TfrmGame.SetBordersMenu;

begin

Borders1.Checked := want_borders;

if want_borders then

Borders1.caption := '&Borders (are on)'

else

Borders1.caption := '&Borders (are off)';

end; { SetBordersMenu }

{----------------------------------------------------------}

procedure TfrmGame.Borders1Click(Sender: TObject);

var

game_in_progress : Boolean;

begin

game_in_progress := (not game_paused) and playing;

if playing then

mnuPauseClick( nil );

want_borders := not want_borders;

SetBordersMenu;

show_panel1;

if game_in_progress then

mnuContinueClick( nil );

end; { Borders1Click }