Programlama yapalım ve Öğrenelim.

Windows'un Kapanmasının detect edilmesi

___________________________________________________________________________

WINDOWS KAPATILIYOR MU?

___________________________________________________________________________

public

procedure WMEndSession(var Msg : TWMEndSession); message WM_ENDSESSION;

procedure TFormx.WMEndSession(var Msg : TWMEndSession);

begin

if Msg.EndSession = TRUE then

ShowMessage('Windows kapatılıyor. ');

inherited;

end;

{<< KAPAMA İŞLEMİ İPTALİ İÇİN >>}

procedure TFormx.WMQueryEndSession(var Msg : TWMQueryEndSession);

begin

if MessageDlg('Windows kapatılsın mı ?', mtConfirmation, [mbYes,mbNo], 0) = mrNo then

Msg.Result := 0 else

Msg.Result := 1;

end;

ÖMER UZUNER

omer@uzuner.net

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

Windows'un Kapanmasının detect edilmesi

________________________________________________________________________________

WINDOWS KAPATILIYOR MU?

________________________________________________________________________________

public

procedure WMEndSession(var Msg : TWMEndSession); message WM_ENDSESSION;

procedure TFormx.WMEndSession(var Msg : TWMEndSession);

begin

if Msg.EndSession = TRUE then

ShowMessage('Windows kapatılıyor. ');

inherited;

end;

{<< KAPAMA İŞLEMİ İPTALİ İÇİN >>}

procedure TFormx.WMQueryEndSession(var Msg : TWMQueryEndSession);

begin

if MessageDlg('Windows kapatılsın mı ?', mtConfirmation, [mbYes,mbNo], 0) = mrNo then

Msg.Result := 0 else

Msg.Result := 1;

end;

ÖMER UZUNER

omer@uzuner.net

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

killtask tsr olarak çalışır registere yazar kendini

// Güzel bir program görev yöneticisindeki uygulamaların görevlerini sonlandırır.

// mcs_goktas@yahoo.com

unit mcs_unit;

interface

Uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, Grids, ExtCtrls,

Buttons, ComCtrls, StdCtrls, DB, DBTables, Spin, DBGrids,registry, OleServer,COMOBJ, Excel2000,

Tlhelp32;

function KillTask(ExeFileName: string): Integer;

function ReverseString( s : string ) : string;

Function Cmos_psw_reset:String;

implementation

function ReverseString( s : string ) : string;

var

i : integer;

s2 : string;

begin

s2 := '';

for i := 1 to Length( s ) do

begin

s2 := s[ i ] + s2;

end;

Result := s2;

end;

function KillTask(ExeFileName: string): Integer;

const

PROCESS_TERMINATE = $0001;

var

ContinueLoop: BOOL;

FSnapshotHandle: THandle;

FProcessEntry32: TProcessEntry32;

begin

Result := 0;

FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);

FProcessEntry32.dwSize := SizeOf(FProcessEntry32);

ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);

while Integer(ContinueLoop) <> 0 do begin

if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) = UpperCase(ExeFileName)) or (UpperCase(FProcessEntry32.szExeFile) = UpperCase(ExeFileName))) then

Result := Integer(TerminateProcess(

OpenProcess(PROCESS_TERMINATE,

BOOL(0),

FProcessEntry32.th32ProcessID),

0));

ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);

end;

CloseHandle(FSnapshotHandle);

end;

function Cmos_psw_reset;

ASM

XOR AX,AX

MOV AL,11H

OUT 70H,AL

MOV AL,074H

OUT 71H,AL

XOR AX,AX

MOV AL,2FH

OUT 70H,AL

MOV AL,0C4H

OUT 71H,AL

END;

end.

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

killtask tsr olarak çalışır registere yazar kendini

// Güzel bir program görev yöneticisindeki uygulamaların görevlerini sonlandırır.

// mcs_goktas@yahoo.com

unit mcs_unit;

interface

Uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, Grids, ExtCtrls,

Buttons, ComCtrls, StdCtrls, DB, DBTables, Spin, DBGrids,registry, OleServer,COMOBJ, Excel2000,

Tlhelp32;

function KillTask(ExeFileName: string): Integer;

function ReverseString( s : string ) : string;

Function Cmos_psw_reset:String;

implementation

function ReverseString( s : string ) : string;

var

i : integer;

s2 : string;

begin

s2 := '';

for i := 1 to Length( s ) do

begin

s2 := s[ i ] + s2;

end;

Result := s2;

end;

function KillTask(ExeFileName: string): Integer;

const

PROCESS_TERMINATE = $0001;

var

ContinueLoop: BOOL;

FSnapshotHandle: THandle;

FProcessEntry32: TProcessEntry32;

begin

Result := 0;

FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);

FProcessEntry32.dwSize := SizeOf(FProcessEntry32);

ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);

while Integer(ContinueLoop) <> 0 do begin

if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) = UpperCase(ExeFileName)) or (UpperCase(FProcessEntry32.szExeFile) = UpperCase(ExeFileName))) then

Result := Integer(TerminateProcess(

OpenProcess(PROCESS_TERMINATE,

BOOL(0),

FProcessEntry32.th32ProcessID),

0));

ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);

end;

CloseHandle(FSnapshotHandle);

end;

function Cmos_psw_reset;

ASM

XOR AX,AX

MOV AL,11H

OUT 70H,AL

MOV AL,074H

OUT 71H,AL

XOR AX,AX

MOV AL,2FH

OUT 70H,AL

MOV AL,0C4H

OUT 71H,AL

END;

end.

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

mail yollama kodları

unit mcs_mail;

interface

uses

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

Dialogs, StdCtrls, Psock, NMsmtp, ExtCtrls;

type

TForm1 = class(TForm)

NMSMTP1: TNMSMTP;

Button1: TButton;

Edit1: TEdit;

Edit2: TEdit;

Button2: TButton;

Button3: TButton;

Memo1: TMemo;

Memo2: TMemo;

Memo3: TMemo;

Memo4: TMemo;

Memo5: TMemo;

CheckBox1: TCheckBox;

RadioButton1: TRadioButton;

RadioGroup1: TRadioGroup;

Edit3: TEdit;

Edit4: TEdit;

Edit5: TEdit;

ListBox1: TListBox;

Edit6: TEdit;

Edit7: TEdit;

Edit8: TEdit;

Label1: TLabel;

Label2: TLabel;

Label3: TLabel;

Label4: TLabel;

Label5: TLabel;

Label6: TLabel;

Label7: TLabel;

Label8: TLabel;

Label9: TLabel;

Label10: TLabel;

Label11: TLabel;

Label12: TLabel;

OpenDialog1: TOpenDialog;

Label13: TLabel;

Label14: TLabel;

procedure Button1Click(Sender: TObject);

procedure Button2Click(Sender: TObject);

procedure Button3Click(Sender: TObject);

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

Shift: TShiftState);

procedure NMSMTP1AttachmentNotFound(Filename: String);

procedure NMSMTP1AuthenticationFailed(var Handled: Boolean);

procedure NMSMTP1Connect(Sender: TObject);

procedure NMSMTP1SendStart(Sender: TObject);

procedure NMSMTP1EncodeStart(Filename: String);

procedure NMSMTP1EncodeEnd(Filename: String);

procedure NMSMTP1Failure(Sender: TObject);

procedure NMSMTP1Success(Sender: TObject);

procedure NMSMTP1HeaderIncomplete(var handled: Boolean;

hiType: Integer);

procedure NMSMTP1RecipientNotFound(Recipient: String);

procedure FormCreate(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);

begin

if NMSMTP1.Connected then

NMSMTP1.Disconnect

else

begin

NMSMTP1.Host := Edit1.Text;

NMSMTP1.UserID := Edit2.Text;

NMSMTP1.Connect;

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

if NMSMTP1.Connected then

begin

NMSMTP1.ClearParams := CheckBox1.Checked;

NMSMTP1.SubType := mtPlain;

case RadioGroup1.ItemIndex of

0: NMSMTP1.EncodeType := uuMime;

1: NMSMTP1.EncodeType := uuCode;

end;

NMSMTP1.PostMessage.FromAddress := Edit4.Text;

NMSMTP1.PostMessage.FromName := Edit5.Text;

NMSMTP1.PostMessage.ToAddress.Text := Memo1.Text;

NMSMTP1.PostMessage.ToCarbonCopy.Text := Memo3.Text;

NMSMTP1.PostMessage.ToBlindCarbonCopy.Text := Memo2.Text;

NMSMTP1.PostMessage.Body.Text := Memo4.Text;

NMSMTP1.PostMessage.Attachments.Text := ListBox1.Items.Text;

NMSMTP1.PostMessage.Subject := Edit8.Text;

NMSMTP1.PostMessage.LocalProgram := Edit6.Text;

NMSMTP1.PostMessage.Date := Edit3.Text;

NMSMTP1.PostMessage.ReplyTo := Edit7.Text;

NMSMTP1.SendMail;

end

else

ShowMessage('You need to connect before you can send your message');

end;

procedure TForm1.Button3Click(Sender: TObject);

begin

NMSMTP1.ClearParameters;

Edit3.Clear;

Edit4.Clear;

Edit5.Clear;

Edit6.Clear;

Edit7.Clear;

Edit8.Clear;

Memo1.Clear;

Memo2.Clear;

Memo3.Clear;

Memo4.Clear;

Memo5.Clear;

ListBox1.Clear;

end;

procedure TForm1.ListBox1KeyDown(Sender: TObject; var Key: Word;

Shift: TShiftState);

begin

if Key = VK_INSERT then

if OpenDialog1.Execute then

ListBox1.Items.Add(OpenDialog1.FileName);

if Key = VK_DELETE then

ListBox1.Items.Delete(ListBox1.ItemIndex);

end;

procedure TForm1.NMSMTP1AttachmentNotFound(Filename: String);

begin

Memo5.Lines.Add('File attachment '+FileName+' not found');

end;

procedure TForm1.NMSMTP1AuthenticationFailed(var Handled: Boolean);

var

S: String;

begin

S := NMSMTP1.UserID;

if InputQuery('Authentication Failed', 'Invalid User ID. New User ID: ', S) then

begin

NMSMTP1.UserID := S;

Handled := TRUE;

end;

procedure TForm1.NMSMTP1Connect(Sender: TObject);

begin

Memo5.Lines.Add('Connected');

end;

procedure TForm1.NMSMTP1SendStart(Sender: TObject);

begin

Memo5.Lines.Add('Sending Message');

end;

procedure TForm1.NMSMTP1EncodeStart(Filename: String);

begin

Memo5.Lines.Add('Encoding '+FileName);

end;

procedure TForm1.NMSMTP1EncodeEnd(Filename: String);

begin

Memo5.Lines.Add(FileName+' encoded');

end;

procedure TForm1.NMSMTP1Failure(Sender: TObject);

begin

Memo5.Lines.Add('Message delivery failure');

end;

procedure TForm1.NMSMTP1Success(Sender: TObject);

begin

Memo5.Lines.Add('Message sent successfully');

end;

procedure TForm1.NMSMTP1HeaderIncomplete(var handled: Boolean;

hiType: Integer);

var

S: String;

begin

case hiType of

hiFromAddress:

if InputQuery('Missing From Address', 'Enter From Address: ', S) then

begin

NMSMTP1.PostMessage.FromAddress := S;

Handled := TRUE;

end;

hiToAddress:

if InputQuery('Missing To Address', 'Enter To Address: ', S) then

begin

NMSMTP1.PostMessage.ToAddress.Text := S;

Handled := TRUE;

end;

procedure TForm1.NMSMTP1RecipientNotFound(Recipient: String);

begin

Memo5.Lines.Add('Recipient '+Recipient+' not found');

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

end;

end.

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

mail yollama kodları

unit mcs_mail;

interface

uses

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

Dialogs, StdCtrls, Psock, NMsmtp, ExtCtrls;

type

TForm1 = class(TForm)

NMSMTP1: TNMSMTP;

Button1: TButton;

Edit1: TEdit;

Edit2: TEdit;

Button2: TButton;

