[ DELPHI ] Ufak yararlı kodlar

BORLAND DELPHİ KODLARI
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;






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

uses wininet;

Function CheckUrl(url:string)lean;
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 KullaniciOnlinemilean;
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;




2.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;




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.



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 lean;
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;



3.12 TCP/IP Protokolü Kullanarak Kullanıcı Pingleme

procedure TForm1.Button1Click(Sender: TObject);
var
LocalName, LocalIp, RemoteIp, RemoteHost:string;

begin
{Degiskenlerimize TCP1 Kontrolünden Datalar Aktariliyor}

LocalName := TCP1.LocalHostName;
LocalIp := TCP1.LocalIP ;
RemoteIp := TCP1.RemoteHostIP ;
RemoteHost:= TCP1.RemoteHost ;

{Sira Geldi Kullaniciya Aktarmaya}

Canvas.TextOut(20,20,'Local Name : '+LocalName);
Canvas.TextOut(20,50,'Local Ip : '+LocalIp);
Canvas.TextOut(20,80,'Remote Ip : '+RemoteIp);
Canvas.TextOut(20,120,'Remote Host :'+RemoteHost);
end;
3.13 Başlat Menüsü Programlarının Tespit Edilmesi

{Forma bir ListBox, bir Buton, birde DDEClientConv nesnesi ekleyip, Service ve Topic özelliğini "Progman" olarak giriniz.}

var
B:Pchar;

procedure TForm1.Button1Click(Sender: TObject);
begin
ListBox1.Items.clear;
B := DDEClientConv1.RequestData('Gr oups');
ListBox1.Items.SetText(B);
StrDispose(B);
end;
3.14 Mouse'un Sağ Tuşunu Kullanmak

// Bu örnekte form üzerinde Mouse’un sağ tusuna basılınca merhaba yazan bir mesaj çıkar

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if ssright in shift then begin
MessageDlg('Merhaba', mtInformation, [mbOk], 0);
end;
end;
3.15 Windows Açılısı Sırasında Programın Çalışmasının Sağlanması

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
AppExe :string;
begin
if CheckBox1.Checked=true then begin
with TRegistry.Create do
try
RootKey := HKEY_CURRENT_USER;
if OpenKey ('\SOFTWARE\Microsoft\Windows\ CurrentVersion\Run', true) then
AppExe:=#34+Application.Exenam e+#34;
WriteString('metin', AppExe);
finally
end;
end;

//DeleteValue('metin'); //=>Programinizi Registry den
Silmek icin
end;
3.16 Ekran Çözünürlüğünün Değiştirilmesi

// AnaForm üzerine ListBox1 ve Button1 bileşenlerini yerleştiriniz

{Ana formun OnCreate olayı}

procedure TForm1.FormCreate(Sender: TObject);
var
i : Integer;
DevMode : TDevMode;
begin
Button1.Enabled:=False;
i := 0;
while EnumDisplaySettings(nil,i,Devm ode) do begin
with Devmode do
ListBox1.Items.Add(Format('%dx %d %d Colors',[dmPelsWidth,dmPelsHeight,1 shl dmBitsperPel]));
Inc(i);
end;
end;

