Programlama yapalım ve Öğrenelim.

Blob alan veri kaydetmek

Bir blob alana bir dosyayı aynen kaydetmek ve sonra da herhangi bir zamanda geri çağırmak

için kullanabilirsiniz bu kodları.word excel gibi

bu tip dosyaları saklamak ve sonra istenen kriterlere uygun olarak çağırma ihtiyacınız olursa

bu kodları kullanabilirsiniz.

}

// BLOB a Dosya Kaydetmek:

procedure TForm1.Button1Click(Sender: TObject);

var

blob: TBlobStream;

begin

blob := SeninDataset.CreateBlobStream(SeninDataset.FieldByName('SENIN_BLOB'), bmWrite);

try

blob.Seek(0, soFromBeginning);

fs := TFileStream.Create('c:SeninDosya.doc', fmOpenRead or

fmShareDenyWrite);

try

blob.CopyFrom(fs, fs.Size)

finally

fs.Free

end;

finally

blob.Free

end;

// BLOB dan kayıtlı dosyayı Okumak:

procedure TForm1.Button1Click(Sender: TObject);

var

blob: TBlobStream;

begin

blob := SeninDataset.CreateBlobStream(SeninDataset.FieldByName('SENIN_BLOB'), bmRead);

try

blob.Seek(0, soFromBeginning);

with TFileStream.Create('c:SeninDosya.doc', fmCreate) do

try

CopyFrom(blob, blob.Size)

finally

Free

end;

finally

blob.Free

end;

{

Kullanırken (BDE/ADO/DAO/ODBC/vs) database engine larından birini kullanabilirsiniz

Gömmek için de Word, Excel Dosyası, Wav,Jpg dosyaları vs. olabilir

}

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

MdiForm - MdiChildForm Kontrol

NeverFear - kaheri579@hotmail.com

*** Delphi 7.0 kullanılarak oluşturulmuş ve denenmiştir.

- Tüm projeyi *.dfm ve *.pas dosyaları ile birlikte aşağıdaki linkten *.zip dosya

olarak edinebilirsiniz.

Link: http://...................................../DownloadFile.aspx?PostId=32043&Destination=UserPosts%2f40511.MdiForm.zip

NOT: Kodbank'ta fazla yer tutmasını önleme düşüncesiyle bu yönteme başvurulmuştur.

İşinizi görmesi dileğimle,

Çalışmalarınızda başarılar dilerim.

NeverFear - kaheri579@hotmail.com

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

Programa Giren Kullanıcı Ağda Bir kez oturum açsın

Arkadaşlar kodbankta hep rastlıyoruz programım bir kere açılsın

fakat ağda aynı kullanıcı adının bir kere açmasına izin vermemiz gereken

bir durumla karşı karşıyaysak şöyle bir yöntem kullanabiliriz

Varsayıyorum programınıza kullanıcı adı ve şifre ile giriş yapıldı,

Bundansonra Uname olarak adlandıracağız giriş yapan kullanıcı adını