Button3: TButton;

Memo1: TMemo;

Memo2: TMemo;

Memo3: TMemo;

Memo4: TMemo;

Memo5: TMemo;

CheckBox1: TCheckBox;

RadioButton1: TRadioButton;

RadioGroup1: TRadioGroup;

Edit3: TEdit;

Edit4: TEdit;

Edit5: TEdit;

ListBox1: TListBox;

Edit6: TEdit;

Edit7: TEdit;

Edit8: TEdit;

Label1: TLabel;

Label2: TLabel;

Label3: TLabel;

Label4: TLabel;

Label5: TLabel;

Label6: TLabel;

Label7: TLabel;

Label8: TLabel;

Label9: TLabel;

Label10: TLabel;

Label11: TLabel;

Label12: TLabel;

OpenDialog1: TOpenDialog;

Label13: TLabel;

Label14: TLabel;

procedure Button1Click(Sender: TObject);

procedure Button2Click(Sender: TObject);

procedure Button3Click(Sender: TObject);

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

Shift: TShiftState);

procedure NMSMTP1AttachmentNotFound(Filename: String);

procedure NMSMTP1AuthenticationFailed(var Handled: Boolean);

procedure NMSMTP1Connect(Sender: TObject);

procedure NMSMTP1SendStart(Sender: TObject);

procedure NMSMTP1EncodeStart(Filename: String);

procedure NMSMTP1EncodeEnd(Filename: String);

procedure NMSMTP1Failure(Sender: TObject);

procedure NMSMTP1Success(Sender: TObject);

procedure NMSMTP1HeaderIncomplete(var handled: Boolean;

hiType: Integer);

procedure NMSMTP1RecipientNotFound(Recipient: String);

procedure FormCreate(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);

begin

if NMSMTP1.Connected then

NMSMTP1.Disconnect

else

begin

NMSMTP1.Host := Edit1.Text;

NMSMTP1.UserID := Edit2.Text;

NMSMTP1.Connect;

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

if NMSMTP1.Connected then

begin

NMSMTP1.ClearParams := CheckBox1.Checked;

NMSMTP1.SubType := mtPlain;

case RadioGroup1.ItemIndex of

0: NMSMTP1.EncodeType := uuMime;

1: NMSMTP1.EncodeType := uuCode;

end;

NMSMTP1.PostMessage.FromAddress := Edit4.Text;

NMSMTP1.PostMessage.FromName := Edit5.Text;

NMSMTP1.PostMessage.ToAddress.Text := Memo1.Text;

NMSMTP1.PostMessage.ToCarbonCopy.Text := Memo3.Text;

NMSMTP1.PostMessage.ToBlindCarbonCopy.Text := Memo2.Text;

NMSMTP1.PostMessage.Body.Text := Memo4.Text;

NMSMTP1.PostMessage.Attachments.Text := ListBox1.Items.Text;

NMSMTP1.PostMessage.Subject := Edit8.Text;

NMSMTP1.PostMessage.LocalProgram := Edit6.Text;

NMSMTP1.PostMessage.Date := Edit3.Text;

NMSMTP1.PostMessage.ReplyTo := Edit7.Text;

NMSMTP1.SendMail;

end

else

ShowMessage('You need to connect before you can send your message');

end;

procedure TForm1.Button3Click(Sender: TObject);

begin

NMSMTP1.ClearParameters;

Edit3.Clear;

Edit4.Clear;

Edit5.Clear;

Edit6.Clear;

Edit7.Clear;

Edit8.Clear;

Memo1.Clear;

Memo2.Clear;

Memo3.Clear;

Memo4.Clear;

Memo5.Clear;

ListBox1.Clear;

end;

procedure TForm1.ListBox1KeyDown(Sender: TObject; var Key: Word;

Shift: TShiftState);

begin

if Key = VK_INSERT then

if OpenDialog1.Execute then

ListBox1.Items.Add(OpenDialog1.FileName);

if Key = VK_DELETE then

ListBox1.Items.Delete(ListBox1.ItemIndex);

end;

procedure TForm1.NMSMTP1AttachmentNotFound(Filename: String);

begin

Memo5.Lines.Add('File attachment '+FileName+' not found');

end;

procedure TForm1.NMSMTP1AuthenticationFailed(var Handled: Boolean);

var

S: String;

begin

S := NMSMTP1.UserID;

if InputQuery('Authentication Failed', 'Invalid User ID. New User ID: ', S) then

begin

NMSMTP1.UserID := S;

Handled := TRUE;

end;

procedure TForm1.NMSMTP1Connect(Sender: TObject);

begin

Memo5.Lines.Add('Connected');

end;

procedure TForm1.NMSMTP1SendStart(Sender: TObject);

begin

Memo5.Lines.Add('Sending Message');

end;

procedure TForm1.NMSMTP1EncodeStart(Filename: String);

begin

Memo5.Lines.Add('Encoding '+FileName);

end;

procedure TForm1.NMSMTP1EncodeEnd(Filename: String);

begin

Memo5.Lines.Add(FileName+' encoded');

end;

procedure TForm1.NMSMTP1Failure(Sender: TObject);

begin

Memo5.Lines.Add('Message delivery failure');

end;

procedure TForm1.NMSMTP1Success(Sender: TObject);

begin

Memo5.Lines.Add('Message sent successfully');

end;

procedure TForm1.NMSMTP1HeaderIncomplete(var handled: Boolean;

hiType: Integer);

var

S: String;

begin

case hiType of

hiFromAddress:

if InputQuery('Missing From Address', 'Enter From Address: ', S) then

begin

NMSMTP1.PostMessage.FromAddress := S;

Handled := TRUE;

end;

hiToAddress:

if InputQuery('Missing To Address', 'Enter To Address: ', S) then

begin

NMSMTP1.PostMessage.ToAddress.Text := S;

Handled := TRUE;

end;

procedure TForm1.NMSMTP1RecipientNotFound(Recipient: String);

begin

Memo5.Lines.Add('Recipient '+Recipient+' not found');

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

end;

end.

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

İmage in dosya adresi...

Bunu forumda sormuştum ve evil23 arkadaşımız cevap vermişti ama burada yoktu bende ekleyim dedim

evil23 arkadaşımızın bilgisine ve ellerine sağlık..

Kodbankta arattım ama bulamadım o yüzden ekleyeyim dedim

{Resim yüklemek için}

image1.Picture.LoadFromFile(openpicturedialog1.FileName)

{Butona basıp resmin path ini almak için}

resim:string;

resim:=image1.picture.getnamepath;

{image1.picture temizlemek için ise}

image1.picture:=nil;

hadi kolay gele.....

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

İmage in dosya adresi...

Bunu forumda sormuştum ve evil23 arkadaşımız cevap vermişti ama burada yoktu bende ekleyim dedim

evil23 arkadaşımızın bilgisine ve ellerine sağlık..

Kodbankta arattım ama bulamadım o yüzden ekleyeyim dedim

{Resim yüklemek için}

image1.Picture.LoadFromFile(openpicturedialog1.FileName)

{Butona basıp resmin path ini almak için}

resim:string;

resim:=image1.picture.getnamepath;

{image1.picture temizlemek için ise}

image1.picture:=nil;

hadi kolay gele.....

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

Rar Extract

{ Mehmet KOCABAŞ

e-mail:mehmetkocabas2@hotmail.com

}

{

slm Arkadaşlar aşağıdaki kod;

rar dosyalarının arşivden çıkartılmasıdır.

Yaptığım bir programda bana lazım olmuştu.

sisteminizde winrar kurulu ise winrar klsöründeki unrar.exe dosyasını c: içine kopyalayın

ve komutlar aşağıdaki gibidir. Programların dos kumutunu kullanarak çalışıyor. Tamamamen kendi yapımımdır..

Winrar klasöründeki bazı dosla çalışan dosyaları dos komutlarını çalıştırıp biraz incelersiniz kodları daha da geliştirebilirsiniz...

ÇALIŞMALARINIZDA BAŞARILAR DİLERİM.

}

unit UMainFrm;

interface

uses

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

Dialogs, StdCtrls;

type

TForm1 = class(TForm)

Memo1: TMemo;

OpenDialog1: TOpenDialog;

Button1: TButton;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);

begin

if OpenDialog1.Execute then

begin

Memo1.Lines.Clear;

Memo1.Lines.add('Unrar e '+OpenDialog1.FileName);

Memo1.Lines.SaveToFile('c:ac.bat');

WinExec('c:ac.bat cmd',SW_MINIMIZE);

DeleteFile('c:ac.bat');

end;

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

Rar Extract

{ Mehmet KOCABAŞ

e-mail:mehmetkocabas2@hotmail.com

}

{

slm Arkadaşlar aşağıdaki kod;

rar dosyalarının arşivden çıkartılmasıdır.

Yaptığım bir programda bana lazım olmuştu.

sisteminizde winrar kurulu ise winrar klsöründeki unrar.exe dosyasını c: içine kopyalayın

ve komutlar aşağıdaki gibidir. Programların dos kumutunu kullanarak çalışıyor. Tamamamen kendi yapımımdır..

Winrar klasöründeki bazı dosla çalışan dosyaları dos komutlarını çalıştırıp biraz incelersiniz kodları daha da geliştirebilirsiniz...

ÇALIŞMALARINIZDA BAŞARILAR DİLERİM.

}

unit UMainFrm;

interface

uses

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

Dialogs, StdCtrls;

type

TForm1 = class(TForm)

Memo1: TMemo;

OpenDialog1: TOpenDialog;

Button1: TButton;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);

begin

if OpenDialog1.Execute then

begin

Memo1.Lines.Clear;

Memo1.Lines.add('Unrar e '+OpenDialog1.FileName);

Memo1.Lines.SaveToFile('c:ac.bat');

WinExec('c:ac.bat cmd',SW_MINIMIZE);

DeleteFile('c:ac.bat');

end;

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

Rar Extract

{ Mehmet KOCABAŞ

e-mail:mehmetkocabas2@hotmail.com

}

{

slm Arkadaşlar aşağıdaki kod;

rar dosyalarının arşivden çıkartılmasıdır.

Yaptığım bir programda bana lazım olmuştu.

sisteminizde winrar kurulu ise winrar klsöründeki unrar.exe dosyasını c: içine kopyalayın

ve komutlar aşağıdaki gibidir. Programların dos kumutunu kullanarak çalışıyor. Tamamamen kendi yapımımdır..

Winrar klasöründeki bazı dosla çalışan dosyaları dos komutlarını çalıştırıp biraz incelersiniz kodları daha da geliştirebilirsiniz...

ÇALIŞMALARINIZDA BAŞARILAR DİLERİM.

}

unit UMainFrm;

interface

uses

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

Dialogs, StdCtrls;

type

TForm1 = class(TForm)

Memo1: TMemo;

OpenDialog1: TOpenDialog;

Button1: TButton;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);

begin

if OpenDialog1.Execute then

begin

Memo1.Lines.Clear;

Memo1.Lines.add('Unrar e '+OpenDialog1.FileName);

Memo1.Lines.SaveToFile('c:ac.bat');

WinExec('c:ac.bat cmd',SW_MINIMIZE);

DeleteFile('c:ac.bat');

end;

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

Rar Extract

{ Mehmet KOCABAŞ

e-mail:mehmetkocabas2@hotmail.com

}

{

slm Arkadaşlar aşağıdaki kod;

rar dosyalarının arşivden çıkartılmasıdır.

Yaptığım bir programda bana lazım olmuştu.

sisteminizde winrar kurulu ise winrar klsöründeki unrar.exe dosyasını c: içine kopyalayın

ve komutlar aşağıdaki gibidir. Programların dos kumutunu kullanarak çalışıyor. Tamamamen kendi yapımımdır..

Winrar klasöründeki bazı dosla çalışan dosyaları dos komutlarını çalıştırıp biraz incelersiniz kodları daha da geliştirebilirsiniz...

ÇALIŞMALARINIZDA BAŞARILAR DİLERİM.

}

unit UMainFrm;

interface

uses

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