{ListBox1'in Onclick olayı}

procedure TForm1.ListBox1Click(Sender: TObject);
// Listede istenilen cözünürlük degeri secildiginde Button1'de kullanir hale getir
begin
Button1.Enabled := Listbox1.ItemIndex >= 0;
end;

procedure TForm1.Button1Click(Sender: TObject);
// Seçilen çözünürlük değerini uygula
var
DevMode : TDevMode;
begin
EnumDisplaySettings(nil,Listbo x1.ItemIndex,Devmode);
ChangeDisplaySettings(DevMode, 0);
end;
3.17 Açık Windows Uygulamalarının Gösterilmesi

// AnaForm üzerine bir ListBox1 ve Button1 ekleyiniz

Function EnumWindowsProc(Wnd : HWnd;Form : TForm1) : Boolean;
Export; {$ifdef Win32} StdCall; {$endif}
var
Buffer : Array [0..99] of char;
begin
GetWindowText(Wnd,Buffer,100);
if StrLen(Buffer) <> 0 then
Form1.ListBox1.Items.Add(StrPa s(Buffer));
Result := True;
end;

// kullanımı

procedure TForm1.Button1Click(Sender: TObject);
begin
EnumWindows(@EnumWindowsProc,L ongInt(Self));
end;
3.18 Form Üzerinde Herhangi Bir Nesneyi Taşımak

Procedure TForm1.Button1MouseDown(Sender : TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
const
sc_DragMove=$F012;

begin
ReleaseCapture;
Button1.Perform(WM_SYSCOMMAND, sc_DragMove, 0);
end;
3.19 Saati Yok Etmek

Yok etmek için:

procedure TForm1.Button1Click(Sender: TObject);
var
Wnd : Thandle;
begin
Wnd := FindWindow('Shell_TrayWnd', nil);
Wnd := FindWindowEx(Wnd, HWND(0),'TrayNotifyWnd', nil);
Wnd := FindWindowEx(Wnd, HWND(0),'TrayClockWClass', nil);
ShowWindow(Wnd, SW_HIde);
end;

Göstermek için:

procedure TForm1.Button1Click(Sender: TObject);
var
Wnd : Thandle;
begin
Wnd := FindWindow('Shell_TrayWnd', nil);
Wnd := FindWindowEx(Wnd, HWND(0),'TrayNotifyWnd', nil);
Wnd := FindWindowEx(Wnd, HWND(0),'TrayClockWClass', nil);
ShowWindow(Wnd, SW_Show);
end;
3.20 Programı Taskbardan Saklamak

procedure TForm1.FormCreate(Sender: TObject);
begin
WS_EX_TOOLWINDOW); // taskbardan saklar
SetWindowLong(Application.Hand le, GWL_EXSTYLE, WS_EX_TOOLWINDOW);
end;
3.21 Belgeler Klasörünü Temizlemek

Uses ShlOBJ;

procedure TForm1.Button1Click(Sender: TObject);
begin
SHAddToRecentDocs(SHARD_PATH, nil);
showmessage('Temizlendi');
end;
3.22 Modemin Durumunu Kontrol Etmek

procedure TForm1.Button1Click(Sender: TObject);
var
CommPort : string;
hCommFile : THandle;
ModemStat : DWord;
begin
CommPort := 'COM2';
hCommFile := CreateFile(PChar(CommPort),
GENERIC_READ,
0,
nil,
OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL,
0);
if hCommFile = INVALID_HANDLE_VALUE then
begin
ShowMessage(CommPort+'acilamad i' );
exit;
end;
if GetCommModemStatus(hCommFile, ModemStat) <> false then begin
if ModemStat and MS_CTS_ON <> 0 then
ShowMessage('The CTS (clear-to-send) is on.');
if ModemStat and MS_DSR_ON <> 0 then
ShowMessage('The DSR (data-set-ready) is on.');
if ModemStat and MS_RING_ON <> 0 then
ShowMessage('The ring indicator is on.');
if ModemStat and MS_RLSD_ON <> 0 then
ShowMessage('RLSD (receive-line-signal-detect)');
end;
{Close the comm port}
CloseHandle(hCommFile);
end;



3.23 Ekran Koruyucuyu Program İçerisinden Çağırmak Ve Ekran Koruyucu Devreye Girdiğinde Haberdar Olmak, c

{
Bazı durumlarda programınız çalışırken ekran koruyucunun devreye
girmesini istemeyebilirsiniz ekran koruyucunun işlemci kullanımını
artırmasından dolayı. Özellikle kullanıcının işlem yapmadığı
fakat programın devamlı işler yaptığı (Seri Porttan veri transferi vb)
durumlarda faydalı olabilir.
}

uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics,
Controls, Forms, Dialogs, StdCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
CheckBox1: TCheckBox;
Label1: TLabel;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
procedure WMSysCommand(VAR Msg: TWMSysCommand);
message WM_SYSCOMMAND;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

// Ekran koruyucuyu çalıştır

procedure TForm1.Button1Click(Sender: TObject);
begin
Perform(WM_SYSCOMMAND, SC_SCREENSAVE, 0);
end;

// Ekran koruyucu devreye girmek uzere

procedure TForm1.WMSysCommand(VAR Msg: TWMSysCommand);
BEGIN
IF (Msg.CmdType AND $FFF0) = SC_SCREENSAVE THEN
IF CheckBox1.Checked THEN
BEGIN
Msg.Result := 0;
Label1.Captiion := 'Ekran koruyucunun calismasi durduruldu';
Exit;
END
ELSE Label1.Captiion := 'Ekran koruyucu calisti';
Inherited;
END;
3.24 Programda Menünün Aktif Olup Olmadığını Anlamak

const
WM_EXITMENULOOP = $212;
type
TForm1 = class(TForm)
MainMenu1: TMainMenu;
Test1: TMenuItem;
ItemA1: TMenuItem;
ItemB1: TMenuItem;
ItemC1: TMenuItem;
private
{ Private declarations }
procedure WMEnterMenuLoop(VAR Msg: TWMNoParams);
message WM_ENTERMENULOOP;
procedure WMExitMenuLoop(VAR Msg: TWMNoParams);
message WM_EXITMENULOOP;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}
procedure TForm1.WMEnterMenuLoop(VAR Msg: TWMNoParams);
BEGIN
Inherited;
Caption := 'Menu aktif';
END;

procedure TForm1.WMExitMenuLoop(VAR Msg: TWMNoParams);
BEGIN
Inherited;
Caption := 'Menu aktif degil';
END;
3.25 Windows Klasör Sec Kutusunun Gösterilmesi Ve Secilen Klasörün Alınması

uses FileCtrl;

{Ikinci parametre baslangic klasörüdür}

procedure TForm1.Button1Click(Sender: TObject);
var Result: string;
begin
if SelectDirectory('Klasor Sec', Edit1.Text, Result) then
Edit1.Text := Result
else
ShowMessage('Islem iptal edildi');
end;
3.26 Windows Sistem Help Butonuna Basılmıs Gibi Algılatmak (Win9.x, 2000)

{
Sistem butonlarindan help butonuna
basilmis gibi algilayacaktir program
}
procedure TForm1.Button1Click(Sender: TObject);
begin
SendMessage(Self.Handle, WM_SYSCOMMAND, $0000f180, $023A02B);
end;
3.27 Windows Dosya Özellikleri Kutusunun Program İçinden Açılması

uses ShellApi;

procedure ShowFileProperties(sFileName :String);
var
sei: TShellExecuteInfo;
begin
ZeroMemory(@sei, sizeof(sei));
with sei do
begin
cbSize := SizeOf(sei);
fMask := SEE_MASK_NOCLOSEPROCESS or SEE_MASK_INVOKEIDLIST or SEE_MASK_FLAG_NO_UI;
Wnd := Form1.Handle;
lpVerb := 'properties';
lpFile := PChar(sFileName);
nShow := SW_SHOWNORMAL;
end;
ShellExecuteEX(@sei);
end;

// Kullanimi:

procedure TForm1.Button1Click(Sender: TObject);
begin
ShowFileProperties(Edit1.Text) ;
end;
3.28 Windows Duvar Kağıdıni Değiştirme,Ekranı Güncelleştirme F5

// duvar kagidi degistirme

masa:='c:\windows\a.bmp';
SystemParametersInfo(SPI_SETDE SKWALLPAPER,0,Pchar(masa),0,);

// ekrani güncellestirme F5 tusuan basma gibi

SendMessaga (FindWindow('Progman','Program Manager'),WM_COMMAND,$A065,0);
3.29 Masa Üstündeki,İkonları Görünmez Yapmak

// Gizlemek için

ShowWindows(FindWindow(nil,'Pr ogram Manager'),SW_HIDE);