/*/-------- GEREKLİ OLANLAR *-*----------------

1- Programa giren kullanıcının adını ve ipsini yazdırabileceğiniz bir tablo

AktifIp:varchar(50)

AktifKullanici:varchar(50)

AktiflikZamani:datetime

2- Ana Formunuza TidUdpClient, TidUdpServer adlı iki bileşen koyunuz

3- Hem AnaFormdan hemde Şifre Ekranından Çağırılacak bir procedure yazacağız

aşağıdaki gibi bunu uygun yere siz yerleştirin

procedure networkdeacikmi(kullanici:String;Tablo:TAdoquery);

var

x:integer;

begin

x:=0;

if Tablo.Active then Tablo.Close;

Tablo.SQL.Clear;

Tablo.SQL.Add('Select * from logAktifusers Where AktifKullanici='+QuotedStr(kullanici));

Tablo.Open;

if Tablo.FieldByName('AktifKullanici').IsNull then

begin

FMain.server.Active:=True;

Tablo.Insert;

Tablo.FieldByName('AktifKullanici').AsString := kullanici;

Tablo.FieldByName('AktifIp').AsString := ipadresi;

Tablo.FieldByName('AktiflikZamani').AsDateTime := Now();

Tablo.Append;

x:=1;

end

else

begin

if x=0 then

if SecMesaJ('Programınız Ağ üzerinde başka bir bilgisayarda açık, Kapatmak istermisiniz') = True then

begin

Fmain.Client.Active := True;

Fmain.Client.Host := Tablo.FieldByName('AktifIp').ASString;

Fmain.Client.Send('ZorlaKapat');

if not Fmain.Server.Active then

Fmain.Server.Active;

Tablo.Insert;

Tablo.FieldByName('AktifKullanici').AsString := kullanici;

Tablo.FieldByName('AktifIp').AsString := ipadresi;

Tablo.FieldByName('AktiflikZamani').AsDateTime := Now();

Tablo.Append;

enD;

Application.Terminate;

end;

öncelikle bir procedurumuz var

şifre denetimini başarıyla geçtikten sonra şu kodu yazıyoruz

networkdeacikmi(Uname,qtmp1);

Ana Form'un üzerindeki UDPServer bileşenin udpRead event'ına

şu kodları yazınız

procedure TFmain.serverUDPRead(Sender: TObject; AData: TBytes;

ABinding: TIdSocketHandle);

var

msj:String;

begin

msj := BytesToString(AData);

if msj = 'ZorlaKapat' then begin

Mesaj('Programınız Diğer Oturumdan Gelen İstekle Kapatılıyor..');

{bu mesaj yerine aslında 5 saniye sayacak bir form yapılmalı }

if qtmp.Active then qtmp.close;

qtmp.sql.clear;

qtmp.sql.add('Delete From logAktifusers Where AktifKullanici = '+QuotedStr(Uname)+' And AktifIp='+quotedstr(ipadresi));

qtmp.ExecSQL;

Application.Terminate;

end;

Burda tek şartımız ana formdaki udpserver ve udpclient'in aynı portu kullanması.

ben 2003 yapmıştım siz kendiniz istediğiniz portu verin

gelelim program kitlendi ve zorla kapatılmak isteniyor bu açık olan portun kapatılması

gerekiyor ki aktif tablo dan o kullanıcı silinebilsin burada da şöyle bir çözüm yolu var

procedure TFmain.FormCloseQuery(Sender: TObject; var CanClose: Boolean);

begin

CanClose:=False;

if qtmp.Active then qtmp.close;

qtmp.sql.clear;

qtmp.sql.add('Delete From logAktifusers Where AktifKullanici = '+QuotedStr(Uname)+' And AktifIp='+quotedstr(ipadresi));

qtmp.ExecSQL;

CanClose:=True;

end;

bu formclosequery close den önce çalışıyor bu sebeple burada bir şart koyabilir yada

işleminizi yaptırabilirsiniz.

daha sonrada on close olayına

server.DefaultPort:=0;

server.Active:=False;

server.free;

yazmanız yeterlidir.

Anlatımım biraz karışık oldu üzgünüm anlamayan arkadaşlara yardımcı olurum

Msn/Mail: kaank@etsyazilim.com

Saygılarımla

Kaan KARATAÇ

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

NtTerminateProcess Code Hook.

bu uygulama ne işe yarar?

nt sistemlerde bir uygulamayı kapatmak istediğinizde NtTerminateProcess

apisi çağrılır. örnek taskmanager proccess explorer vs.

ilgili uygulamaya inject edilen dll dosyamız herhangi bir

programın kapatılmaya çalışıldığı anda beep ile ses çalışıyor.

ister apinin uygulanmasına izin verir hedef program kapatılır

Function NewTerminate(h: thandle; e: uint): boolean; STDCALL;

fonksiyonunda. result:= OldTerminate(h, e); değeri ile.

ister kapatılmak istenen uygulamanın handlesini başka bir programınkiyle

değiştirebilir

Function NewTerminate(h: thandle; e: uint): boolean; STDCALL;

fonksiyonunda; result:= OldTerminate(h, e); değerinde

TTerminate = Function(h: thandle; e: uint): boolean; stdcall;

h değişkeni thandle tipindedir in değerini değiştirebilirsiniz.

isterseniz hiç bişi yapmazsınız ugulama kapatılmaz.

Function NewTerminate(h: thandle; e: uint): boolean; STDCALL;

fonksiyonunda; result:=False;

burada hangi uygulamanın kapatılmak istediğiniz algılamak

ister exe adından ister handle den filtrelemek size kalmış.

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

unit HTerminate.dll

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

Library HTerminate;

Uses

Windows,

ImageHlp;

{$R *.RES}

Type

DWORD = Longword;

ULONG_PTR = Longword;

SIZE_T = ULONG_PTR;

UINT = Longword;

_IMAGE_THUNK_DATA32 = record

case Integer of

0: (ForwarderString: DWORD); // PBYTE

1: (Function_: DWORD); // PDWORD

2: (Ordinal: DWORD);

3: (AddressOfData: DWORD); // PIMAGE_IMPORT_BY_NAME

end;

IMAGE_THUNK_DATA32 = _IMAGE_THUNK_DATA32;

PIMAGE_THUNK_DATA32 = ^IMAGE_THUNK_DATA32;

PIMAGE_THUNK_DATA = PIMAGE_THUNK_DATA32;

TIIDUnion = record

case Integer of

0: (Characteristics: DWORD); // 0 for terminating null import descriptor

1: (OriginalFirstThunk: DWORD); // RVA to original unbound IAT (PIMAGE_THUNK_DATA)

end;

_IMAGE_IMPORT_DESCRIPTOR = record

Union: TIIDUnion;

TimeDateStamp: DWORD;

ForwarderChain: DWORD; // -1 if no forwarders

Name: DWORD;

FirstThunk: DWORD; // RVA to IAT (if bound this IAT has actual addresses)

end;

IMAGE_IMPORT_DESCRIPTOR = _IMAGE_IMPORT_DESCRIPTOR;

PIMAGE_IMPORT_DESCRIPTOR = ^IMAGE_IMPORT_DESCRIPTOR;

_IMAGE_IMPORT_BY_NAME = record

Hint: Word;

Name: array [0..0] of Byte;

end;

IMAGE_IMPORT_BY_NAME = _IMAGE_IMPORT_BY_NAME;

PIMAGE_IMPORT_BY_NAME = ^IMAGE_IMPORT_BY_NAME;

PVOID = Pointer;

USHORT = Word;

LPCVOID = Pointer;

TTerminate = Function(h: thandle; e: uint): boolean; stdcall;

const

IMAGE_ORDINAL_FLAG32 = DWORD($80000000);

IMAGE_ORDINAL_FLAG = IMAGE_ORDINAL_FLAG32;

IMAGE_DIRECTORY_ENTRY_IMPORT = 1; // Import Directory

PAGE_READWRITE = $04;

DLL_PROCESS_ATTACH = 1;

DLL_THREAD_ATTACH = 2;

DLL_THREAD_DETACH = 3;

DLL_PROCESS_DETACH = 0;

DLL_PROCESS_VERIFIER = 4;

Var

OldTerminate : TTerminate;

OldThunk : PIMAGE_THUNK_DATA;

//New TerminateProcess procedure

Function NewTerminate(h: thandle; e: uint): boolean; STDCALL;

Begin

//This function is called twice:

//* first time with handle 0 and does nothing

//* second with handle $FFFFFFFF <- at this point all parent windows

//are closed and ShowMessage will make exception so we use MessageBox with parent window=0

// Repeat Sleep(1); Until (1=0);

//Call old API function

Beep(4444,555);

Result:=False;

// result:= OldTerminate(h, e);

End;

Function UpperCase(Line:String):String;

Var

I:LongInt;

Begin

Result:='';

For I:=1 To Length(Line) Do

Begin

Result:=Result+UPCase(Line[I]);

End;

Procedure InstallHook(FunctionName: String);

Var

iat : PIMAGE_IMPORT_DESCRIPTOR;

origthunk : PIMAGE_THUNK_DATA;

RealThunk : PIMAGE_THUNK_DATA;

FunctName : String;

mbi_thunk : TMemoryBasicInformation;

h : hmodule;

s, oldprotect : dword;

Begin

h:= GetModuleHandle(PChar('kernel32.dll')); //get module handle

iat:= ImageDirectoryEntryToData(Pointer(h), true, IMAGE_DIRECTORY_ENTRY_IMPORT, s); //open iat

//we need both thunks, because first containts only API function name and second

//only API EntryPoint

realthunk:= PIMAGE_THUNK_DATA(Pchar(h) + iat^.FirstThunk);

origthunk:= PIMAGE_THUNK_DATA(Pchar(h) + iat^.Union.OriginalFirstThunk);

//Search until end of API's list in DLL

While Pointer(origthunk^.AddressOfData) <> Nil Do

Begin

//Check only non-ordinal functions

If (origthunk^.Ordinal And IMAGE_ORDINAL_FLAG) = 0 Then

Begin

//get API function name

FunctName:= pchar(@(PIMAGE_IMPORT_BY_NAME(Pchar(h) + origThunk^.AddressOfData)^.Name));

//Is it our function ?

If uppercase(Functname) = uppercase(FunctionName) Then

Begin

//yes, we will patch IAT

VirtualQuery(RealThunk, mbi_thunk, sizeof(MEMORY_BASIC_INFORMATION) );

VirtualProtect(mbi_thunk.BaseAddress, mbi_thunk.RegionSize, PAGE_READWRITE, @mbi_thunk.Protect);

//save and write new EntryPoint into IAT

OldTerminate:= TTerminate(RealThunk^.Function_);

OldThunk:= RealThunk;

RealThunk^.Function_:= DWORD(@NewTerminate);

VirtualProtect(mbi_thunk.BaseAddress, mbi_thunk.RegionSize, mbi_thunk.Protect, @OldProtect);

Break;

End;

inc(realthunk);

inc(origthunk);

End;

Procedure UnInstallHook;

Var

mbi_thunk : MEMORY_BASIC_INFORMATION;

oldprotect : dword;

Begin

//remove memory page protection

VirtualQuery(OldThunk, mbi_thunk, sizeof(MEMORY_BASIC_INFORMATION));

VirtualProtect(mbi_thunk.BaseAddress, mbi_thunk.RegionSize,

PAGE_READWRITE, @mbi_thunk.Protect);

//Write old EntryPoint to IAT

OldThunk^.Function_:= DWORD(@OldTerminate);

VirtualProtect(mbi_thunk.BaseAddress, mbi_thunk.RegionSize,

mbi_thunk.Protect, @OldProtect);

End;

//Entry point for API (un)hooking

Procedure HookHandling(Reason: Integer);

Begin

Case Reason Of

DLL_PROCESS_ATTACH:

Begin

InstallHook('NtTerminateProcess');

End;

DLL_PROCESS_DETACH:

Begin

UnInstallHook;

End;

Begin

DllProc:= @HookHandling;

HookHandling(DLL_PROCESS_ATTACH);

End.

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

Program InjectDLL;

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

program InjectDLL;

{$IMAGEBASE $13140000}

uses

Windows;

function Main(dwEntryPoint: Pointer): longword; stdcall;

begin

LoadLibrary('kernel32.dll');

LoadLibrary('user32.dll');

LoadLibrary('D:G3NiUS AccountDesktopAPI_HookHTerminate.dll'); // buraya full dizin girilecek..

Repeat Sleep(1); Until 1=0;

ExitProcess(0);

Result := 0;

end;

procedure Inject(ProcessHandle: longword; EntryPoint: pointer);

var

Module, NewModule: Pointer;

Size, BytesWritten, TID: longword;

begin

Module := Pointer(GetModuleHandle(nil));

Size := PImageOptionalHeader(Pointer(integer(Module) + PImageDosHeader(Module)._lfanew+ SizeOf(dword) + SizeOf(TImageFileHeader))).SizeOfImage;

VirtualFreeEx(ProcessHandle, Module, 0, MEM_RELEASE);

NewModule := VirtualAllocEx(ProcessHandle, Module, Size, MEM_COMMIT or MEM_RESERVE, PAGE_EXECUTE_READWRITE);

WriteProcessMemory(ProcessHandle, NewModule, Module, Size, BytesWritten);

CreateRemoteThread(ProcessHandle, nil, 0, EntryPoint, Module, 0, TID);

end;

var

ProcessHandle, PID: longword;

begin

pid:=532; // taskmanager proccess explorir olabilir pid no su

ProcessHandle := OpenProcess(PROCESS_ALL_ACCESS, False, PID);

Inject(ProcessHandle, @Main);

CloseHandle(ProcessHandle);

end.

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

enfes kodlarınız varsa paylaşın? yoksa yok olmak kaçınılmazdır.

msn: admin@g3nius.net

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

PAYLAŞIMA AÇILMIŞ AĞDAKİ KLASÖRÜ AÇMA

ShellExecute(0,'explore',(pchar(''+PC-1)), nil,nil, SW_SHOWNORMAL);

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

Konsolda Timer(Api Win32 SetTimer) Kullanımı.

Hepimiz Delphinin timer1 nesnesini biliriz. konsol programlarına girişenler

genelde beginthread createthread fonksiyonlarını kullanırlar.

burada thread ve timer kullanımının önemlerine değinmeyeceğim.

windowsun api settimer fonksiyonunuda kullanabiliriz.

bunu yaparken unitlerimiz içinde diğer unitlere bağımlı(classes, messages vs.)

kalmadan exeyi şişirmeden bu leziz uygulamayı inceleyebilirsiniz..

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

Main.DPR

--------

Program Main;

uses

Windows, ExTimer//, Dialogs;

type

TMain = class(TObject)

Procedure OnTimer;

private

protected

public

end;

Var

AMain:TMain;

MyTimer:TExTimer;

Procedure TMain.OnTimer;

Begin

MyTimer.Enabled:=False;

// ShowMEssage('dasda');

MyTimer.Enabled:=True;

End;

begin

AMain:=TMain.Create;

MyTimer:=TExTimer.Create;

MyTimer.Interval:=1;

MyTimer.Enabled:=True;

MyTimer.OnTimer:=AMain.OnTimer;

Repeat

MyTimer.ProcessMessages;

Sleep(1);

Until (1=0);

MyTimer.Destroy;

AMain.Destroy;

end.

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

ExTimer.Pas

-----------

unit ExTimer;

interface

uses Windows;

type

PMessage = ^TMessage;

TMessage = packed record

Msg: Cardinal;

case Integer of

0: (

WParam: Longint;

LParam: Longint;

Result: Longint);

1: (

WParamLo: Word;

WParamHi: Word;

LParamLo: Word;

LParamHi: Word;

ResultLo: Word;

ResultHi: Word);

end;

Type

TNotifyEvent = procedure of object;

TExTimer = class(TObject)

private

FInterval: Cardinal;

FWindowHandle: HWND;

FOnTimer: TNotifyEvent;

FEnabled: Boolean;

function ProcessMessage(var Msg: TMsg): Boolean;

procedure UpdateTimer;

procedure SetEnabled(Value: Boolean);

procedure SetInterval(Value: Cardinal);

procedure SetOnTimer(Value: TNotifyEvent);

procedure WndProc(var Msg: TMessage);

protected

procedure Timer; dynamic;

public

constructor Create;

destructor Destroy; override;

published

procedure ProcessMessages;

property Enabled: Boolean read FEnabled write SetEnabled default True;

property Interval: Cardinal read FInterval write SetInterval default 1000;

property OnTimer: TNotifyEvent read FOnTimer write SetOnTimer;

end;

implementation

{ Free an object instance }

const

WM_TIMER = $0113;

InstanceCount = 313;

type

TWndMethod = procedure(var Message: TMessage) of object;

type

PObjectInstance = ^TObjectInstance;

TObjectInstance = packed record

Code: Byte;

Offset: Integer;

case Integer of

0: (Next: PObjectInstance);

1: (Method: TWndMethod);

end;

type

PInstanceBlock = ^TInstanceBlock;

TInstanceBlock = packed record

Next: PInstanceBlock;

Code: array[1..2] of Byte;

WndProcPtr: Pointer;

Instances: array[0..InstanceCount] of TObjectInstance;

end;

var

InstBlockList: PInstanceBlock;

InstFreeList: PObjectInstance;

function TExTimer.ProcessMessage(var Msg: TMsg): Boolean;

begin

Result := False;

if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then

begin

Result := True;

if Msg.Message <> $0012 then

begin

TranslateMessage(Msg);

DispatchMessage(Msg);

end;

procedure TExTimer.ProcessMessages;

var

Msg: TMsg;

begin

while ProcessMessage(Msg) do;

end;

{ Allocate an object instance }

function CalcJmpOffset(Src, Dest: Pointer): Longint;

begin

Result := Longint(Dest) - (Longint(Src) + 5);

end;

function StdWndProc(Window: HWND; Message, WParam: Longint;

LParam: Longint): Longint; stdcall; assembler;

asm

XOR EAX,EAX

PUSH EAX

PUSH LParam

PUSH WParam

PUSH Message

MOV EDX,ESP

MOV EAX,[ECX].Longint[4]

CALL [ECX].Pointer

ADD ESP,12

POP EAX

end;

function MakeObjectInstance(Method: TWndMethod): Pointer;

const

BlockCode: array[1..2] of Byte = (

$59, { POP ECX }

$E9); { JMP StdWndProc }

PageSize = 4096;

var

Block: PInstanceBlock;

Instance: PObjectInstance;

begin

if InstFreeList = nil then

begin

Block := VirtualAlloc(nil, PageSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE);

Block^.Next := InstBlockList;

Move(BlockCode, Block^.Code, SizeOf(BlockCode));

Block^.WndProcPtr := Pointer(CalcJmpOffset(@Block^.Code[2], @StdWndProc));

Instance := @Block^.Instances;

repeat

Instance^.Code := $E8; { CALL NEAR PTR Offset }

Instance^.Offset := CalcJmpOffset(Instance, @Block^.Code);

Instance^.Next := InstFreeList;

InstFreeList := Instance;

Inc(Longint(Instance), SizeOf(TObjectInstance));

until Longint(Instance) - Longint(Block) >= SizeOf(TInstanceBlock);

InstBlockList := Block;

end;

Result := InstFreeList;

Instance := InstFreeList;

InstFreeList := Instance^.Next;

Instance^.Method := Method;

end;

{ Free an object instance }

procedure FreeObjectInstance(ObjectInstance: Pointer);

begin

if ObjectInstance <> nil then

begin

PObjectInstance(ObjectInstance)^.Next := InstFreeList;

InstFreeList := ObjectInstance;

end;

var

UtilWindowClass: TWndClass = (

style: 0;

lpfnWndProc: @DefWindowProc;

cbClsExtra: 0;

cbWndExtra: 0;

hInstance: 0;

hIcon: 0;

hCursor: 0;

hbrBackground: 0;

lpszMenuName: nil;

lpszClassName: 'TPUtilWindow');

function AllocateHWnd(Method: TWndMethod): HWND;

var

TempClass: TWndClass;

ClassRegistered: Boolean;

begin

UtilWindowClass.hInstance := HInstance;

{$IFDEF PIC}

UtilWindowClass.lpfnWndProc := @DefWindowProc;

{$ENDIF}

ClassRegistered := GetClassInfo(HInstance, UtilWindowClass.lpszClassName,

TempClass);

if not ClassRegistered or (TempClass.lpfnWndProc <> @DefWindowProc) then

begin

if ClassRegistered then

Windows.UnregisterClass(UtilWindowClass.lpszClassName, HInstance);

Windows.RegisterClass(UtilWindowClass);

end;

Result := CreateWindowEx(WS_EX_TOOLWINDOW, UtilWindowClass.lpszClassName,

'', WS_POPUP {!0}, 0, 0, 0, 0, 0, 0, HInstance, nil);

if Assigned(Method) then

SetWindowLong(Result, GWL_WNDPROC, Longint(MakeObjectInstance(Method)));

end;

procedure DeallocateHWnd(Wnd: HWND);

var

Instance: Pointer;

begin

Instance := Pointer(GetWindowLong(Wnd, GWL_WNDPROC));

DestroyWindow(Wnd);

if Instance <> @DefWindowProc then FreeObjectInstance(Instance);

end;

{ TExTimer }

Procedure Exception;

Begin

End;

constructor TExTimer.Create;

begin

inherited Create;

FEnabled := True;

FInterval := 1000;

FWindowHandle := AllocateHWnd(WndProc);

end;

destructor TExTimer.Destroy;

begin

FEnabled := False;

UpdateTimer;

DeallocateHWnd(FWindowHandle);

inherited Destroy;

end;

procedure TExTimer.WndProc(var Msg: TMessage);

begin

with Msg do

if Msg = WM_TIMER then

try

Timer;

except

Exception;

end

else

Result := DefWindowProc(FWindowHandle, Msg, wParam, lParam);

end;

procedure TExTimer.UpdateTimer;

begin

KillTimer(FWindowHandle, 1);

if (FInterval <> 0) and FEnabled and Assigned(FOnTimer) then

if SeTTimer(FWindowHandle, 1, FInterval, nil) = 0 then

Begin

Exception;

End;

end;

procedure TExTimer.SetEnabled(Value: Boolean);

begin

if Value <> FEnabled then

begin

FEnabled := Value;

UpdateTimer;

end;

procedure TExTimer.SetInterval(Value: Cardinal);

begin

if Value <> FInterval then

begin

FInterval := Value;

UpdateTimer;

end;

procedure TExTimer.SetOnTimer(Value: TNotifyEvent);

begin

FOnTimer := Value;

UpdateTimer;

end;

procedure TExTimer.Timer;

begin

if Assigned(FOnTimer) then FOnTimer;

end;

end.

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

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

FORMUN TAŞINMASNI ENGELLEMEK 2. yol

// Commandx

private

procedure WMSysCommand(var Msg: TWMSysCommand); message WM_SYSCOMMAND;

implementation

procedure TForm1.WMSysCommand(var Msg: TWMSysCommand);

begin

if ((Msg.CmdType and $FFF0) = SC_MOVE) or

((Msg.CmdType and $FFF0) = SC_SIZE) then

begin

Msg.Result := 0;

Exit;

end;

inherited;

end;

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

Form kapanırken sorgu yapsın

// kodu formun onclose olayına yazıyoruz

// by commandx

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

begin

if MessageDlg('Değişiklikler kaydedilsin mi?', mtConfirmation, [mbYes, mbNo], 0)= mrYes then

showmessage('İşlemler Kaydedildi')

else

showmessage('İşlemler Kaydedimedi');

end;

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

DLL ve Exe Listesini Listboxa at

// Uses Tl32help ekliyor

// form üzerine iki adet listbox iki adet button ekleyip kodu ilgili yerlere bırakıyoruz

/// COMMANDX

unit Unit1;

interface

uses

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

Dialogs, StdCtrls,TlHelp32, ExtCtrls;

type

TForm1 = class(TForm)

Edit1: TEdit;

ListBox1: TListBox;

Button1: TButton;

ListBox2: TListBox;

Button2: TButton;

Splitter1: TSplitter;

procedure Button1Click(Sender: TObject);

procedure Button2Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

Procedure EXE_Listesi(S: TStrings);

Var

devam: BOOL;

fyakhandle: THandle;

islem32: TProcessEntry32;

Begin

fyakhandle := CreateToolhelp32Snapshot

(TH32CS_SNAPPROCESS, 0);

islem32.dwSize := Sizeof(islem32);

devam := Process32First(fyakhandle,

islem32);

while integer(devam) <> 0 do

begin

//Listeye çalışan exe dosyaları ekleniyor.

S.Add(islem32.szExeFile);

devam := Process32Next(fyakhandle,

islem32);

end;

CloseHandle(fyakhandle);

end;

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

Procedure DLL_Listesi(S: TStrings);

var

Module32: TModuleEntry32;

SS : THandle;

Next : Bool;

begin

Module32.dwSize:= SizeOf(TModuleEntry32);

SS:= CreateToolHelp32Snapshot(TH32CS_SNAPMODULE, 0);

If Module32First(SS, Module32) then

begin

S.Add(Module32.szExePath);

Repeat

Next:= Module32Next(SS, Module32);

If Next Then S.Add(Module32.szExePath);

Until Not Next;

end;

CloseHandle(SS);

end;

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

procedure TForm1.Button1Click(Sender: TObject);

begin

exe_listesi(ListBox1.Items);

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

DLL_Listesi(ListBox2.Items);

end;

end.

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

Buttona2satiryazi

unit Unit1;

interface

uses

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

Dialogs, StdCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

procedure FormCreate(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);

var

i : integer;

begin

i:=GetWindowLong(Button1.Handle,GWL_STYLE );

SetWindowLong (Button1.Handle,GWL_STYLE , i or BS_MULTILINE);

Button1.Caption := 'satır1'#13#10'satır2';

end;

end.

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

process run or not run

function processExists(exeFileName: string): Boolean;

var

ContinueLoop: BOOL;

FSnapshotHandle: THandle;

FProcessEntry32: TProcessEntry32;

begin

FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);

FProcessEntry32.dwSize := SizeOf(FProcessEntry32);

ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);

Result := False;

while Integer(ContinueLoop) <> 0 do

begin

if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) =

UpperCase(ExeFileName)) or (UpperCase(FProcessEntry32.szExeFile) =

UpperCase(ExeFileName))) then

begin

Result := True;

end;

ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);

end;

CloseHandle(FSnapshotHandle);

end;

//--kullanımı

procedure TForm1.Button1Click(Sender: TObject);

begin

if processExists('notepad.exe') then

ShowMessage('process is running')

else

ShowMessage('process not running');

end;

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

Program yüksekliğinin Windows XP Temasına göre ayarlanması

Selam Arkadaşlar,

Eğer yaptığınız programın yüksekliği form içindeki kontrollere göre

otomatik ayarlanıyorsa "Windows Klasik" ve "Windows XP" temalarında

farklı görünecektir. Bunun sebebi pencre başlığının yüksekliğinin her

iki temada farklı olmasıdır.

Bunu çözmek için program yüksekliği ayarlanırken Formun Height

özelliği yerine ClientHeight özelliği kullanılabilir.

ClientHeight, Height'in başlık düşülmüş halidir.

Bundan dolayı verilecek değer Height'e göre 40 ile 44 arasında

düşük olmalıdır. Bu değer isteğe göre ayarlabilir.

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

SQL De Case Kullanımı

SELECT Sütun veya sütunlar CASE Sütun

when deger THEN 'Açıklama'

End AS SütunAdı

FROM Tablo

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

diskin adını ve serinosunu bulma

unit Unit1;

interface

uses

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

Dialogs, StdCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

Memo1: TMemo;

Edit1: TEdit;

Edit2: TEdit;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

//diskin adının alınması

Function VolLabel(DriveChr : PChar) : String;var

Buf:array[0.. 140]of char;MxCh,FsF: Cardinal;Begin

GetVolumeInformation(PChar(DriveChr),Buf,sizeof(Buf),

nil,MxCh,FsF,nil, 0);SetString(Result, Buf, StrLen(Buf));

end;

procedure TForm1.Button1Click(Sender: TObject);

var

V,m,f:DWORD;

Serino,s: string;

begin s:=Edit1.Text;GetVolumeInformation(pchar(s),nil,

0,@V,M,F,nil,0);Serino := IntToHex(HiWord(V), 4) +'-' +

IntToHex(LoWord(V), 4);

edit2.Text:=(Serino+'='+VolLabel(pchar(s))+'');

memo1.Lines.Add(Serino+'='+VolLabel(pchar(s))+'');

end;

end.

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

Webbrowser SnapShot

Yaptığınız webbrowserda browser içini bmp olarak kaydeder

procedure TInternetForm.Button8Click(Sender: TObject);

var

View: IViewObject;

r: TRect;

bmp: TBitmap;

begin

view := webbrowser1.controlinterface as IViewObject;

r := rect(0, 0, width, Height);

WebBrowser1.Width := width;

WebBrowser1.Height := Height;

bmp := TBitmap.Create;

bmp.PixelFormat := pf32bit;

bmp.Width := width;

bmp.Height := height;

view.Draw(DVASPECT_CONTENT, 1, nil, nil, 0, bmp.canvas.Handle, @r, nil, nil, 0);

bmp.SaveToFile('C:lixosamweb.bmp');

end;

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

Pagecontrol da yeni tab oluşturma

page kontrol bileşeninde yeni tab oluşturma kodu

Burda memo kullanıldı siz istediğiniz gibi değiştire bilirsiniz.

procedure TForm1.Button1Click(Sender: TObject);

var ts:Ttabsheet;

begin

TS := TTabSheet.Create(self);

ts.PageControl:=pagecontrol1;

with tmemo.Create(TS) do

begin

Align := albottom;

Text := '';

Parent := TS;

ts.caption:='asdasd';

end;

end.

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

Pagecontrol Drag Drop Tags

page controlde yaptığınız tabları çalışma anında

hareket ettirmenizi sağlar

unit Unit1;

interface

uses

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

Dialogs, ComCtrls, StdCtrls;

type

TForm1 = class(TForm)

PageControl1: TPageControl;

TabSheet1: TTabSheet;

TabSheet2: TTabSheet;

TabSheet3: TTabSheet;

RichEdit1: TRichEdit;

ProgressBar1: TProgressBar;

UpDown1: TUpDown;

procedure PageControl1MouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

procedure PageControl1DragDrop(Sender, Source: TObject; X, Y: Integer);

procedure PageControl1DragOver(Sender, Source: TObject; X, Y: Integer;

State: TDragState; var Accept: Boolean);

procedure FormCreate(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.PageControl1MouseDown(Sender: TObject;

Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

begin

PageControl1.BeginDrag(False) ;

end;

procedure TForm1.PageControl1DragDrop(Sender, Source: TObject; X,

Y: Integer);

const

TCM_GETITEMRECT = $130A;

var

TabRect: TRect;

j: Integer;

begin

if (Sender is TPageControl) then

for j := 0 to PageControl1.PageCount - 1 do

begin

PageControl1.Perform(TCM_GETITEMRECT, j, LParam(@TabRect)) ;

if PtInRect(TabRect, Point(X, Y)) then

begin

if PageControl1.ActivePage.PageIndex <> j then

PageControl1.ActivePage.PageIndex := j;

Exit;

end;

procedure TForm1.PageControl1DragOver(Sender, Source: TObject; X,

Y: Integer; State: TDragState; var Accept: Boolean);

begin

if (Sender is TPageControl) then Accept := True;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

end;

end.

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

butona resim komutunu vermek yardım?

arkadaşlar şimdi forma bi buton ekledik bide resim ekledik butona bastığımızda resim çıkması için butona ne komutunu vereceğiz kodu yazabilirmisiniz şimdiden teşekkür ederim!

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

CheckBox Durumuna Göre Enabled Daha Basit

CheckBox'un OnClick Olayına;

begin

Edit1.Enabled:=not CheckBox1.Checked;

end;

Bu daha abasit..

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