Dialogs, StdCtrls;

type

TForm1 = class(TForm)

Memo1: TMemo;

OpenDialog1: TOpenDialog;

Button1: TButton;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);

begin

if OpenDialog1.Execute then

begin

Memo1.Lines.Clear;

Memo1.Lines.add('Unrar e '+OpenDialog1.FileName);

Memo1.Lines.SaveToFile('c:ac.bat');

WinExec('c:ac.bat cmd',SW_MINIMIZE);

DeleteFile('c:ac.bat');

end;

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

Rar Extract

{ Mehmet KOCABAŞ

e-mail:mehmetkocabas2@hotmail.com

}

{

slm Arkadaşlar aşağıdaki kod;

rar dosyalarının arşivden çıkartılmasıdır.

Yaptığım bir programda bana lazım olmuştu.

sisteminizde winrar kurulu ise winrar klsöründeki unrar.exe dosyasını c: içine kopyalayın

ve komutlar aşağıdaki gibidir. Programların dos kumutunu kullanarak çalışıyor. Tamamamen kendi yapımımdır..

Winrar klasöründeki bazı dosla çalışan dosyaları dos komutlarını çalıştırıp biraz incelersiniz kodları daha da geliştirebilirsiniz...

ÇALIŞMALARINIZDA BAŞARILAR DİLERİM.

}

unit UMainFrm;

interface

uses

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

Dialogs, StdCtrls;

type

TForm1 = class(TForm)

Memo1: TMemo;

OpenDialog1: TOpenDialog;

Button1: TButton;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);

begin

if OpenDialog1.Execute then

begin

Memo1.Lines.Clear;

Memo1.Lines.add('Unrar e '+OpenDialog1.FileName);

Memo1.Lines.SaveToFile('c:ac.bat');

WinExec('c:ac.bat cmd',SW_MINIMIZE);

DeleteFile('c:ac.bat');

end;

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

Rar Extract

{ Mehmet KOCABAŞ

e-mail:mehmetkocabas2@hotmail.com

}

{

slm Arkadaşlar aşağıdaki kod;

rar dosyalarının arşivden çıkartılmasıdır.

Yaptığım bir programda bana lazım olmuştu.

sisteminizde winrar kurulu ise winrar klsöründeki unrar.exe dosyasını c: içine kopyalayın

ve komutlar aşağıdaki gibidir. Programların dos kumutunu kullanarak çalışıyor. Tamamamen kendi yapımımdır..

Winrar klasöründeki bazı dosla çalışan dosyaları dos komutlarını çalıştırıp biraz incelersiniz kodları daha da geliştirebilirsiniz...

ÇALIŞMALARINIZDA BAŞARILAR DİLERİM.

}

unit UMainFrm;

interface

uses

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

Dialogs, StdCtrls;

type

TForm1 = class(TForm)

Memo1: TMemo;

OpenDialog1: TOpenDialog;

Button1: TButton;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);

begin

if OpenDialog1.Execute then

begin

Memo1.Lines.Clear;

Memo1.Lines.add('Unrar e '+OpenDialog1.FileName);

Memo1.Lines.SaveToFile('c:ac.bat');

WinExec('c:ac.bat cmd',SW_MINIMIZE);

DeleteFile('c:ac.bat');

end;

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

Rar Extract

{ Mehmet KOCABAŞ

e-mail:mehmetkocabas2@hotmail.com

}

{

slm Arkadaşlar aşağıdaki kod;

rar dosyalarının arşivden çıkartılmasıdır.

Yaptığım bir programda bana lazım olmuştu.

sisteminizde winrar kurulu ise winrar klsöründeki unrar.exe dosyasını c: içine kopyalayın

ve komutlar aşağıdaki gibidir. Programların dos kumutunu kullanarak çalışıyor. Tamamamen kendi yapımımdır..

Winrar klasöründeki bazı dosla çalışan dosyaları dos komutlarını çalıştırıp biraz incelersiniz kodları daha da geliştirebilirsiniz...

ÇALIŞMALARINIZDA BAŞARILAR DİLERİM.

}

unit UMainFrm;

interface

uses

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

Dialogs, StdCtrls;

type

TForm1 = class(TForm)

Memo1: TMemo;

OpenDialog1: TOpenDialog;

Button1: TButton;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);

begin

if OpenDialog1.Execute then

begin

Memo1.Lines.Clear;

Memo1.Lines.add('Unrar e '+OpenDialog1.FileName);

Memo1.Lines.SaveToFile('c:ac.bat');

WinExec('c:ac.bat cmd',SW_MINIMIZE);

DeleteFile('c:ac.bat');

end;

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

Rar Extract

{ Mehmet KOCABAŞ

e-mail:mehmetkocabas2@hotmail.com

}

{

slm Arkadaşlar aşağıdaki kod;

rar dosyalarının arşivden çıkartılmasıdır.

Yaptığım bir programda bana lazım olmuştu.

sisteminizde winrar kurulu ise winrar klsöründeki unrar.exe dosyasını c: içine kopyalayın

ve komutlar aşağıdaki gibidir. Programların dos kumutunu kullanarak çalışıyor. Tamamamen kendi yapımımdır..

Winrar klasöründeki bazı dosla çalışan dosyaları dos komutlarını çalıştırıp biraz incelersiniz kodları daha da geliştirebilirsiniz...

ÇALIŞMALARINIZDA BAŞARILAR DİLERİM.

}

unit UMainFrm;

interface

uses

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

Dialogs, StdCtrls;

type

TForm1 = class(TForm)

Memo1: TMemo;

OpenDialog1: TOpenDialog;

Button1: TButton;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);

begin

if OpenDialog1.Execute then

begin

Memo1.Lines.Clear;

Memo1.Lines.add('Unrar e '+OpenDialog1.FileName);

Memo1.Lines.SaveToFile('c:ac.bat');

WinExec('c:ac.bat cmd',SW_MINIMIZE);

DeleteFile('c:ac.bat');

end;

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

Rar Extract

{ Mehmet KOCABAş

e-mail:mehmetkocabas2@hotmail.com

}

{

slm Arkadaşlar aşağıdaki kod;

rar dosyalarının arşivden çıkartılmasıdır.

Yaptığım bir programda bana lazım olmuştu.

sisteminizde winrar kurulu ise winrar klsöründeki unrar.exe dosyasını c: içine kopyalayın

ve komutlar aşağıdaki gibidir. Programların dos kumutunu kullanarak çalışıyor. Tamamamen kendi yapımımdır..

Winrar klasöründeki bazı dosla çalışan dosyaları dos komutlarını çalıştırıp biraz incelersiniz kodları daha da geliştirebilirsiniz...

ÇALIŞMALARINIZDA BAŞARILAR DİLERİM.

}

unit UMainFrm;

interface

uses

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

Dialogs, StdCtrls;

type

TForm1 = class(TForm)

Memo1: TMemo;

OpenDialog1: TOpenDialog;

Button1: TButton;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);

begin

if OpenDialog1.Execute then

begin

Memo1.Lines.Clear;

Memo1.Lines.add('Unrar e '+OpenDialog1.FileName);

Memo1.Lines.SaveToFile('c:ac.bat');

WinExec('c:ac.bat cmd',SW_MINIMIZE);

DeleteFile('c:ac.bat');

end;

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

Rar Extract

{ Mehmet KOCABAş

e-mail:mehmetkocabas2@hotmail.com

}

{

slm Arkadaşlar aşağıdaki kod;

rar dosyalarının arşivden çıkartılmasıdır.

Yaptığım bir programda bana lazım olmuştu.

sisteminizde winrar kurulu ise winrar klsöründeki unrar.exe dosyasını c: içine kopyalayın

ve komutlar aşağıdaki gibidir. Programların dos kumutunu kullanarak çalışıyor. Tamamamen kendi yapımımdır..

Winrar klasöründeki bazı dosla çalışan dosyaları dos komutlarını çalıştırıp biraz incelersiniz kodları daha da geliştirebilirsiniz...

ÇALIŞMALARINIZDA BAŞARILAR DİLERİM.

}

unit UMainFrm;

interface

uses

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

Dialogs, StdCtrls;

type

TForm1 = class(TForm)

Memo1: TMemo;

OpenDialog1: TOpenDialog;

Button1: TButton;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);

begin

if OpenDialog1.Execute then

begin

Memo1.Lines.Clear;

Memo1.Lines.add('Unrar e '+OpenDialog1.FileName);

Memo1.Lines.SaveToFile('c:ac.bat');

WinExec('c:ac.bat cmd',SW_MINIMIZE);

DeleteFile('c:ac.bat');

end;

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

ado ile resim kaydetme

//delphiturkiye.com dan alıntıdır

//var bloğunda tanımlanacaklar'

var

jpgresim:Tjpegimage;

blobalan:Tadoblobstream;

if not FieldByName('resim').Isnull then

begin

blobalan:=TADOBlobStream.Create(TGraphicField(FieldByName('resim')), bmread);

jpgresim:=tjpegimage.create;

jpgresim.LoadFromStream(blobalan);

Image1.Picture.Assign(jpgresim);

jpgresim.free;

blobalan.free;

end;

veritabanına yazmak için ise

Kod:

var

jpgresim: Tjpegimage;

blobalan: Tadoblobstream;

hafiza: Tmemorystream;

;

with adresdefteriset do

begin

Append;

FieldValues['adi']:=edit1.text;

FieldValues['soyadi']:=edit2.text;

jpgresim:=TJpegImage.Create;

jpgresim.assign(Image1.Picture.Bitmap);

hafiza:=TMemoryStream.Create;

jpgresim.savetostream(hafiza);

blobalan:=TADOBlobStream.Create(TGraphicField(FieldByName('resim')), bmWrite);

blobalan.copyfrom(hafiza,0);

blobalan.free;

hafiza.free;

jpgresim.free;

post;

end;

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

ado ile resim kaydetme

//delphiturkiye.com dan alıntıdır

//var bloğunda tanımlanacaklar'

var

jpgresim:Tjpegimage;

blobalan:Tadoblobstream;

if not FieldByName('resim').Isnull then

begin

blobalan:=TADOBlobStream.Create(TGraphicField(FieldByName('resim')), bmread);

jpgresim:=tjpegimage.create;

jpgresim.LoadFromStream(blobalan);

Image1.Picture.Assign(jpgresim);

jpgresim.free;

blobalan.free;

end;

veritabanına yazmak için ise

Kod:

var

jpgresim: Tjpegimage;

blobalan: Tadoblobstream;

hafiza: Tmemorystream;

;

with adresdefteriset do

begin

Append;

FieldValues['adi']:=edit1.text;

FieldValues['soyadi']:=edit2.text;

jpgresim:=TJpegImage.Create;

jpgresim.assign(Image1.Picture.Bitmap);

hafiza:=TMemoryStream.Create;

jpgresim.savetostream(hafiza);

blobalan:=TADOBlobStream.Create(TGraphicField(FieldByName('resim')), bmWrite);

blobalan.copyfrom(hafiza,0);

blobalan.free;

hafiza.free;

jpgresim.free;

post;

end;

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

sql serverda database adresini almak

select * from sysfiles

yada

sp_helpdb databasename

sonucta filename dite field cıkıyor ordan hem log hemde

mdf dosyasını alabilirsiniz

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

sql serverda database adresini almak

select * from sysfiles

yada

sp_helpdb databasename

sonucta filename dite field cıkıyor ordan hem log hemde

mdf dosyasını alabilirsiniz

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

OpenPictureDialog ve SavePictureDialog Kullanımı

OpenPictureDialog Kullanımı :

//------------------------------------------------------------------------