// Göstermek için

ShowWindows(FindWindow(nil,'Pr ogram Manager'),SW_SHOW);
3.30 Bilgisayarı Kapatmak Ya Da Bilgisayarı Yeniden Başlatmak

// Bilgisayari kapatmak için

Exitwindowsex(EWX_SHUTDOWN,0);

// Bilgisayari yeniden başlatmak için

Exitwindowsex(EWX_REBOOT,0);
3.31 Tüm Sistem İcerisinde Geçerli Bir "hotkey" Yaratmak

type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
protected
procedure hotykey(var msg:TMessage); message WM_HOTKEY;
end;

var
Form1: TForm1;
id,id2:Integer;

implementation

{$R *.DFM}


procedure TForm1.hotykey(var msg:TMessage);
begin
if (msg.LParamLo=MOD_CONTROL) and (msg.LParamHi=81) then
begin
ShowMessage('Ctrl + Q ');
end;

if (msg.LParamLo=MOD_CONTROL) and (msg.LParamHi=82) then
begin
ShowMessage('Ctrl + R ');
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
id:=GlobalAddAtom('hotkey');
RegisterHotKey(handle,id,mod_c ontrol,81);

id2:=GlobalAddAtom('hotkey2');
RegisterHotKey(handle,id2,mod_ control,82);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
UnRegisterHotKey(handle,id);
UnRegisterHotKey(handle,id2);
end;



3.32 Dokumanlar Klasörüne Bir Dosya Eklemek

uses ShellAPI, ShlOBJ;

procedure AddToStartDocumentsMenu(sFileP ath : string);
begin
SHAddToRecentDocs(SHARD_PATH, PChar( sFilePath ) );
end;
3.33 Programın End Task Menüsünde Görünmesini Engellemek (CTRL-ALT-DEL)

...
implementation

Function RegisterServiceProcess (dwProcessID, dwType: DWord) : DWord; stdcall; external 'KERNEL32.DLL';

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
// sakla
RegisterServiceProcess(GetCurr entProcessID,1);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
// tekrar göster
RegisterServiceProcess(GetCurr entProcessID,0);
end;
3.34 Sistem İcon'larının Alınması (Klasör, Dosya, Sürücü vb)

uses commctrl, shellapi;
{
Form'un uzerine TImageList, TImage ve EditBox koyun.
Edit1'in icine 0, 1, 3 .. sayilar girip Button1' basin
}

Procedure TForm1.CreateImages;
var
SysIL: HImageList;
SFI: TSHFileInfo;
begin
SysIL := SHGetFileInfo('', 0, SFI, SizeOf(SFI),
SHGFI_SYSICONINDEX or SHGFI_largeICON);
if SysIL <> 0 then begin
ImageList1.Handle := SysIL;
ImageList1.ShareImages := TRUE;
end;
End;

procedure TForm1.FormCreate(Sender: TObject);
begin
CreateImages;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
imagelist1.GetIcon(strtoint(ed it1.text), image1.picture.icon);
end;
3.35 Windows Explorer Favorites Klasörünün Alınması

Function TForm1.Favoritesfolder: string;
var
pidl: PItemIDList;
buf: array[0..MAX_PATH] of Char;
begin
if Succeeded(ShGetSpecialFolderLo cation(Handle, CSIDL_FAVORITES, pidl))
then begin
ShGetPathfromIDList(pidl, buf);
Result := buf;
end else Result:='';
end;

// Kullanimi:
procedure TForm1.Button1Click(Sender: TObject);
begin
label1.caption := Favoritesfolder;
end;
3.36 Programdan Ekran Koruyucuyu Çalıştırmak

procedure LauchScreenSaver;
begin
Windows.PostMessage(Windows.Ge tDesktopWindow,WM_SYSCOMMAND,S C_SCREENSAVE,0);
end;
3.37 Windows Taskbar'in Saklanması Ve Tekrar Gözükür Hale Getirilmesi

procedure hideTaskbar;
var wndHandle : THandle;
wndClass : array [0..50] of Char;
begin
StrPCopy(@wndClass[0], 'Shell_TrayWnd');
wndHandle := FindWindow(@wndClass[0], nil);
ShowWindow(wndHandle, SW_HIDE); // Sakla
end;

procedure showTaskbar;
var wndHandle : THandle;
wndClass : array [0..50] of Char;
begin
StrPCopy(@wndClass[0], 'Shell_TrayWnd');
wndHandle := FindWindow(@wndClass[0], nil);
ShowWindow(wndHandle, SW_RESTORE); // Göster
end;

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

procedure TForm1.Button2Click(Sender: TObject);
begin
HideTaskBar;
end;
3.38 Desktop, Quick Launch Veya Start Menu'de Kısa Yol Yaratmak

{
Uses bölümüne aşağıdaki unit'leri ekleyin:
ShlObj, ComObj, ActiveX, registry
}

type
TShortCutLocation = (slDesktop, slStartMenu, slQuickLaunch);
TShortCutLocations = set of TShortCutLocation;

procedure CreateShortCut(Description, ApplicationPath, StartFolder: string;
Locations: TShortCutLocations);
var
MyObject : IUnknown;
MySLink : IShellLink;
MyPFile : IPersistFile;
Directory : string;
WFileName : WideString;
MyReg : TRegIniFile;
begin
MyObject := CreateComObject(CLSID_ShellLin k);
MySLink := MyObject as IShellLink;
MyPFile := MyObject as IPersistFile;

with MySLink do begin
{ Parametreler icin kullanilabilir:
SetArguments(PChar(Application Path));
}
MySLink.SetPath(PChar(Applicat ionPath));
SetRelativePath(PChar(StartFol der),0);
SetWorkingDirectory(PChar(Star tFolder));
SetDescription(PChar(Descripti on));
SetIconLocation(PChar(Applicat ionPath),0);
end;
MyReg := TRegIniFile.Create('Software\M icroSoft\Windows\CurrentVersio n\Explorer');