{

if (OpenPictureDialog1->Execute())

{

Image1->Picture->LoadFromFile (OpenPicture1Dialog1->FileName);

Image1->Refresh();ShowMessage ("Resim Açıldı !");

}

else

{

ShowMessage ("İşlem İptal edildi");return;

}

//------------------------------------------------------------------------

SavePictureDialog Kullanımı :

//------------------------------------------------------------------------

{

if (SavePictureDialog1->Execute())

{

Image1->Picture->SaveToFile (SavePicture1Dialog1->FileName);

Image1->Refresh();ShowMessage ("Resim Kaydedildi !");

}

else

{

ShowMessage ("İşlem İptal edildi");return;

}

C++ Builder - .....................................

OpenPictureDialog ve SavePictureDialog Kullanımı

OpenPictureDialog Kullanımı :

//------------------------------------------------------------------------

{

if (OpenPictureDialog1->Execute())

{

Image1->Picture->LoadFromFile (OpenPicture1Dialog1->FileName);

Image1->Refresh();ShowMessage ("Resim Açıldı !");

}

else

{

ShowMessage ("İşlem İptal edildi");return;

}

//------------------------------------------------------------------------

SavePictureDialog Kullanımı :

//------------------------------------------------------------------------

{

if (SavePictureDialog1->Execute())

{

Image1->Picture->SaveToFile (SavePicture1Dialog1->FileName);

Image1->Refresh();ShowMessage ("Resim Kaydedildi !");

}

else

{

ShowMessage ("İşlem İptal edildi");return;

}

C++ Builder - .....................................

OpenPictureDialog ve SavePictureDialog Kullanımı

OpenPictureDialog Kullanımı :

//------------------------------------------------------------------------

{

if (OpenPictureDialog1->Execute())

{

Image1->Picture->LoadFromFile (OpenPicture1Dialog1->FileName);

Image1->Refresh();ShowMessage ("Resim Açıldı !");

}

else

{

ShowMessage ("İşlem İptal edildi");return;

}

//------------------------------------------------------------------------

SavePictureDialog Kullanımı :

//------------------------------------------------------------------------

{

if (SavePictureDialog1->Execute())

{

Image1->Picture->SaveToFile (SavePicture1Dialog1->FileName);

Image1->Refresh();ShowMessage ("Resim Kaydedildi !");

}

else

{

ShowMessage ("İşlem İptal edildi");return;

}

C++ Builder - .....................................

OpenPictureDialog ve SavePictureDialog Kullanımı

OpenPictureDialog Kullanımı :

//------------------------------------------------------------------------

{

if (OpenPictureDialog1->Execute())

{

Image1->Picture->LoadFromFile (OpenPicture1Dialog1->FileName);

Image1->Refresh();ShowMessage ("Resim Açıldı !");

}

else

{

ShowMessage ("İşlem İptal edildi");return;

}

//------------------------------------------------------------------------

SavePictureDialog Kullanımı :

//------------------------------------------------------------------------

{

if (SavePictureDialog1->Execute())

{

Image1->Picture->SaveToFile (SavePicture1Dialog1->FileName);

Image1->Refresh();ShowMessage ("Resim Kaydedildi !");

}

else

{

ShowMessage ("İşlem İptal edildi");return;

}

C++ Builder - .....................................

HexToInt

Function HexToInt(HexNumber:string):Integer;

var

CharOne,

CharTwo : Char;

CharOne2,

CharTwo2 : integer;

begin

CharOne2:=0;

CharTwo2:=0;

HexNumber:=UpperCase(HexNumber);

If Length(HexNumber) > 1 Then

begin

CharOne := HexNumber[1];

CharTwo := HexNumber[2];

If IsNumeric(CharOne) Then

CharOne2 := strtoint(CharOne) * 16

Else

Case CharOne of

'A': CharOne2 := 10 * 16;

'B': CharOne2 := 11 * 16;

'C': CharOne2 := 12 * 16;

'D': CharOne2 := 13 * 16;

'E': CharOne2 := 14 * 16;

'F': CharOne2 := 15 * 16;

End;

If IsNumeric(CharTwo) Then

CharTwo2 := strtoint(CharTwo)

Else

Case CharTwo of

'A': CharTwo2 := 10;

'B': CharTwo2 := 11;

'C': CharTwo2 := 12;

'D': CharTwo2 := 13;

'E': CharTwo2 := 14;

'F': CharTwo2 := 15;

End;

End

Else //eğer tek haneli bir hex ise

begin

if length(HexNumber)>0 then

begin

CharOne := HexNumber[1];

If IsNumeric(CharOne) Then

CharOne2 := strtoint(CharOne)

Else

Case CharOne of

#0:CharOne2 := 0;

#1:CharOne2 := 1;

#2:CharOne2 := 2;

#3:CharOne2 := 3;

#4:CharOne2 := 4;

#5:CharOne2 := 5;

#6:CharOne2 := 6;

#7:CharOne2 := 7;

#8:CharOne2 := 8;

#9:CharOne2 := 9;

'A': CharOne2 := 10;

'B': CharOne2 := 11;

'C': CharOne2 := 12;

'D': CharOne2 := 13;

'E': CharOne2 := 14;

'F': CharOne2 := 15;

End;

end;

End;

HexToInt := CharOne2 + CharTwo2

End;

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

HexToInt

Function HexToInt(HexNumber:string):Integer;

var

CharOne,

CharTwo : Char;

CharOne2,

CharTwo2 : integer;

begin

CharOne2:=0;

CharTwo2:=0;

HexNumber:=UpperCase(HexNumber);

If Length(HexNumber) > 1 Then

begin

CharOne := HexNumber[1];

CharTwo := HexNumber[2];

If IsNumeric(CharOne) Then

CharOne2 := strtoint(CharOne) * 16

Else

Case CharOne of

'A': CharOne2 := 10 * 16;

'B': CharOne2 := 11 * 16;

'C': CharOne2 := 12 * 16;

'D': CharOne2 := 13 * 16;

'E': CharOne2 := 14 * 16;

'F': CharOne2 := 15 * 16;

End;

If IsNumeric(CharTwo) Then

CharTwo2 := strtoint(CharTwo)

Else

Case CharTwo of

'A': CharTwo2 := 10;

'B': CharTwo2 := 11;

'C': CharTwo2 := 12;

'D': CharTwo2 := 13;

'E': CharTwo2 := 14;

'F': CharTwo2 := 15;

End;

End

Else //eğer tek haneli bir hex ise

begin

if length(HexNumber)>0 then

begin

CharOne := HexNumber[1];

If IsNumeric(CharOne) Then

CharOne2 := strtoint(CharOne)

Else

Case CharOne of

#0:CharOne2 := 0;

#1:CharOne2 := 1;

#2:CharOne2 := 2;

#3:CharOne2 := 3;

#4:CharOne2 := 4;

#5:CharOne2 := 5;

#6:CharOne2 := 6;

#7:CharOne2 := 7;

#8:CharOne2 := 8;

#9:CharOne2 := 9;

'A': CharOne2 := 10;

'B': CharOne2 := 11;

'C': CharOne2 := 12;

'D': CharOne2 := 13;

'E': CharOne2 := 14;

'F': CharOne2 := 15;

End;

end;

End;

HexToInt := CharOne2 + CharTwo2

End;

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

StrToChar

function StrToChar(deger:string):Char;

var cikis:Char;

begin

cikis:=deger[1];

result:=cikis;

end;

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

StrToChar

function StrToChar(deger:string):Char;

var cikis:Char;

begin

cikis:=deger[1];

result:=cikis;

end;

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

www.east-software.com

işte size yeni bir yazılım sitesi inanın bayılacaksınız türkiyede

ilkleri gerçekleştirecek site

www.east-software.com

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

www.east-software.com

işte size yeni bir yazılım sitesi inanın bayılacaksınız türkiyede

ilkleri gerçekleştirecek site

www.east-software.com

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

Access dosyasından alan tanımlarını okumak (tam)

uses ADOInt;//<- bir öncekinde bunu belirtmeyi unuttum.. onu silin, kalabalık etmesin

//Aslında destekleyen diğer sürücülerden de okuma yapılabilir. Yeterki ADO bağlantısı yapılsın

procedure TabloAlanTanimlariniOku(const Baglanti:TADOConnection;const TabloAdi:String;const Liste:TStrings);

//const OkunacakBilgiTanimi = 'COLUMN_NAME';//Bu değer kullanılırsa alan isimleri okunur

const OkunacakBilgiTanimi = 'DESCRIPTION';//malum, alanların tanımlama bilgilerini okuyoruz

var Alanlar: _Recordset;

begin

if Assigned(Liste) and Assigned(Baglanti) and Baglanti.Connected then begin

Alanlar := Baglanti.ConnectionObject.OpenSchema(adSchemaColumns,

VarArrayOf([Null, Null, TabloAdi]), EmptyParam);

with Liste do begin

BeginUpdate;

try

Clear;

while not Alanlar.EOF do begin

Add(VarToStr(Alanlar.Fields[OkunacakBilgiTanimi].Value));

{Eğer alan sıralaması uygun değilse bunu Add satırının yerine aşağıdaki Add

satırını yazarak giderebilirsiniz. Çünkü alan ismiyle birlikte listeye alınır.

Add(VarToStr(Alanlar.Fields['COLUMN_NAME'].Value)+'='+VarToStr(Alanlar.Fields[OkunacakBilgiTanimi].Value));}

Alanlar.MoveNext;

end;

finally

EndUpdate;

end;

//kullanımı

TabloAlanTanimlariniOku(ADOConnection1,'Musteri',ListBox1.Items);

//Şeklinde olursa tanımlar listbox içerisine doldurulur..

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

Access dosyasından alan tanımlarını okumak (tam)

uses ADOInt;//<- bir öncekinde bunu belirtmeyi unuttum.. onu silin, kalabalık etmesin

//Aslında destekleyen diğer sürücülerden de okuma yapılabilir. Yeterki ADO bağlantısı yapılsın

procedure TabloAlanTanimlariniOku(const Baglanti:TADOConnection;const TabloAdi:String;const Liste:TStrings);

//const OkunacakBilgiTanimi = 'COLUMN_NAME';//Bu değer kullanılırsa alan isimleri okunur

const OkunacakBilgiTanimi = 'DESCRIPTION';//malum, alanların tanımlama bilgilerini okuyoruz

var Alanlar: _Recordset;

begin

if Assigned(Liste) and Assigned(Baglanti) and Baglanti.Connected then begin

Alanlar := Baglanti.ConnectionObject.OpenSchema(adSchemaColumns,

VarArrayOf([Null, Null, TabloAdi]), EmptyParam);

with Liste do begin

BeginUpdate;

try

Clear;

while not Alanlar.EOF do begin

Add(VarToStr(Alanlar.Fields[OkunacakBilgiTanimi].Value));

{Eğer alan sıralaması uygun değilse bunu Add satırının yerine aşağıdaki Add

satırını yazarak giderebilirsiniz. Çünkü alan ismiyle birlikte listeye alınır.

Add(VarToStr(Alanlar.Fields['COLUMN_NAME'].Value)+'='+VarToStr(Alanlar.Fields[OkunacakBilgiTanimi].Value));}

Alanlar.MoveNext;

end;

finally

EndUpdate;

end;

//kullanımı

TabloAlanTanimlariniOku(ADOConnection1,'Musteri',ListBox1.Items);

//Şeklinde olursa tanımlar listbox içerisine doldurulur..

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

Access dosyasından alan tanımlarını okumak

//Aslında destekleyen diğer sürücülerden de okuma yapılabilir. Yeterki ADO bağlantısı yapılsın

procedure TabloAlanTanimlariniOku(const Baglanti:TADOConnection;const TabloAdi:String;const Liste:TStrings);

//const OkunacakBilgiTanimi = 'COLUMN_NAME';//Bu değer kullanılırsa alan isimleri okunur

const OkunacakBilgiTanimi = 'DESCRIPTION';//malum, alanların tanımlama bilgilerini okuyoruz

var Alanlar: _Recordset;

begin

if Assigned(Liste) and Assigned(Baglanti) and Baglanti.Connected then begin

Alanlar := Baglanti.ConnectionObject.OpenSchema(adSchemaColumns,

VarArrayOf([Null, Null, TabloAdi]), EmptyParam);

with Liste do begin

BeginUpdate;

try

Clear;

while not Alanlar.EOF do begin

Add(VarToStr(Alanlar.Fields[OkunacakBilgiTanimi].Value));

{Eğer alan sıralaması uygun değilse bunu Add satırının yerine aşağıdaki Add

satırını yazarak giderebilirsiniz. Çünkü alan ismiyle birlikte listeye alınır.

Add(VarToStr(Alanlar.Fields['COLUMN_NAME'].Value)+'='+VarToStr(Alanlar.Fields[OkunacakBilgiTanimi].Value));}

Alanlar.MoveNext;

end;

finally

EndUpdate;

end;

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

Access dosyasından alan tanımlarını okumak

//Aslında destekleyen diğer sürücülerden de okuma yapılabilir. Yeterki ADO bağlantısı yapılsın

procedure TabloAlanTanimlariniOku(const Baglanti:TADOConnection;const TabloAdi:String;const Liste:TStrings);

//const OkunacakBilgiTanimi = 'COLUMN_NAME';//Bu değer kullanılırsa alan isimleri okunur

const OkunacakBilgiTanimi = 'DESCRIPTION';//malum, alanların tanımlama bilgilerini okuyoruz

var Alanlar: _Recordset;

begin

if Assigned(Liste) and Assigned(Baglanti) and Baglanti.Connected then begin

Alanlar := Baglanti.ConnectionObject.OpenSchema(adSchemaColumns,

VarArrayOf([Null, Null, TabloAdi]), EmptyParam);

with Liste do begin

BeginUpdate;

try

Clear;

while not Alanlar.EOF do begin

Add(VarToStr(Alanlar.Fields[OkunacakBilgiTanimi].Value));

{Eğer alan sıralaması uygun değilse bunu Add satırının yerine aşağıdaki Add

satırını yazarak giderebilirsiniz. Çünkü alan ismiyle birlikte listeye alınır.

Add(VarToStr(Alanlar.Fields['COLUMN_NAME'].Value)+'='+VarToStr(Alanlar.Fields[OkunacakBilgiTanimi].Value));}

Alanlar.MoveNext;

end;

finally

EndUpdate;

end;

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

Sanal Tik Programi

istediğimiz bir programın (mesela bir eğitim CD'si gibi)

istediğimiz yerine

belli sürelerde sol veya sağ tık sinyali gönderebiliriz

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

Win+X tuşu ile de durdurabiliyoruz.

Programın son halini

http://www.yunus.projesi.com dan

indirebilirsiniz

aynı siteden MEGEP programlama kitapcıkları (modül) indirebilirsiniz.

yorumlarınızı beklerim!

http://sourceforge.net/projects/yunus

unit Unit1;

interface

uses

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

Dialogs, ExtCtrls, StdCtrls, Spin, ToolWin, ComCtrls, Buttons, inifiles;

type

TForm1 = class(TForm)

Timer1: TTimer;

Memo1: TMemo;

CoolBar1: TCoolBar;

SpinEdit1: TSpinEdit;

Button2: TButton;

Button1: TButton;

Panel1: TPanel;

LabeledEdit1: TLabeledEdit;

LabeledEdit2: TLabeledEdit;

LabeledEdit3: TLabeledEdit;

ComboBox1: TComboBox;

procedure Timer1Timer(Sender: TObject);

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

Shift: TShiftState);

procedure Button1Click(Sender: TObject);

procedure Button2Click(Sender: TObject);

procedure SpinEdit1Change(Sender: TObject);

procedure FormDestroy(Sender: TObject);

procedure FormCreate(Sender: TObject);

procedure BitBtn1Click(Sender: TObject);

procedure ayarkaydet;

procedure ayaroku;

private

{ Private declarations }

public

procedure WMHotKey(var Msg2: TWMHotKey); message WM_HOTKEY;

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

procedure Tform1.WMHotKey(var Msg2: TWMHotKey);

begin

if Msg2.HotKey = 1 then

begin

form1.Button2Click(self);

end;

procedure TForm1.Timer1Timer(Sender: TObject);

begin

if FindWindow(nil, pchar(form1.LabeledEdit1.Text)) <> 0 then

begin

caption:='SANAL TIKLAMA 1.0 - VAR';

Windows.ShowWindow(FindWindow(nil,PChar(form1.LabeledEdit1.Text)),SW_SHOW);

SetCursorPos(strtoint(form1.LabeledEdit2.Text),strtoint(form1.LabeledEdit3.Text));

case ComboBox1.ItemIndex of

begin

mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0);

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

end;

begin

mouse_event(MOUSEEVENTF_RIGHTDOWN, 0, 0, 0, 0);

mouse_event(MOUSEEVENTF_RIGHTUP, 0, 0, 0, 0);

end;

begin

mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0);

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

mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0);

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

end;

end else begin

caption:='SANAL TIKLAMA 1.0 - YOK';

timer1.Enabled:=false;

button2.Caption:='&Başla';

end;

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

Shift: TShiftState);

begin

if key=27 then close

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

close;

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

timer1.Enabled:=not(timer1.Enabled);

if timer1.Enabled then

Button2.Caption:='&Dur'

else

Button2.Caption:='&Başla';

end;

procedure TForm1.SpinEdit1Change(Sender: TObject);

begin

timer1.Interval:=SpinEdit1.Value

end;

procedure TForm1.FormDestroy(Sender: TObject);

begin

ayarkaydet;

UnRegisterHotKey(Handle,1);

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

if not RegisterHotKey(Handle, 1, MOD_WIN, ord('X')) then

begin

ShowMessage('WIN+X başka program tarafından kullanılıyor.');

end;

ayaroku;

end;

procedure TForm1.BitBtn1Click(Sender: TObject);

begin

ayarkaydet;

end;

procedure TForm1.ayarkaydet;

var

a:TIniFile;

begin

a:=TIniFile.Create(ExtractFilePath(Application.ExeName)+'ayar.ini');

a.WriteString('SanalTik','Hedef',LabeledEdit1.Text);

a.WriteString('SanalTik','X',LabeledEdit2.Text);

a.WriteString('SanalTik','Y',LabeledEdit3.Text);

a.WriteInteger('SanalTik','Zaman',timer1.Interval);

a.WriteInteger('SanalTik','Fare',combobox1.ItemIndex);

a.UpdateFile;

a.Free;

end;

procedure TForm1.ayaroku;

var

a:TIniFile;

begin

if fileexists(ExtractFilePath(Application.ExeName)+'ayar.ini') then begin

a:=TIniFile.Create(ExtractFilePath(Application.ExeName)+'ayar.ini');

LabeledEdit1.Text:=a.ReadString('SanalTik','Hedef','Macromedia Flash Player 7');

LabeledEdit2.Text:=a.ReadString('SanalTik','X','590');

LabeledEdit3.Text:=a.ReadString('SanalTik','Y','610');

SpinEdit1.Value:=a.ReadInteger('SanalTik','Zaman',1000);

ComboBox1.ItemIndex:=a.ReadInteger('SanalTik','Fare',0);

a.Free;

end;

end.

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

Sanal Tik Programi

istediğimiz bir programın (mesela bir eğitim CD'si gibi)

istediğimiz yerine

belli sürelerde sol veya sağ tık sinyali gönderebiliriz

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

Win+X tuşu ile de durdurabiliyoruz.

Programın son halini

http://www.yunus.projesi.com dan

indirebilirsiniz

aynı siteden MEGEP programlama kitapcıkları (modül) indirebilirsiniz.

yorumlarınızı beklerim!

http://sourceforge.net/projects/yunus

unit Unit1;

interface

uses

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

Dialogs, ExtCtrls, StdCtrls, Spin, ToolWin, ComCtrls, Buttons, inifiles;

type

TForm1 = class(TForm)

Timer1: TTimer;

Memo1: TMemo;

CoolBar1: TCoolBar;

SpinEdit1: TSpinEdit;

Button2: TButton;

Button1: TButton;

Panel1: TPanel;

LabeledEdit1: TLabeledEdit;

LabeledEdit2: TLabeledEdit;

LabeledEdit3: TLabeledEdit;

ComboBox1: TComboBox;

procedure Timer1Timer(Sender: TObject);

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

Shift: TShiftState);

procedure Button1Click(Sender: TObject);

procedure Button2Click(Sender: TObject);

procedure SpinEdit1Change(Sender: TObject);

procedure FormDestroy(Sender: TObject);

procedure FormCreate(Sender: TObject);

procedure BitBtn1Click(Sender: TObject);

procedure ayarkaydet;

procedure ayaroku;

private

{ Private declarations }

public

procedure WMHotKey(var Msg2: TWMHotKey); message WM_HOTKEY;

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

procedure Tform1.WMHotKey(var Msg2: TWMHotKey);

begin

if Msg2.HotKey = 1 then

begin

form1.Button2Click(self);

end;

procedure TForm1.Timer1Timer(Sender: TObject);

begin

if FindWindow(nil, pchar(form1.LabeledEdit1.Text)) <> 0 then

begin

caption:='SANAL TIKLAMA 1.0 - VAR';

Windows.ShowWindow(FindWindow(nil,PChar(form1.LabeledEdit1.Text)),SW_SHOW);

SetCursorPos(strtoint(form1.LabeledEdit2.Text),strtoint(form1.LabeledEdit3.Text));

case ComboBox1.ItemIndex of

begin

mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0);

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

end;

begin

mouse_event(MOUSEEVENTF_RIGHTDOWN, 0, 0, 0, 0);

mouse_event(MOUSEEVENTF_RIGHTUP, 0, 0, 0, 0);

end;

begin

mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0);

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

mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0);

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

end;

end else begin

caption:='SANAL TIKLAMA 1.0 - YOK';

timer1.Enabled:=false;

button2.Caption:='&Başla';

end;

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

Shift: TShiftState);

begin

if key=27 then close

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

close;

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

timer1.Enabled:=not(timer1.Enabled);

if timer1.Enabled then

Button2.Caption:='&Dur'

else

Button2.Caption:='&Başla';

end;

procedure TForm1.SpinEdit1Change(Sender: TObject);

begin

timer1.Interval:=SpinEdit1.Value

end;

procedure TForm1.FormDestroy(Sender: TObject);

begin

ayarkaydet;

UnRegisterHotKey(Handle,1);

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

if not RegisterHotKey(Handle, 1, MOD_WIN, ord('X')) then

begin

ShowMessage('WIN+X başka program tarafından kullanılıyor.');

end;

ayaroku;

end;

procedure TForm1.BitBtn1Click(Sender: TObject);

begin

ayarkaydet;

end;

procedure TForm1.ayarkaydet;

var

a:TIniFile;

begin

a:=TIniFile.Create(ExtractFilePath(Application.ExeName)+'ayar.ini');

a.WriteString('SanalTik','Hedef',LabeledEdit1.Text);

a.WriteString('SanalTik','X',LabeledEdit2.Text);

a.WriteString('SanalTik','Y',LabeledEdit3.Text);

a.WriteInteger('SanalTik','Zaman',timer1.Interval);

a.WriteInteger('SanalTik','Fare',combobox1.ItemIndex);

a.UpdateFile;

a.Free;

end;

procedure TForm1.ayaroku;

var

a:TIniFile;

begin

if fileexists(ExtractFilePath(Application.ExeName)+'ayar.ini') then begin

a:=TIniFile.Create(ExtractFilePath(Application.ExeName)+'ayar.ini');

LabeledEdit1.Text:=a.ReadString('SanalTik','Hedef','Macromedia Flash Player 7');

LabeledEdit2.Text:=a.ReadString('SanalTik','X','590');

LabeledEdit3.Text:=a.ReadString('SanalTik','Y','610');

SpinEdit1.Value:=a.ReadInteger('SanalTik','Zaman',1000);

ComboBox1.ItemIndex:=a.ReadInteger('SanalTik','Fare',0);

a.Free;

end;

end.

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

İşlemcim nekadar cycle lık işlem yapıyor.

İşlemcinin belirtilen sürede nedakarlık işlem yapabildiğini bulmak için:

Celeron 2.4 Ghz işlemcide saniyede 2.4 milyar cycle işlem yapıyor.