// Desktop'a kisa yol olusturmak icin }

if slDesktop in Locations then
begin
Directory := MyReg.ReadString('Shell Folders','Desktop','');
WFileName := Directory+ '' + Description + '.lnk';
MyPFile.Save(PWChar(WFileName) ,False);
end;

// Start Menu için

if slStartMenu in Locations then
begin
Directory := MyReg.ReadString('Shell Folders','Programs','');

{ Alt Klasörde oluşturmak için:

Directory = Directory + '\KlasorAdi';
CreateDir(Directory); }

WFileName := Directory+ '' + Description + '.lnk';
MyPFile.Save(PWChar(WFileName) ,False);
end;

// QuickLaunch için

if slQuickLaunch in Locations then
begin
Directory := MyReg.ReadString('Shell Folders','Appdata','');
WFileName := Directory +
'\Microsoft\Internet Explorer\Quick Launch' +
Description + '.lnk';
MyPFile.Save(PWChar(WFileName) ,False);
end;
MyReg.Free;
end;

// Kullanimi:

procedure TForm1.Button1Click(Sender: TObject);
begin
// Desktop, Start Menu ve Quick Launch'da oluştur

CreateShortCut('Not defteri', 'c:\windows\notepad.exe', 'c:\windows',
[slDesktop, slStartMenu, slQuickLaunch]);

// Sadece Desktop ve Quick Launch'da oluştur

CreateShortCut('Not defteri', 'c:\windows\notepad.exe', 'c:\windows',
[slDesktop, slQuickLaunch]);

end;
3.39 Network'e Bağlanmış Sürücü Listesinin Alınması

Function GetNetworkDriveMappings(SList: TStrings):Integer;
Var
I:Char;
ThePath:String;
MaxNetPathLenWord;
Begin
SList.Clear;
MaxNetPathLen:=MAX_PATH;
SetLength(ThePath,MAX_PATH);
For I := 'A' to 'Z' Do
If WNetGetConnection(
PChar(''+I+':'),PChar(ThePath) ,
MaxNetPathLen)=NO_ERROR Then
SList.Add(I+': '+ThePath);
Result := SList.Count;
End;

// Kullanımı:

procedure TForm1.Button1Click(Sender: TObject);
begin
GetNetworkDriveMappings(Form1. ListBox1.Items);
end;
3.40 Çalışan Bir Exe'nin Silinmesi