İşlemcinin hızını bulmak için kullanılabilir.

İşlemci her komut için farklı sayıda cycle lık iş yapar.

Böylece eğer komutun kaç cycle gerektirdiğini biliyorsanız kodunuzun ne kadar hızlı

çalışacağını da hesaplayabilirsiniz.

FUNCTION GetCycleCount: Int64; // D4-D5

ASM

DB 0FH

DB 031H

END;

procedure TForm1.Button1Click(Sender: TObject);

VAR

Start: Int64; // D4-D5

Stop : Int64;

begin

Start := GetCycleCount;

Sleep(1000); // 1000 milliseconds = 1 seconds

Stop := GetCycleCount;

ShowMessage( IntToStr(Stop-Start) )

end;

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

İşlemcim nekadar cycle lık işlem yapıyor.

İşlemcinin belirtilen sürede nedakarlık işlem yapabildiğini bulmak için:

Celeron 2.4 Ghz işlemcide saniyede 2.4 milyar cycle işlem yapıyor.

İşlemcinin hızını bulmak için kullanılabilir.

İşlemci her komut için farklı sayıda cycle lık iş yapar.

Böylece eğer komutun kaç cycle gerektirdiğini biliyorsanız kodunuzun ne kadar hızlı

çalışacağını da hesaplayabilirsiniz.

FUNCTION GetCycleCount: Int64; // D4-D5

ASM

DB 0FH

DB 031H

END;

procedure TForm1.Button1Click(Sender: TObject);

VAR

Start: Int64; // D4-D5

Stop : Int64;

begin

Start := GetCycleCount;

Sleep(1000); // 1000 milliseconds = 1 seconds

Stop := GetCycleCount;

ShowMessage( IntToStr(Stop-Start) )

end;

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

Dosya böl /birleştir

unit ScreenCombineSplit;

interface

uses

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

StdCtrls;

type

TForm1 = class(TForm)

ButtonCombine: TButton;

ButtonSplit: TButton;

procedure ButtonCombineClick(Sender: TObject);

procedure ButtonSplitClick(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

CONST

FileList : ARRAY[1..5] OF STRING =

('1.DAT', '2.DAT', '3.DAT', '4.DAT', '5.DAT');

CombinedFile = 'Combined.DAT';

procedure TForm1.ButtonCombineClick(Sender: TObject);

VAR

i : INTEGER;

s : ARRAY[1..5] OF STRING;

size : INTEGER;

Stream : TMemoryStream;

begin

FOR i := Low(FileList) TO High(FileList) DO

BEGIN

// Load files into strings

IF FileExists(FileList[i])

THEN BEGIN

Stream := TMemoryStream.Create;

TRY

Stream.LoadFromFile(FileList[i]);

SetLength(s[i], Stream.Size);

Stream.Read(s[i][1], Stream.Size)

FINALLY

Stream.Free

END

ELSE s[i] := '';

END;

// Could encrypt the strings here if desired

// Save strings to single binary file

DeleteFile(CombinedFile);

Stream := TMemoryStream.Create;

TRY

FOR i := Low(s) TO High(s) DO

BEGIN

size := LENGTH(s[i]);

Stream.Write(size, SizeOf(size));

Stream.Write(s[i][1], size);

END;

Stream.SaveToFile(CombinedFile)

FINALLY

Stream.Free

END;

ButtonSplit.Enabled := TRUE

end;

procedure TForm1.ButtonSplitClick(Sender: TObject);

VAR

buffer : STRING;

i : INTEGER;

InFileStream : TFileStream;

OutFileStream: TFileStream;

size : INTEGER;

begin

InFileStream := TFileStream.Create(CombinedFile,

fmOpenRead OR fmShareDenyNone);

TRY

// split combined file ito separate files

// with extension .BIN instead of .DAT

FOR i := Low(FileList) TO High(FileList) DO

BEGIN

InFileStream.Read(size, SizeOf(size));

SetLength(buffer, size);

InFileStream.Read(buffer[1], size);

// Could decrypt the strings here if desired

// Write new file

OutFileStream := TFileStream.Create(ChangeFileExt(FileList[i], '.BIN'),

fmCreate or fmOpenWrite or fmShareExclusive);

TRY

OutFileStream.Write(buffer[1], size)

FINALLY

OutFileStream.Free

END

FINALLY

InFileStream.Free

END

end;

end.

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

Dosya böl /birleştir

unit ScreenCombineSplit;

interface

uses

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

StdCtrls;

type

TForm1 = class(TForm)

ButtonCombine: TButton;

ButtonSplit: TButton;

procedure ButtonCombineClick(Sender: TObject);

procedure ButtonSplitClick(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

CONST

FileList : ARRAY[1..5] OF STRING =

('1.DAT', '2.DAT', '3.DAT', '4.DAT', '5.DAT');

CombinedFile = 'Combined.DAT';

procedure TForm1.ButtonCombineClick(Sender: TObject);

VAR

i : INTEGER;

s : ARRAY[1..5] OF STRING;

size : INTEGER;

Stream : TMemoryStream;

begin

FOR i := Low(FileList) TO High(FileList) DO

BEGIN

// Load files into strings

IF FileExists(FileList[i])

THEN BEGIN

Stream := TMemoryStream.Create;

TRY

Stream.LoadFromFile(FileList[i]);

SetLength(s[i], Stream.Size);

Stream.Read(s[i][1], Stream.Size)

FINALLY

Stream.Free

END

ELSE s[i] := '';

END;

// Could encrypt the strings here if desired

// Save strings to single binary file

DeleteFile(CombinedFile);

Stream := TMemoryStream.Create;

TRY

FOR i := Low(s) TO High(s) DO

BEGIN

size := LENGTH(s[i]);

Stream.Write(size, SizeOf(size));

Stream.Write(s[i][1], size);

END;

Stream.SaveToFile(CombinedFile)

FINALLY

Stream.Free

END;

ButtonSplit.Enabled := TRUE

end;

procedure TForm1.ButtonSplitClick(Sender: TObject);

VAR

buffer : STRING;

i : INTEGER;

InFileStream : TFileStream;

OutFileStream: TFileStream;

size : INTEGER;

begin

InFileStream := TFileStream.Create(CombinedFile,

fmOpenRead OR fmShareDenyNone);

TRY

// split combined file ito separate files

// with extension .BIN instead of .DAT

FOR i := Low(FileList) TO High(FileList) DO

BEGIN

InFileStream.Read(size, SizeOf(size));

SetLength(buffer, size);

InFileStream.Read(buffer[1], size);

// Could decrypt the strings here if desired

// Write new file

OutFileStream := TFileStream.Create(ChangeFileExt(FileList[i], '.BIN'),

fmCreate or fmOpenWrite or fmShareExclusive);

TRY

OutFileStream.Write(buffer[1], size)

FINALLY

OutFileStream.Free

END

FINALLY

InFileStream.Free

END

end;

end.

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

sql servarda kulanıcı tanımlama

EXEC sp_addlogin 'sv', @passwd = '1', @defdb = 'rfwsspagok', @deflanguage = 'Turkish'

// tum kulanıcı yetkileri

EXEC sp_addsrvrolemember 'sv', 'sysadmin'

EXEC sp_addsrvrolemember 'sv', 'securityadmin'

EXEC sp_addsrvrolemember 'sv', 'serveradmin'

EXEC sp_addsrvrolemember 'sv', 'setupadmin'

EXEC sp_addsrvrolemember 'sv', 'processadmin'

EXEC sp_addsrvrolemember 'sv', 'diskadmin'

EXEC sp_addsrvrolemember 'sv', 'dbcreator'

EXEC sp_addsrvrolemember 'sv', 'bulkadmin'

username='sv'

@passwd='1'//pasword

@defdb = 'rfwsspagok' //DATABASE adı

@deflanguage = 'Turkish'//dil seçenegi

// kulanıcı silme

EXEC sp_droplogin 'sv'

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

sql servarda kulanıcı tanımlama

EXEC sp_addlogin 'sv', @passwd = '1', @defdb = 'rfwsspagok', @deflanguage = 'Turkish'

// tum kulanıcı yetkileri

EXEC sp_addsrvrolemember 'sv', 'sysadmin'

EXEC sp_addsrvrolemember 'sv', 'securityadmin'

EXEC sp_addsrvrolemember 'sv', 'serveradmin'

EXEC sp_addsrvrolemember 'sv', 'setupadmin'

EXEC sp_addsrvrolemember 'sv', 'processadmin'

EXEC sp_addsrvrolemember 'sv', 'diskadmin'

EXEC sp_addsrvrolemember 'sv', 'dbcreator'

EXEC sp_addsrvrolemember 'sv', 'bulkadmin'

username='sv'

@passwd='1'//pasword

@defdb = 'rfwsspagok' //DATABASE adı

@deflanguage = 'Turkish'//dil seçenegi

// kulanıcı silme

EXEC sp_droplogin 'sv'

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

Fastcode library kullanımı

Arkadaşlar yeni işlemcilerin komut setlerine göre hazırlanmış matematiksel

ve string komutları var. Çok daha hızlı çalışıyorlar.

Aşağıdaki adresten kaynak kodları ve örnek programları indirebilirsiniz.

http://www.fastcodeproject.org/ (MMX,SSE,SSE2,SSE3,3DNOW!)

if FastCodeTarget = ftP4P then

FastMove := MoveFastcodeP4P

else if FastCodeTarget = ftP4N then

FastMove := MoveFastcodeP4N

else if FastCodeTarget = ftPMD then

FastMove := MoveFastcodePMD

else if FastCodeTarget = ftPMB then

FastMove := MoveFastcodePMB

else if FastCodeTarget = ftAmd64 then

FastMove := MoveFastcodeAMD64

else if FastCodeTarget = ftAmdXp then

FastMove := MoveFastcodeXP

else

begin

if isMMX in CPU.InstructionSupport then

FastMove := MoveFastcodeBlended

else

FastMove := MoveFastcodeRTL;

end;

karşılaştır

function Compare(A, B: Integer): Integer;

asm

mov ecx, 1

sub eax, edx

cdq

cmovg eax, ecx

or eax, edx

end;

regards,

John

The Fastcode Project:

http://www.fastcodeproject.org/

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

Fastcode library kullanımı

Arkadaşlar yeni işlemcilerin komut setlerine göre hazırlanmış matematiksel

ve string komutları var. Çok daha hızlı çalışıyorlar.

Aşağıdaki adresten kaynak kodları ve örnek programları indirebilirsiniz.

http://www.fastcodeproject.org/ (MMX,SSE,SSE2,SSE3,3DNOW!)

if FastCodeTarget = ftP4P then

FastMove := MoveFastcodeP4P

else if FastCodeTarget = ftP4N then

FastMove := MoveFastcodeP4N

else if FastCodeTarget = ftPMD then

FastMove := MoveFastcodePMD

else if FastCodeTarget = ftPMB then

FastMove := MoveFastcodePMB

else if FastCodeTarget = ftAmd64 then

FastMove := MoveFastcodeAMD64

else if FastCodeTarget = ftAmdXp then

FastMove := MoveFastcodeXP

else

begin

if isMMX in CPU.InstructionSupport then

FastMove := MoveFastcodeBlended

else

FastMove := MoveFastcodeRTL;

end;

karşılaştır

function Compare(A, B: Integer): Integer;

asm

mov ecx, 1

sub eax, edx

cdq

cmovg eax, ecx

or eax, edx

end;

regards,

John

The Fastcode Project:

http://www.fastcodeproject.org/

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

string bölmek hızlı yöntem

VERY fast split function

this function returns part of a string based on

constant defineable delimiters, such as ";". So

SPLIT('this is a test ',' ',3) = 'is' or

SPLIT('data;another;yet;again;more;',';',4) = 'yet'

Split function shifts index integer by two to

be compatible with commonly used PD split function

gpl 2004 / Juhani Suhonen

}

function split(input: string; schar: Char; s: Integer): string;

var

c: array of Integer;

b, t: Integer;

begin

Dec(s, 2); // for compatibility with very old & slow split function

t := 0; // variable T needs to be initialized...

setlength(c, Length(input));

for b := 0 to pred(High(c)) do

begin

c[b + 1] := posex(schar, input, succ(c[b]));

// BREAK LOOP if posex looped (position before previous)

// or wanted position reached..

if (c[b + 1] < c[b]) or (s < t) then break

else

Inc(t);

end;

Result := Copy(input, succ(c[s]), pred(c[s + 1] - c[s]));

end;

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

string bölmek hızlı yöntem

VERY fast split function

this function returns part of a string based on

constant defineable delimiters, such as ";". So

SPLIT('this is a test ',' ',3) = 'is' or

SPLIT('data;another;yet;again;more;',';',4) = 'yet'

Split function shifts index integer by two to

be compatible with commonly used PD split function

gpl 2004 / Juhani Suhonen

}

function split(input: string; schar: Char; s: Integer): string;

var

c: array of Integer;

b, t: Integer;

begin

Dec(s, 2); // for compatibility with very old & slow split function

t := 0; // variable T needs to be initialized...

setlength(c, Length(input));

for b := 0 to pred(High(c)) do

begin

c[b + 1] := posex(schar, input, succ(c[b]));

// BREAK LOOP if posex looped (position before previous)

// or wanted position reached..

if (c[b + 1] < c[b]) or (s < t) then break

else

Inc(t);

end;

Result := Copy(input, succ(c[s]), pred(c[s + 1] - c[s]));

end;

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

internet uygulaması

Getting the IP address and mask for ALL TCP/IP interfaces

Question/Problem/Abstract:

We have seen a lot of methods obtaining the IP address of a machine. This is the "correct" method listing all addresses, network masks, broadcast addresses and status for all interfaces, including the loopback 127.0.0.1 - Requires WinSock 2

Answer:

This is a complete Delphi unit. By adding it to a project you can

call :

EnumInterfaces(var s string): Boolean;

that returns a CRLF separated string of all IP addresses, netmasks,

broadcast addresses and interface status.

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

unit USock;

interface

uses Windows, Winsock;

{

This function enumerates all TCP/IP interfaces and

returns a CRLF separated string containing:

IP, NetMask, BroadCast-Address, Up/Down status,

Broadcast support, Loopback

If you feed this string to a wide TMEMO (to its memo.lines.text

property) you will see cleary the results.

To use this you need Win98/ME/2K, 95 OSR 2 or NT service

pack #3 because WinSock 2 is used (WS2_32.DLL)

}

function EnumInterfaces(var sInt: string): Boolean;

{ Imported function WSAIOCtl from Winsock 2.0 - Winsock 2 is }