{ Bu işlem için windows'un tekrar başlatılması gereklidir. }

uses Registry;

procedure DeleteNextTime(const FileName: string);
begin
with TRegistry.Create do
begin
RootKey := HKEY_LOCAL_MACHINE;
LazyWrite := False;
OpenKey('Software\Microsoft\Wi ndows\CurrentVersion\RunOnce', False);
WriteString('Delete Me','command.com /c del ' + FileName);
CloseKey;
free;
end;
end;


3.41 Windows Ve Sistem Klasörlerinin Alınması

{
Her bilgisayarda Windows c:\windows klasörune
kurulmamis olabilir
}
Function GetWinDir: String;
var
dir: array [0..max_path] of char;
begin
GetWindowsDirectory(dir, max_path);
result:=StrPas(dir);
end;

Function GetSysDir: String;
var
dir: array [0..max_path] of char;
begin
GetSystemDirectory(dir, max_path);
result:=StrPas(dir);
end;

// Kullanımı:

procedure TForm1.Button1Click(Sender: TObject);
begin
label1.caption:=GetWinDir;
label2.caption:=GetSysDir;
end;
3.42 Bilgisayar Adının Alınması

{ Bilgisayar'a login olmus kullanici adi ile karistirmayiniz}

Function GetCompName: string;
var
buffer : array 0..MAX_COMPUTERNAME_LENGTH+1] of Char;
length:Cardinal;
begin
length:=MAX_COMPUTERNAME_LENGT H+1;
GetComputerName(@Buffer,length );
Result := Buffer;
end;

// Kullanımı:

procedure TForm1.Button1Click(Sender: TObject);
begin
Label1.Caption := GetCompName;
end;
3.43 Windows İcon Ve Bitmap'lerini Program İçinden Almak

{
Çeşitli icon sabitleri:
( Daha Fazlası için Windows unit'ine bakın )

- IDI_APPLICATION
- IDI_ASTERISK
- IDI_EXCLAMATION
- IDI_HAND
- IDI_QUESTION
}

// Icons
procedure TForm1.Button1Click(Sender: TObject);
begin
Image1.Picture.Icon.Handle:=Lo adIcon(0,IDI_HAND);
end;
{
Bitmap sabitleri:
(Daha fazlasi icin Windows unit'ine bakin)
- OBM_BTNCORNERS
- OBM_BTSIZE
- OBM_CHECK
- OBM_CHECKBOXES
- OBM_CLOSE
- OBM_COMBO
- OBM_DNARROW
- OBM_DNARROWD
- OBM_DNARROWI
- OBM_LFARROW
- OBM_LFARROWD
- OBM_LFARROWI
- OBM_MNARROW
- OBM_REDUCE
- OBM_RESTORE
- OBM_REDUCED
- OBM_SIZE
- OBM_UPARROW
- OBM_ZOOM
}

// Bitmap:
procedure TForm1.Button2Click(Sender: TObject);
begin
image1.picture.bitmap.Handle:= LoadBitmap(0,makeintresource(O BM_RESTORE));
end;
3.44 Start Button'u Gizlemek Ve Tekrar Gözükür Hale Getirmek

// Gizlemek için

Procedure HideStartButton;
Var
taskbarhandle,
buttonhandle : HWND;
begin
taskbarhandle := FindWindow('Shell_TrayWnd', nil);
buttonhandle := GetWindow(taskbarhandle, GW_CHILD);
ShowWindow(buttonhandle, SW_HIDE);
end;

// Tekrar göstermek için

Procedure ShowStartButton;
Var
taskbarhandle,
buttonhandle : HWND;
begin
taskbarhandle := FindWindow('Shell_TrayWnd', nil);
buttonhandle := GetWindow(taskbarhandle, GW_CHILD);
ShowWindow(buttonhandle, SW_RESTORE);
end;

// Kullanımı:

{ Gizle }
procedure TForm1.Button1Click(Sender: TObject);
begin
HideStartButton;
end;

{ Göster }
procedure TForm1.Button2Click(Sender: TObject);
begin
ShowStartButton;
end;
3.45 Windows Start Menu Resminin Değiştirilmesi

var
Form1: TForm1;
StartButton: hWnd;
OldBitmap: THandle;
NewImage: TPicture;

procedure TForm1.FormCreate(Sender: TObject);
begin
NewImage := TPicture.create;
NewImage.LoadFromFile('C:\Wind ows\Circles.BMP');
StartButton := FindWindowEx
(FindWindow(
'Shell_TrayWnd', nil),
0,'Button', nil);
OldBitmap := SendMessage(StartButton,
BM_SetImage, 0,
NewImage.Bitmap.Handle);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
SendMessage(StartButton,BM_Set Image,0,OldBitmap);
NewImage.Free;
end;
3.46 ALT-TAB Tuşunu Kullanılmaz Hale Getirmek

procedure DisableAltTab;
var
iTemp: Integer;
begin
iTemp := 0;
SystemParametersInfo(SPI_SETFA STTASKSWITCH, 1, @iTemp, 0);
end;
3.47 Dosya Tipini Windows'a Kaydettirmek Ve Herhangi Bir Programla Açılmasını Sağlamak

procedure RegisterExtension(const sExt, sDesc, AppPath: string);
begin
with TRegistry.Create do
try
RootKey := HKEY_CLASSES_ROOT;
if OpenKey(sExt, True) then begin
WriteString('', sDesc);
CloseKey;
end;
if OpenKey('' + sDesc, True) then begin
WriteString('', sDesc);
CloseKey;
end;
if OpenKey('DefaultIcon', True) then begin
WriteString('', AppPath + ',' + IntToStr(0));
CloseKey;
end;
if OpenKey('' + sDesc + '\Shell\Open\Command', True) then begin
WriteString('', '"' + AppPath + '" "%1"');
CloseKey;
end;
finally
Free;
end;
end;

// Kullanımı:

procedure TForm1.Button1Click(Sender: TObject);
begin
RegisterExtension('.den', 'Deneme Dosyasi', 'C:\windows\notepad.exe')
end;
3.48 Windowsu Kullanarak Dosya Kopyalama İşlemi

Function CopyFiles(const Source,Destination: String): Boolean;
var
SHFileOpStruct : TSHFileOpStruct;
begin
if FileExists(Source) then
begin
FillChar(SHFileOpStruct,SizeOf (TSHFileOpStruct),#0);
with SHFileOpStruct do begin
Wnd:=Application.Handle;
wFunc:=FO_COPY;
fFlags:=FOF_ALLOWUNDO;
hNameMappings:=nil;
pFrom:=PChar(Source+#0+#0);
pTo:=PChar(Destination+#0+#0);
end;
Result := ShFileOperation(SHFileOpStruct ) = 0;
end else Result := False;
end;

// Kullanımı:

procedure TForm1.Button1Click(Sender: TObject);
begin
if not CopyFiles('C:\windows\notepad. exe', 'C:\sil\notepad.exe') then
showmessage('Kopyalama islemi basarisiz');
end;
3.49 Sisteme Login Olmuş Kullanıcı Adının Alınması

Function GetNetUser : Ansistring;
var
dwI : DWord;
begin
dwI := MAX_PATH;
SetLength (Result, dwI + 1);
if WNetGetUser (Nil, PChar (Result), dwI) = NO_ERROR then
SetLength (Result, StrLen (PChar (Result)))
else
SetLength (Result, 0)
end;


3.50 Windows Explorer'dan Program'a Sürüklenen Dosyaların Program Tarafindan Alınması

Uses ShellApi;

procedure TForm1.FormCreate(Sender: TObject);
begin
DragAcceptFiles(Form1.Handle, true);
Application.OnMessage := AppMessage;
end;

procedure TForm1.AppMessage(var Msg: Tmsg; var Handled: Boolean);
const
BufferLength : DWORD = 511;
var
DroppedFilename : string;
FileIndex : DWORD;
NumDroppedFiles : DWORD;
pDroppedFilename : array [0..511] of Char;
DroppedFileLength : DWORD;
begin
if Msg.message = WM_DROPFILES then
begin
FileIndex := $FFFFFFFF;
NumDroppedFiles := DragQueryFile(Msg.WParam, FileIndex,
pDroppedFilename, BufferLength);
Memo1.Lines.Clear;
for FileIndex := 0 to (NumDroppedFiles - 1) do
begin
DroppedFileLength := DragQueryFile(Msg.WParam, FileIndex,
pDroppedFilename,
BufferLength);
DroppedFilename := StrPas(pDroppedFilename);
Memo1.Lines.Add(pDroppedFilena me);
end;
DragFinish(Msg.WParam);
Handled := true;
end;
end;
3.51 Kontrol Panel'deki Ayarları Açmak

{
Exampels of AppletFileNames:
---------------------------------------------
Timedate.cpl : Time and date
Joy.cpl : Game controlers
Telephon.cpl : TAPI
bdeadmin.cpl : BDE administrator
odbccp32.cpl : 32 bit ODBC setup
directx.cpl : DirectX
Appwiz.cpl : Add and remove programs
Desk.cpl : Desktop and Screen
Inetcpl.cpl : Internet
Intl.cpl : International settings
Main.cpl : Mouse
Mmsys.cpl : Multimedia
Modem.cpl : Modem
Netcpl.cpl : Network
Password.cpl : Password
Powercfg.cpl : Power configuration
}
Function RunControlPanelApplet(AppletFi leName:string):Integer;
Begin
Result:=WinExec(PChar('rundll3 2.exe shell32.dll,'+
'Control_RunDLL '+AppletFileName),SW_SHOWNORMA L);
End;
3.52 Programdan Start Menu'yu Açmak

Sendmessage(Application.Handle ,WM_SYSCOMMAND,SC_TASKLIST,0);
3.53 Recycle Bin'in Program İçinden Boşaltılması

procedure EmptyRecycleBin;
const
SHERB_NOCONFIRMATION = $00000001;
SHERB_NOPROGRESSUI = $00000002;
SHERB_NOSOUND = $00000004;
type
TSHEmptyRecycleBin = function (Wnd: HWND;
LPCTSTR: PChar;
DWORD: Word): integer; stdcall;
var
SHEmptyRecycleBin: TSHEmptyRecycleBin;
LibHandle: THandle;
begin
LibHandle := LoadLibrary(PChar('Shell32.dll '));
if LibHandle <> 0 then
@SHEmptyRecycleBin := GetProcAddress(LibHandle, 'SHEmptyRecycleBinA')
else
begin
MessageDlg('Failed to load Shell32.dll.', mtError, [mbOK], 0);
Exit;
end;

if @SHEmptyRecycleBin <> nil then
SHEmptyRecycleBin(Application. Handle,
'',
SHERB_NOCONFIRMATION or
SHERB_NOPROGRESSUI or
SHERB_NOSOUND);

FreeLibrary(LibHandle);
@SHEmptyRecycleBin := nil;
end;
3.54 Sistemin Desteklediği Tüm Ekran Modlarının Alınması

procedure GetVideoModes(ModeList: TStringList);
var
i, j: integer;
MoreModes,
AddMode: boolean;
dm: TDeviceMode;
Mode: string;
begin
ModeList.Clear;
MoreModes := True;
Mode := '';
i := 0;
while MoreModes do
begin
MoreModes := EnumDisplaySettings(nil, i, dm);
Mode := IntToStr(dm.dmBitsPerPel) + ' Bits Per Pixel ' +
IntToStr(dm.dmPelsWidth) + ' x ' +
IntToStr(dm.dmPelsHeight);
AddMode := True;
for j := 0 to ModeList.Count-1 do
if Mode = ModeList[j] then
AddMode := False;
if AddMode then
ModeList.Add(Mode);
Inc(i);
end;
end;

// Kullanımı:

procedure TForm1.Button1Click(Sender: TObject);
begin
GetVideoModes(TStringList(memo 1.lines));
end;
3.55 Form Menüsünde Kapat Komutunun Yok Edilmesi

procedure TForm1.FormCreate(Sender: TObject);
var
hwndHandle : THANDLE;
hMenuHandle : HMENU;
iPos:Integer;
begin
hwndHandle := FindWindow(nil,PChar(Caption)) ;

if (hwndHandle <> 0) then begin
hMenuHandle := GetSystemMenu(hwndHandle, FALSE);
if (hMenuHandle <> 0) then begin
DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND);
iPos := GetMenuItemCount(hMenuHandle);
Dec(iPos);
{ Make sure no errors occured i.e. -1 indicates an error }
if iPos > -1 then
DeleteMenu(hMenuHandle,iPos,MF _BYPOSITION);
end;
end;
end;
3.56 Temp Klasörün Alınması

Function GetTempDir: string;
var
lng: DWORD;
begin
SetLength(Result, MAX_PATH);
lng := GetTempPath(MAX_PATH, PChar(Result));
SetLength(Result, lng);
end;

// Kullanımı:

procedure TForm1.Button1Click(Sender: TObject);
begin
label1.caption := GetTempDir;
end;
3.57 Herhangi Bir Programın Sürümü Nasıl Alınır ?

procedure GetBuildInfo(const AppName: string;
var V1, V2, V3, V4: Word);
var
VerInfoSize,
VerValueSize,
Dummy : DWORD;
VerInfo : Pointer;
VerValue : PVSFixedFileInfo;
begin
VerInfoSize := GetFileVersionInfoSize(PChar(A ppName), Dummy);
GetMem(VerInfo, VerInfoSize);
GetFileVersionInfo(PChar(AppNa me), 0, VerInfoSize, VerInfo);
VerQueryValue(VerInfo, '', Pointer(VerValue), VerValueSize);
with VerValue^ do
begin
V1 := dwFileVersionMS shr 16;
V2 := dwFileVersionMS and $FFFF;
V3 := dwFileVersionLS shr 16;
V4 := dwFileVersionLS and $FFFF;
end;
FreeMem(VerInfo, VerInfoSize);
end;

// Kullanımı:

procedure TForm1.Button1Click(Sender: TObject);
var v1, v2, v3, v4: word;
begin
GetBuildInfo('C:\windows\notep ad.exe', v1, v2, v3, v4);
Label1.Caption := Format('%d.%d.%d.%d', [V1, V2, V3, V4]);
end;



3.58 Program Çalıştırmak Ve Bitene Kadar Beklemek

Function RunProcess(const AppPath:string; MustWait: Boolean;
AppParams: string; Visibility: Word)WORD;
var
SI: TStartupInfo;
PI: TProcessInformation;
Proc: THandle;
zFileName, zParams: array [0..79] of Char;
begin
FillChar(SI, SizeOf(SI), 0);
SI.cb := SizeOf(SI);
SI.wShowWindow := Visibility;
if not CreateProcess(StrPCopy(zFileNa me, AppPath),
StrPCopy(zParams, AppParams),
nil, nil, false, Normal_Priority_Class, nil, nil, SI, PI) then
raise Exception.CreateFmt('Failed to excecute program ' +
AppPath + '. Error Code %d', [GetLastError]);

Proc := PI.hProcess;
CloseHandle(PI.hThread);

if MustWait then
if WaitForSingleObject(Proc, Infinite) <> Wait_Failed then
GetExitCodeProcess(Proc, Result);
CloseHandle(Proc);
end;

// Kullanımı:

RunProcess('notepad.exe', True, '', SW_SHOWNORMAL);
3.59 Form Başlık Yerine Tüm Yüzeyden Nasıl Sürüklenir ?

{ Aşağıdaki kodun Form üzerindeki tüm bileşenlerin
onmousedown event handler'ine konulması gerekir }

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
ReleaseCapture;
Form1.perform(WM_SYSCOMMAND, $F012, 0);
end;
3.60 Herhangi Bir Wincontrol' Veya Tüm Ekran Nasıl Bitmap Olarak Alınır ?

Function GetDcAsBitmap(DC: HDC; Bitmap: TBitmap; W, H: Cardinal): Boolean;
var
hdcCompatible: HDC;
hbmScreen: HBitmap;
begin
Result := False;
if DC = 0 then Exit;
hdcCompatible := CreateCompatibleDC(DC);
hbmScreen := CreateCompatibleBitmap(DC, W, H);
if (hbmScreen = 0) then Exit;
if (SelectObject(hdcCompatible, hbmScreen)=0) then Exit;
if not (BitBlt(hdcCompatible, 0,0, W, H, DC, 0,0, SRCCOPY)) then
Exit;
Bitmap.Handle := HbmScreen;
Bitmap.Dormant;
Result := True;
end;

Function GetScreenAsBitmap(Bitmap: TBitmap): Boolean;
var ScreenDC: HDC;
begin
ScreenDC := CreateDC('DISPLAY', NIL, NIL, NIL);
Result := GetDCAsBitmap(ScreenDC, Bitmap,
GetDeviceCaps(ScreenDC, HORZRES),
GetDeviceCaps(ScreenDC, VERTRES)
);
end;

Function GetWindowAsBitmap(const WindowName: string;
Bitmap: TBitmap): Boolean;
var Wnd: HWnd;
Rect: TRect;
begin
Wnd := FindWindow(nil, PChar(WindowName));
GetWindowRect(Wnd, Rect);
Result := GetDCAsBitmap(GetWindowDC(Wnd) , Bitmap,
Rect.Right - Rect.Left, Rect.Bottom - Rect.Top);
end;

Function GetWindowAsBitmap(Wnd: HWnd; Bitmap: TBitmap): Boolean;
var
Rect: TRect;
begin
GetWindowRect(Wnd, Rect);
Result := GetDCAsBitmap(GetWindowDC(Wnd) , Bitmap,
Rect.Right - Rect.Left, Rect.Bottom - Rect.Top);
end;

// Kullanımı:
{ Button1 yüzeyini resim olarak al }

GetWindowAsBitmap(Button1.Hand le, Image1.Picture.Bitmap);

{ Tüm ekranı resim olarak al }

GetScreenAsBitmap(Image1.Pictu re.Bitmap);
3.61 Ekran Çözünürlüğünün Değiştirilmesi

procedure SetRes(XRes, YRes: DWord);
var
lpDevMode : TDeviceMode;
begin
EnumDisplaySettings(nil, 0, lpDevMode);
lpDevMode.dmFields:=DM_PELSWID TH or DM_PELSHEIGHT;
lpDevMode.dmPelsWidth:=XRes;
lpDevMode.dmPelsHeight:=YRes;
ChangeDisplaySettings(lpDevMod e, 0);
end;

// Kullanimi:
Setres(800, 600);
3.62 Dosyayı Windows Recycle Bin'e Göndermek

Function SendToRecycleBin(FileToRecycle : TFilename): boolean;
var Struct: TSHFileOpStruct;
pFromc: array [0..255] of char;
Resultval: integer;
begin
if not FileExists(FileToRecycle) then begin
Result := False;
exit;
end
else begin
fillchar(pfromc,sizeof(pfromc) ,0);
StrPcopy(pfromc,expandfilename (FileToRecycle)+#0#0);
Struct.wnd := 0;
Struct.wFunc := FO_DELETE;
Struct.pFrom := pFromC;
Struct.pTo := nil;
Struct.fFlags:= FOF_ALLOWUNDO;
Struct.fAnyOperationsAborted := false;
Struct.hNameMappings := nil;
Resultval := ShFileOperation(Struct);
Result := (Resultval = 0);
end;
end;
3.63 Programdan Bir İnternet Adresini Yeni Ve İstenilen Özelliklerde Bir Pencerede Açmak

procedure TFmMain.GotoUrl(SUrl: string; Width, Height: Integer; ToolBar: Boolean);
const
csOLEObjName = 'InternetExplorer.Application' ;
var
IE : Variant;
WinHanlde : HWnd;
begin
if ( VarIsEmpty( IE ) ) then
begin
IE := CreateOleObject( csOLEObjName );
IE.Visible := true;
IE.Toolbar := Toolbar;
if Width > 0 then IE.Width := Width;
if Height > 0 then IE.Height := Height;
IE.Navigate( sURL );
end else
begin
WinHanlde := FindWIndow( 'IEFrame', nil );
if ( 0 <> WinHanlde ) then
begin
IE.Navigate( sURL );
SetForegroundWindow( WinHanlde );
end else
begin
ShowMessage('Internet Explorer açılamadı');
end;
end;
end;

// Kullanımı:

{ Adresi Yükseklik Ve Genişlik Belirtmeden Açar }

GotoUrl('http://www.delphiturk.com', 0, 0, True);

{ Adresi Yükseklik Ve Genişlik Belirterek Toolbar
Olmayan Bir Pencerede Açar }

GotoUrl('http://www.delphiturk.com', 400, 400, False);
3.64 Programdan Windows Wallpaper'i Değiştirme İşlemi

procedure TForm1.ChangeWallPaper(const FileName: string);
begin
SystemParametersInfoA(SPI_SETD ESKWALLPAPER, 0,
PChar(FileName), SPIF_UPDATEINIFILE);
end;
3.65 Formun Etrafı Boyalı

private
procedure PaintFrame(var Msg : TWMNCPaint); message WM_NCPAINT;
{ Private declarations }
public
{ Public declarations }
end;

procedure TForm1.PaintFrame(var Msg: TWMNCPaint);
var dc : hDc;
P : hPen;
OP : hPen;
OB : hBrush;
begin
inherited;
dc := GetWindowDC(Handle);
msg.Result := 1;
P := CreatePen(PS_SOLID, 10, clYellow );
OP := SelectObject(dc, P);
OB := SelectObject(dc, GetStockObject(NULL_BRUSH));
Rectangle(dc, 0,0, Width, Height);
SelectObject(dc, OB);
SelectObject(dc, OP);
DeleteObject(P);
ReleaseDC(Handle, Canvas.Handle);
end;


3.66 Formu Animasyonlu Bir Şekilde Açtırmak

procedure Tform1.FormShow(Sender: TObject);
begin
{ Formu Soldan Sağa Doğru Açar }
AnimateWindow(Self.Handle,250, AW_HOR_POSITIVE or AW_ACTIVATE);
{ Formu Ortadan Küçükten Büyüterek Açar }
AnimateWindow(Self.Handle,500, AW_CENTER or AW_ACTIVATE);
{ Formu Yukarıdan Aşağıya Doğru Açar }
AnimateWindow(Self.Handle, 250, AW_VER_POSITIVE or AW_ACTIVATE);

end;
3.67 Trayicon Kısmında Programın Simgesini Çıkartarak Ve Kullanılması

{ Programınızın Exe’sinin olduğu Klasörde Res uzantılı bir dosyanız olmalıdır. Bu dosyanın içinde Trayicon kısmında çıkan programınıza ait icon dosyası bulunmalıdır. Bu Dosyayı Delphi’nin Tools / Image Editor Menüsünü kullanarak oluşturabilirsiniz. }

Uses ShellApi;

Const
wm_IconMessage = wm_User;

{ Delphi’nin Type kısmının üstüne kendiniz bu Type bölümünü yazıyorsunuz. }

Type
TNotifyIconData = record
cbSize : DWORD;
hWnd : HWND;
uID : UINT;
uFlags : UINT;
uCallbackMessage : UINT;
hIcon : HICON;
szTip : array [0..63] of AnsiChar;
End;

Type
TForm1 = class(TForm)
procedure TrayIconDurumFree;
procedure TrayIconDurumLock;

private
nid : TNotifyIconData;
public
procedure IconTray(var Msg: TMessage);
message wm_IconMessage;
end;

var
Form1: TForm1;
TrayIconDurum : Boolean;

implementation

uses Winamp2, Winamp3, Winamp4;

{$R *.DFM}
{$R RES.res} // Res dosyası

procedure TForm1.TrayIconDurumLock;
Begin
TrayIconDurum := False;
end;

procedure TForm1.TrayIconDurumFree;
Begin
TrayIconDurum := True;
end;

procedure TForm1.IconTray(var Msg: TMessage);
Var
Pt : TPoint;
begin
if Msg.LParam = wm_rbuttondown Then
Begin
If TrayIconDurum = True Then
Begin
GetCursorPos(Pt);
SetForegroundWindow(Handle);
PopupMenu1.Popup(Pt.x,Pt.y);
End
Else
Begin
Application.MessageBox('Ana menu şuan pasif çalışmaktadır. Ana menuye dönmek için lütfen aktif pencereyi kapatınız...',
'Program Mesajı',Mb_Ok + Mb_IconInformation);
End;
End;
if Msg.LParam = wm_Lbuttondblclk Then
Begin
If TrayIconDurum = True Then
Begin
ShowWindow(Handle,sw_ShowNorma l);
SetForegroundWindow(Handle);
Show;
End
Else
Begin
Application.MessageBox('Ana menu şuan pasif çalışmaktadır. Ana menuye dönmek için lütfen aktif pencereyi kapatınız...',
'Program Mesajı',Mb_Ok + Mb_IconInformation);
End;
End;
end;

{ Form1’de Timer ve Popup Menünün olması Gerekiyor. Popup Menü Trayicon’daki ikon’un üzerinde sağ Tıklayınca çıkıyor. Eğer popup menü istemiyorsanız, Menünün içini doldurmazsınız. Fakat olması gereklidir. Ve Form1’den başka diğer formların Activate’lerine Form1.TrayIconDurumLock; komutunu FormClose olayına’da Form1.TrayIconDurumFree; komutunu yazıyorsunuz. Bu Form1 yani AnaFormun üzerinde başka bir form Aktif ise siz Trayicon’a Çift Tıkladığınızda veya sağ tıkladığınızda karşınıza ‘Ana Menü Pasif Çalışmaktadır. Lütfen Aktif Pencereyi Kapatınız... ‘ diye bir mesaj çıkar. }

procedure TForm1.FormCreate(Sender: TObject);
begin
// Res dosyasındaki ikon Adı .....
Icon.Handle := LoadIcon(HInstance,'WINAMP');
nid.cbSize := sizeof(nid);
nid.hWnd := Handle;
nid.uID := 1; //simge ID
nid.uCallbackMessage := wm_IconMessage;
nid.hIcon := Icon.Handle;
nid.szTip := 'AzmanSoft MP3 Player';
nid.uFlags := nif_Message or nif_Icon or nif_Tip;
Shell_NotifyIcon(NIM_ADD, @nid);
Timer1Timer(Self);
// Programın Adını Görev Çubuğundan Gizleme ....
SetWindowLong(Application.Hand le, GWL_EXSTYLE, WS_EX_TOOLWINDOW);
end;
{ Minimize Butonuna Basılınca Formu Gizlemek }
ShowWindow(Handle,Sw_Hide);

{ Formu Tekrar Ekrana Açmak }
ShowWindow(Handle,sw_ShowNorma l);
SetForegroundWindow(Handle);
Show;

{ Programı Kapat Butonu }
Close;


devamı gelecek....

Cok ugraşmıssın kardesım belli oluyor ınceledım cok guzel ... !...

Yha Bu ne yha !!