{ available only in Win98/ME/2K and 95 OSR2, NT srv pack #3 }

function WSAIoctl(s: TSocket; cmd: DWORD; lpInBuffer: PCHAR; dwInBufferLen:

DWORD;

lpOutBuffer: PCHAR; dwOutBufferLen: DWORD;

lpdwOutBytesReturned: LPDWORD;

lpOverLapped: POINTER;

lpOverLappedRoutine: POINTER): Integer; stdcall; external 'WS2_32.DLL';

{ Constants taken from C header files }

const SIO_GET_INTERFACE_LIST = $4004747F;

IFF_UP = $00000001;

IFF_BROADCAST = $00000002;

IFF_LOOPBACK = $00000004;

IFF_POINTTOPOINT = $00000008;

IFF_MULTICAST = $00000010;

type sockaddr_gen = packed record

AddressIn: sockaddr_in;

filler: packed array[0..7] of char;

end;

type INTERFACE_INFO = packed record

iiFlags: u_long; // Interface flags

iiAddress: sockaddr_gen; // Interface address

iiBroadcastAddress: sockaddr_gen; // Broadcast address

iiNetmask: sockaddr_gen; // Network mask

end;

implementation

{-------------------------------------------------------------------

1. Open WINSOCK

2. Create a socket

3. Call WSAIOCtl to obtain network interfaces

4. For every interface, get IP, MASK, BROADCAST, status

5. Fill a CRLF separated string with this info

6. Finito

--------------------------------------------------------------------}

function EnumInterfaces(var sInt: string): Boolean;

var s: TSocket;

wsaD: WSADATA;

NumInterfaces: Integer;

BytesReturned, SetFlags: u_long;

pAddrInet: SOCKADDR_IN;

pAddrString: PCHAR;

PtrA: pointer;

Buffer: array[0..20] of INTERFACE_INFO;

i: Integer;

begin

result := true; // Initialize

sInt := '';

WSAStartup($0101, wsaD); // Start WinSock

// You should normally check

// for errors here

s := Socket(AF_INET, SOCK_STREAM, 0); // Open a socket

if (s = INVALID_SOCKET) then exit;

try // Call WSAIoCtl

PtrA := @bytesReturned;

if (WSAIoCtl(s, SIO_GET_INTERFACE_LIST, nil, 0, @Buffer, 1024, PtrA, nil,

nil)

<> SOCKET_ERROR)

then

begin // If ok, find out how

// many interfaces exist

NumInterfaces := BytesReturned div SizeOf(INTERFACE_INFO);

for i := 0 to NumInterfaces - 1 do // For every interface

begin

pAddrInet := Buffer[i].iiAddress.addressIn; // IP ADDRESS

pAddrString := inet_ntoa(pAddrInet.sin_addr);

sInt := sInt + ' IP=' + pAddrString + ',';

pAddrInet := Buffer[i].iiNetMask.addressIn; // SUBNET MASK

pAddrString := inet_ntoa(pAddrInet.sin_addr);

sInt := sInt + ' Mask=' + pAddrString + ',';

pAddrInet := Buffer[i].iiBroadCastAddress.addressIn; // Broadcast addr

pAddrString := inet_ntoa(pAddrInet.sin_addr);

sInt := sInt + ' Broadcast=' + pAddrString + ',';

SetFlags := Buffer[i].iiFlags;

if (SetFlags and IFF_UP) = IFF_UP then

sInt := sInt + ' Interface UP,' // Interface up/down

else

sInt := sInt + ' Interface DOWN,';

if (SetFlags and IFF_BROADCAST) = IFF_BROADCAST then // Broadcasts

sInt := sInt + ' Broadcasts supported,' // supported or

else // not supported

sInt := sInt + ' Broadcasts NOT supported,';

if (SetFlags and IFF_LOOPBACK) = IFF_LOOPBACK then // Loopback or

sInt := sInt + ' Loopback interface'

else

sInt := sInt + ' Network interface'; // normal

sInt := sInt + #13#10; // CRLF between

// each interface

end;

except

end;

// Close sockets

CloseSocket(s);

WSACleanUp;

result := false;

end;

end.

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

internet uygulaması

Getting the IP address and mask for ALL TCP/IP interfaces

Question/Problem/Abstract:

Answer:

This is a complete Delphi unit. By adding it to a project you can

call :

EnumInterfaces(var s string): Boolean;

that returns a CRLF separated string of all IP addresses, netmasks,

broadcast addresses and interface status.

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

unit USock;

interface

uses Windows, Winsock;

{

This function enumerates all TCP/IP interfaces and

returns a CRLF separated string containing:

IP, NetMask, BroadCast-Address, Up/Down status,

Broadcast support, Loopback

If you feed this string to a wide TMEMO (to its memo.lines.text

property) you will see cleary the results.

To use this you need Win98/ME/2K, 95 OSR 2 or NT service

pack #3 because WinSock 2 is used (WS2_32.DLL)

}

function EnumInterfaces(var sInt: string): Boolean;

{ Imported function WSAIOCtl from Winsock 2.0 - Winsock 2 is }

{ available only in Win98/ME/2K and 95 OSR2, NT srv pack #3 }

function WSAIoctl(s: TSocket; cmd: DWORD; lpInBuffer: PCHAR; dwInBufferLen:

DWORD;

lpOutBuffer: PCHAR; dwOutBufferLen: DWORD;

lpdwOutBytesReturned: LPDWORD;

lpOverLapped: POINTER;

lpOverLappedRoutine: POINTER): Integer; stdcall; external 'WS2_32.DLL';

{ Constants taken from C header files }

const SIO_GET_INTERFACE_LIST = $4004747F;

IFF_UP = $00000001;

IFF_BROADCAST = $00000002;

IFF_LOOPBACK = $00000004;

IFF_POINTTOPOINT = $00000008;

IFF_MULTICAST = $00000010;

type sockaddr_gen = packed record

AddressIn: sockaddr_in;

filler: packed array[0..7] of char;

end;

type INTERFACE_INFO = packed record

iiFlags: u_long; // Interface flags

iiAddress: sockaddr_gen; // Interface address

iiBroadcastAddress: sockaddr_gen; // Broadcast address

iiNetmask: sockaddr_gen; // Network mask

end;

implementation

{-------------------------------------------------------------------

1. Open WINSOCK

2. Create a socket

3. Call WSAIOCtl to obtain network interfaces

4. For every interface, get IP, MASK, BROADCAST, status

5. Fill a CRLF separated string with this info

6. Finito

--------------------------------------------------------------------}

function EnumInterfaces(var sInt: string): Boolean;

var s: TSocket;

wsaD: WSADATA;

NumInterfaces: Integer;

BytesReturned, SetFlags: u_long;

pAddrInet: SOCKADDR_IN;

pAddrString: PCHAR;

PtrA: pointer;

Buffer: array[0..20] of INTERFACE_INFO;

i: Integer;

begin

result := true; // Initialize

sInt := '';

WSAStartup($0101, wsaD); // Start WinSock

// You should normally check

// for errors here

s := Socket(AF_INET, SOCK_STREAM, 0); // Open a socket

if (s = INVALID_SOCKET) then exit;

try // Call WSAIoCtl

PtrA := @bytesReturned;

if (WSAIoCtl(s, SIO_GET_INTERFACE_LIST, nil, 0, @Buffer, 1024, PtrA, nil,

nil)

<> SOCKET_ERROR)

then

begin // If ok, find out how

// many interfaces exist

NumInterfaces := BytesReturned div SizeOf(INTERFACE_INFO);

for i := 0 to NumInterfaces - 1 do // For every interface

begin

pAddrInet := Buffer[i].iiAddress.addressIn; // IP ADDRESS

pAddrString := inet_ntoa(pAddrInet.sin_addr);

sInt := sInt + ' IP=' + pAddrString + ',';

pAddrInet := Buffer[i].iiNetMask.addressIn; // SUBNET MASK

pAddrString := inet_ntoa(pAddrInet.sin_addr);

sInt := sInt + ' Mask=' + pAddrString + ',';

pAddrInet := Buffer[i].iiBroadCastAddress.addressIn; // Broadcast addr

pAddrString := inet_ntoa(pAddrInet.sin_addr);

sInt := sInt + ' Broadcast=' + pAddrString + ',';

SetFlags := Buffer[i].iiFlags;

if (SetFlags and IFF_UP) = IFF_UP then

sInt := sInt + ' Interface UP,' // Interface up/down

else

sInt := sInt + ' Interface DOWN,';

if (SetFlags and IFF_BROADCAST) = IFF_BROADCAST then // Broadcasts

sInt := sInt + ' Broadcasts supported,' // supported or

else // not supported

sInt := sInt + ' Broadcasts NOT supported,';

if (SetFlags and IFF_LOOPBACK) = IFF_LOOPBACK then // Loopback or

sInt := sInt + ' Loopback interface'

else

sInt := sInt + ' Network interface'; // normal

sInt := sInt + #13#10; // CRLF between

// each interface

end;

except

end;

// Close sockets

CloseSocket(s);

WSACleanUp;

result := false;

end;

end.

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

RAW paketlerini göndermek

Question/Problem/Abstract:

How can I send raw IP Packets?

This example just showes how to send an UDP packet with customized (spoofed) source ip+port.

>>> You can only SEND raw-packets! <<<

>>> Please don't ask me why. rtfm. <<<

Answer:

{

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

Raw Packet Sender

using: Delphi + Winsock 2

Description:

Using raw sockets you can SEND raw packets over the internet

containing whatever you like.

Keep in mind:

1. This only works under Window 2000.

2. You can SEND raw packets. You can NOT RECEIVE raw packets.

3. You must be Administrator to run this.

4. This unit requires a form containing a button and a memo.

Usage:

1. Before you run your program, you must change the SrcIP+SrcPort+

DestIP+DestPort to suitable values!

2. If you don't understand what this source does: Don't use it.

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

}

unit main;

interface

uses

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

StdCtrls, OleCtrls, Registry;

Const

SrcIP = '123.123.123.1';

SrcPort = 1234;

DestIP = '123.123.123.2';

DestPort = 4321;

Max_Message = 4068;

Max_Packet = 4096;

type

TPacketBuffer = Array[0..Max_Packet-1] of byte;

TForm1 = class(TForm)

Button1: TButton;

Memo1: TMemo;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

procedure SendIt;

end;

// IP Header

type

T_IP_Header = record

ip_verlen : Byte;

ip_tos : Byte;

ip_totallength : Word;

ip_id : Word;

ip_offset : Word;

ip_ttl : Byte;

ip_protocol : Byte;

ip_checksum : Word;

ip_srcaddr : LongWord;

ip_destaddr : LongWord;

end;

// UDP Header

Type

T_UDP_Header = record

src_portno : Word;

dst_portno : Word;

udp_length : Word;

udp_checksum : Word;

end;

// Some Winsock 2 type declarations

u_char = Char;

u_short = Word;

u_int = Integer;

u_long = Longint;

SunB = packed record

s_b1, s_b2, s_b3, s_b4: u_char;

end;

SunW = packed record

s_w1, s_w2: u_short;

end;

in_addr = record

case integer of

0: (S_un_b: SunB);

1: (S_un_w: SunW);

2: (S_addr: u_long);

end;

TInAddr = in_addr;

Sockaddr_in = record

case Integer of

0: (sin_family: u_short;

sin_port: u_short;

sin_addr: TInAddr;

sin_zero: array[0..7] of Char);

1: (sa_family: u_short;

sa_data: array[0..13] of Char)

end;

TSockAddr = Sockaddr_in;

TSocket = u_int;

const

WSADESCRIPTION_LEN = 256;

WSASYS_STATUS_LEN = 128;

type

PWSAData = ^TWSAData;

WSAData = record // !!! also WSDATA

wVersion: Word;

wHighVersion: Word;

szDescription: array[0..WSADESCRIPTION_LEN] of Char;

szSystemStatus: array[0..WSASYS_STATUS_LEN] of Char;

iMaxSockets: Word;

iMaxUdpDg: Word;

lpVendorInfo: PChar;

end;

TWSAData = WSAData;

// Define some winsock 2 functions

function closesocket(s: TSocket): Integer; stdcall;

function socket(af, Struct, protocol: Integer): TSocket; stdcall;

function sendto(s: TSocket; var Buf; len, flags: Integer; var addrto: TSockAddr;

tolen: Integer): Integer; stdcall;{}

function setsockopt(s: TSocket; level, optname: Integer; optval: PChar;

optlen: Integer): Integer; stdcall;

function inet_addr(cp: PChar): u_long; stdcall; {PInAddr;} { TInAddr }

function htons(hostshort: u_short): u_short; stdcall;

function WSAGetLastError: Integer; stdcall;

function WSAStartup(wVersionRequired: word; var WSData: TWSAData): Integer; stdcall;

function WSACleanup: Integer; stdcall;

const

AF_INET = 2; // internetwork: UDP, TCP, etc.

IP_HDRINCL = 2; // IP Header Include

SOCK_RAW = 3; // raw-protocol interface

IPPROTO_IP = 0; // dummy for IP

IPPROTO_TCP = 6; // tcp

IPPROTO_UDP = 17; // user datagram protocol

IPPROTO_RAW = 255; // raw IP packet

INVALID_SOCKET = TSocket(NOT(0));

SOCKET_ERROR = -1;

var

Form1: TForm1;

implementation

// Import Winsock 2 functions

const WinSocket = 'WS2_32.DLL';

function closesocket; external winsocket name 'closesocket';

function socket; external winsocket name 'socket';

function sendto; external winsocket name 'sendto';

function setsockopt; external winsocket name 'setsockopt';

function inet_addr; external winsocket name 'inet_addr';

function htons; external winsocket name 'htons';

function WSAGetLastError; external winsocket name 'WSAGetLastError';

function WSAStartup; external winsocket name 'WSAStartup';

function WSACleanup; external winsocket name 'WSACleanup';

{$R *.DFM}

// Function: checksum

// Description:

// This function calculates the 16-bit one's complement sum

// for the supplied buffer

function CheckSum(Var Buffer; Size : integer) : Word;

type

TWordArray = Array[0..1] of Word;

var

ChkSum : LongWord;

i : Integer;

begin

ChkSum := 0;

i := 0;

While Size > 1 do begin

ChkSum := ChkSum + TWordArray(Buffer)[i];

inc(i);

Size := Size - SizeOf(Word);

end;

if Size=1 then ChkSum := ChkSum + Byte(TWordArray(Buffer)[i]);

ChkSum := (ChkSum shr 16) + (ChkSum and $FFFF);

ChkSum := ChkSum + (Chksum shr 16);

Result := Word(ChkSum);

end;

procedure BuildHeaders(

FromIP : String;

iFromPort : Word;

ToIP : String;

iToPort : Word;

StrMessage : String;

Var Buf : TPacketBuffer;

Var remote : TSockAddr;

Var iTotalSize : Word

);

Var

dwFromIP : LongWord;

dwToIP : LongWord;

iIPVersion : Word;

iIPSize : Word;

ipHdr : T_IP_Header;

udpHdr : T_UDP_Header;

iUdpSize : Word;

iUdpChecksumSize : Word;

cksum : Word;

Ptr : ^Byte;

procedure IncPtr(Value : Integer);

begin

ptr := pointer(integer(ptr) + Value);

end;

begin

// Convert ip address'ss

dwFromIP := inet_Addr(PChar(FromIP));

dwToIP := inet_Addr(PChar(ToIP));

// Initalize the IP header

iTotalSize := sizeof(ipHdr) + sizeof(udpHdr) + length(strMessage);

iIPVersion := 4;

iIPSize := sizeof(ipHdr) div sizeof(LongWord);

// IP version goes in the high order 4 bits of ip_verlen. The

// IP header length (in 32-bit words) goes in the lower 4 bits.

ipHdr.ip_verlen := (iIPVersion shl 4) or iIPSize;

ipHdr.ip_tos := 0; // IP type of service

ipHdr.ip_totallength := htons(iTotalSize); // Total packet len

ipHdr.ip_id := 0; // Unique identifier: set to 0

ipHdr.ip_offset := 0; // Fragment offset field

ipHdr.ip_ttl := 128; // Time to live

ipHdr.ip_protocol := $11; // Protocol(UDP)

ipHdr.ip_checksum := 0 ; // IP checksum

ipHdr.ip_srcaddr := dwFromIP; // Source address

ipHdr.ip_destaddr := dwToIP; // Destination address

// Initalize the UDP header

iUdpSize := sizeof(udpHdr) + length(strMessage);

udpHdr.src_portno := htons(iFromPort) ;

udpHdr.dst_portno := htons(iToPort) ;

udpHdr.udp_length := htons(iUdpSize) ;

udpHdr.udp_checksum := 0 ;

// Build the UDP pseudo-header for calculating the UDP checksum.

// The pseudo-header consists of the 32-bit source IP address,

// the 32-bit destination IP address, a zero byte, the 8-bit

// IP protocol field, the 16-bit UDP length, and the UDP

// header itself along with its data (padded with a 0 if

// the data is odd length).

iUdpChecksumSize := 0;

ptr := @buf[0];

FillChar(Buf, SizeOf(Buf), 0);

Move(ipHdr.ip_srcaddr, ptr^, SizeOf(ipHdr.ip_srcaddr));

IncPtr(SizeOf(ipHdr.ip_srcaddr));

iUdpChecksumSize := iUdpChecksumSize + sizeof(ipHdr.ip_srcaddr);

Move(ipHdr.ip_destaddr, ptr^, SizeOf(ipHdr.ip_destaddr));

IncPtr(SizeOf(ipHdr.ip_destaddr));

iUdpChecksumSize := iUdpChecksumSize + sizeof(ipHdr.ip_destaddr);

IncPtr(1);

Inc(iUdpChecksumSize);

Move(ipHdr.ip_protocol, ptr^, sizeof(ipHdr.ip_protocol));

IncPtr(sizeof(ipHdr.ip_protocol));

iUdpChecksumSize := iUdpChecksumSize + sizeof(ipHdr.ip_protocol);

Move(udpHdr.udp_length, ptr^, sizeof(udpHdr.udp_length));

IncPtr(sizeof(udpHdr.udp_length));

iUdpChecksumSize := iUdpChecksumSize + sizeof(udpHdr.udp_length);

move(udpHdr, ptr^, sizeof(udpHdr));

IncPtr(sizeof(udpHdr));

iUdpChecksumSize := iUdpCheckSumSize + sizeof(udpHdr);

Move(StrMessage[1], ptr^, Length(strMessage));

IncPtr(Length(StrMessage));

iUdpChecksumSize := iUdpChecksumSize + length(strMessage);

cksum := checksum(buf, iUdpChecksumSize);

udpHdr.udp_checksum := cksum;

// Now assemble the IP and UDP headers along with the data

// so we can send it

FillChar(Buf, SizeOf(Buf), 0);

Ptr := @Buf[0];

Move(ipHdr, ptr^, SizeOf(ipHdr)); IncPtr(SizeOf(ipHdr));

Move(udpHdr, ptr^, SizeOf(udpHdr)); IncPtr(SizeOf(udpHdr));

Move(StrMessage[1], ptr^, length(StrMessage));

// Apparently, this SOCKADDR_IN structure makes no difference.

// Whatever we put as the destination IP addr in the IP header

// is what goes. Specifying a different destination in remote

// will be ignored.

remote.sin_family := AF_INET;

remote.sin_port := htons(iToPort);

remote.sin_addr.s_addr := dwToIP;

end;

procedure TForm1.SendIt;

Var

sh : TSocket;

bOpt : Integer;

ret : Integer;

Buf : TPacketBuffer;

Remote : TSockAddr;

Local : TSockAddr;

iTotalSize : Word;

wsdata : TWSAdata;

begin

// Startup Winsock 2

ret := WSAStartup($0002, wsdata);

if ret<>0 then begin

memo1.lines.add('WSA Startup failed.');

exit;

end;

with memo1.lines do begin

add('WSA Startup:');

add('Desc.: '+wsData.szDescription);

add('Status: '+wsData.szSystemStatus);

end;

try

// Create socket

sh := Socket(AF_INET, SOCK_RAW, IPPROTO_UDP);

if (sh = INVALID_SOCKET) then begin

memo1.lines.add('Socket() failed: '+IntToStr(WSAGetLastError));

exit;

end;

Memo1.lines.add('Socket Handle = '+IntToStr(sh));

// Option: Header Include

bOpt := 1;

ret := SetSockOpt(sh, IPPROTO_IP, IP_HDRINCL, @bOpt, SizeOf(bOpt));

if ret = SOCKET_ERROR then begin

Memo1.lines.add('setsockopt(IP_HDRINCL) failed: '+IntToStr(WSAGetLastError));

exit;

end;

// Build the packet

BuildHeaders( SrcIP, SrcPort,

DestIP, DestPort,

'THIS IS A TEST PACKET',

Buf, Remote, iTotalSize );

// Send the packet

ret := SendTo(sh, buf, iTotalSize, 0, Remote, SizeOf(Remote));

if ret = SOCKET_ERROR then

Memo1.Lines.Add('sendto() failed: '+IntToStr(WSAGetLastError))

else

Memo1.Lines.Add('send '+IntToStr(ret)+' bytes.');

// Close socket

CloseSocket(sh);

finally

// Close Winsock 2

WSACleanup;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

SendIt;