Programlama yapalım ve Öğrenelim.

Windows geçici klasörünün bulunması

Windows 95 ve NT işletim sistemlerinde, geçici dosyalar için kullanılan, genellikle "TEMP" isimli bir klasör vardır. Fakat bazen kullanıcılar bu dizinin adını veya yerini değiştirirler. Aşağıdaki fonksiyon, geçici dizini tespit eder.

function GetTempDirectory: String;

var

TempDir: array[0..255] of Char;

begin

GetTempPath(255, @TempDir);

Result := StrPas(TempDir);

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

showmessage(gettempdirectory);

end;

Windows sistem dizininin bulunması

Var

SysDir: PChar;

Size: Word;

SysDirInString : String[144];

Begin

SysDir := '';

GetSystemDirectory(SysDir, Size);

SysDirInString := StrPas(SysDir);

Canvas.TextOut(10, 10, SysDirInString);

end;

Dosya yaratılma tarihi

Bu fonksiyon, dosyanın yaratıldığı tarihi döndürür.

Function File_GetCreationDate(FileName : String): TDateTime;

var

SearchRec : TSearchRec;

DT : TFileTime;

ST : TSystemTime;

begin

Result := 0;

If Not FileExists(FileName) Then Exit;

Try

SysUtils.FindFirst(FileName, faAnyFile, SearchRec);

Try

FileTimeToLocalFileTime(SearchRec.FindData.ftCreationTime,DT);

FileTimeToSystemTime(DT, ST);

Result := SystemTimeToDateTime(ST);

Finally

SysUtils.FindClose(SearchRec);

End;

Except

Result := 0;

End;

end;

Dosyanın son kullanıldığı tarih

Bu fonksiyon, dosyanın, son olarak kullanıldığı tarihi döndürür.

Function File_GetLastAccessDate(FileName : String): TDateTime;

var

SearchRec : TSearchRec;

DT : TFileTime;

ST : TSystemTime;

begin

Result := 0;

If Not FileExists(FileName) Then Exit;

Try

SysUtils.FindFirst(FileName, faAnyFile, SearchRec);

Try

FileTimeToLocalFileTime(SearchRec.FindData.ftLastAccessTime,DT);

FileTimeToSystemTime(DT, ST);

Result := SystemTimeToDateTime(ST);

Finally

SysUtils.FindClose(SearchRec);

End;

Except

Result := 0;

End;

end;

Dosyanın son değiştirildiği tarih

Bu fonksiyon, FileName parametresi ile gönderilen dosyanın, son olarak değiştirildiği tarihi bulmaya yarar.

Function File_GetLastModifiedDate(FileName : String): TDateTime;

var

SearchRec : TSearchRec;

DT : TFileTime;

ST : TSystemTime;

begin

Result := 0;

If Not FileExists(FileName) Then Exit;

Try

SysUtils.FindFirst(FileName, faAnyFile, SearchRec);

Try

FileTimeToLocalFileTime(SearchRec.FindData.ftLastWriteTime,DT);

FileTimeToSystemTime(DT, ST);

Result := SystemTimeToDateTime(ST);

Finally

SysUtils.FindClose(SearchRec);

End;

Except

Result := 0;

End;

end;

Dizin boşmu?

DirName parametresi ile gönderilen dizinin boş olup olmadığını kontrol etmeye yarayan bir fonksiyon.

Function IsDirEmpty(DirName: String): Boolean;

Begin

If IsDir(DirName) Then

Begin

If IsFile(DirName+'*.*') Then

Begin

Result := False;

End

Else

Begin

Result := True;

End;

End

Else

Begin

Result := False;

End;

Dosya uzantısı hangi programla bağlantılı?

Bir dosyanın uzantısına bakarak, hangi program tarafından çalıştırılacağının bulunması için aşağıdaki kod örneği kullanılabilir.

unit Unit1;

interface

uses

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

StdCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);

const

BufferSize = {$IFDEF Win32} 540 {$ELSE} 80 {$ENDIF};

var

Buffer : PChar;

StringPosition : PChar;

ReturnedData: Longint;

begin

Buffer := StrAlloc(BufferSize);

try

{ get the first entry, don't bother about the version !}

ReturnedData := BufferSize;

StrPCopy(Buffer, '.pas');

RegQueryValue(hKey_Classes_Root, Buffer, Buffer, ReturnedData);

if StrLen(Buffer) > 0 then

begin

showmessage(strpas(buffer));

end;

except

showmessage('bulunamadı');

end;

end.

Geri dönüşüm kutusuna gönder.

Bir dosyayı, geri dönüşüm kutusuna göndererek silmek için ;

unit Unit1;

interface

uses

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

StdCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

uses

ShellApi;

function DF(sFileName : string ) : boolean;

var

fos : TSHFileOpStruct;

begin

FillChar( fos, SizeOf( fos ), 0 );

with fos do

begin

Wnd := application.handle;

wFunc := FO_DELETE;

pFrom := PChar( sFileName );

fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMATION or FOF_SILENT;

end;

Result := ( 0 = ShFileOperation( fos ) );

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

df('c:&quotWP.txt');

end;

end.

6. Genel

Bu bölümde, diğer başlıklar altında yer almayan püf noktaları ve kod örnekleri yer almaktadır.

Karakter dizisi karşılaştırma

unit matchstring;

interface

uses

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

StdCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

CheckBox1: TCheckBox;

Edit1: TEdit;

Edit2: TEdit;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

function MatchStrings(source, pattern: String): Boolean;

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

function tform1.MatchStrings(source, pattern: String): Boolean;

var

pSource: Array [0..255] of Char;

pPattern: Array [0..255] of Char;

function MatchPattern(element, pattern: PChar): Boolean;

function IsPatternWild(pattern: PChar): Boolean;

var

t: Integer;

begin

Result := StrScan(pattern,'*') <> nil;

if not Result then Result := StrScan(pattern,'?') <> nil;

end;

begin

if 0 = StrComp(pattern,'*') then

Result := True

else if (element^ = Chr(0)) and (pattern^ <> Chr(0)) then

Result := False

else if element^ = Chr(0) then

Result := True

else begin

case pattern^ of

'*': if MatchPattern(element,@pattern[1]) then

Result := True

else

Result := MatchPattern(@element[1],pattern);

'?': Result := MatchPattern(@element[1],@pattern[1]);

else

if element^ = pattern^ then

Result := MatchPattern(@element[1],@pattern[1])

else

Result := False;

end;

begin

StrPCopy(pSource,source);

StrPCopy(pPattern,pattern);

Result := MatchPattern(pSource,pPattern);

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

checkbox1.checked:=matchstrings(edit1.text,edit2.text);

end;

end.

Yüklenmiş DLL dosyalarının hafızadan atılması

Kullanılmayan DLL'lerin hafızada boşuna yer işgal etmemesi için hafızadan atılması gerekebilir. Aşağıdaki kod örneğinde bu işlemin yapılması gösterilmektedir. EditDLLName isimli 1 Tedit, 1 Tamam ve 1 adet de Kapat butonu form üzerine yerleştirilmiştir. Tamam butonunun OnClick davranışına yazılan kod aşağıdadır.

procedure TForm1.TamamBtnClick(Sender: TObject); var hDLL: THandle;

aName : array[0..10] of char;

FoundDLL : Boolean;

begin

if EditDLLName.Text = '' then

begin

MessageDlg('Çıkarılacak DLL dosyasının adını yazınız.!',mtInformation,[mbOk],0);

exit;

end;

StrPCopy(aName, EditDLLName.Text);

FoundDLL := false;

repeat

hDLL := GetModuleHandle(aName);

if hDLL = 0 then

break;

FoundDLL := true;

FreeLibrary(hDLL);

until false;

if FoundDLL then

MessageDlg('Tamam!',mtInformation,[mbOk],0)

else

MessageDlg('DLL Bulunamadı!',mtInformation,[mbOk],0);

EditDLLName.Text := '';

end;

Bir DOS komutunun kullanılması

Windows 95 ortamındayken, bir DOS komutunun çalıştırılması için gereken yordam şudur.

procedure doskomutu(komut:string;mesajver:boolean);

var

Startupinfo:TStartupinfo;

ProcessInfo:TProcessInformation;

begin

if terminateprocess(processinfo.hProcess,0)=NULL then

begin

if mesajver then showmessage('Devam eden işlem iptal edilemedi');

exit;

end;

FillChar(StartupInfo,Sizeof(StartupInfo),#0);

StartupInfo.cb := Sizeof(StartupInfo);

StartupInfo.wShowWindow := SW_HIDE;

StartupInfo.dwFlags:=STARTF_USESHOWWINDOW;

if not CreateProcess(nil,

Pchar('c:command.com /c '+komut),

nil,

true,

NORMAL_PRIORITY_CLASS,

nil,

StartupInfo,

ProcessInfo) then

begin

if mesajver then

ShowMessage('İşlem gerçekleştirilemedi')

end

else

begin

if mesajver then ShowMessage('İşlem tamam')

end;

Bu yordamın kullanımı;

procedure TForm1.Button1Click(Sender: TObject);

begin

doskomutu('copy c:autoexec.bat a:autoexec.dat',false);

end;

TEdit metninin, OnChange olayında değiştirilmesi

Eğer, bir Tedit bileşenindeki metni, aynı bileşenin OnChange olayında değiştirmeye kalkarsanız, yığın (Stack) dolana kadar sürecek bir zincirleme reaksiyon yaratırsınız. Bu işlemi yapabilmek için, OnChange olay yordamına girildiğinde, önce OnChange olayı boşaltılmalı, işlem bitince yeniden eski haline getirilmelidir.

procedure Edit1Change(Sender : TObject);

begin

Edit1.OnChange := NIL;

if Edit1.Text = 'Some Text' then

Edit1.Text := 'New Text';

Edit1.OnChange := Edit1Change;

end;

TMemo bileşeninde, imleç hangi satırda?

Bir Tmemo bileşeninde, imlecin hangi satırda olduğunu anlamak için;

With Memo1 do begin

Line := Perform(EM_LINEFROMCHAR,SelStart, 0);

Column := SelStart - Perform(EM_LINEINDEX, Line, 0);

end;

Ulusal ayarlar

Başlangıçta, Delphi bütün Tarih/Saat ayarlarını Kontrol panelde belirtilen bölgesel ayarlardan alarak kullanır. Bu durum, özellikle tarih alanlarına değer girildiğinde, hatalara neden olabilir. Bu sorunun çözümü için, Delphi içerisinde tanımlanmış ve bu tür bilgileri taşıyan değişkenleri, isteğinizi karşılayacak şekilde değiştirebilirsiniz.

DecimalSeparator := '.';

ShortDateFormat := 'mm/dd/yy';

TeditBox bileşenindeki metnin ilk karakterinin, büyük harfe çevirilmesi

TeditBox bileşenindeki metnin ilk karakterinin, büyük harfe çevirilmesi için aşağıdaki kod kullanılabilir.

procedure TForm1.Edit1Change(Sender: TObject);

var

OldStart : Integer;

begin

With Edit1 do

if Text <> '' then

begin

OnChange := NIL;

OldStart := SelStart;

Text := UpperCase(Copy(Text,1,1))+

LowerCase(Copy(Text,2,Length(Text)));

SelStart := OldStart;

OnChange := Edit1Change;

end;

Windows'un kapanma anının tespiti

Windows'un kapanma anının yakalanabilmesi için, Windows tarafından kapanmadan önce yayınlanan, WM_EndSession mesajı yakalanmalıdır.

Mesaj yakalama yordamı, uygulama ana form sınıfının, Private bölümünde şu şekilde tanımlanır.

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

Mesaj yakalama yordamının kendisi ise, Implementation bölümünde aşağıdaki gibi yaratılır.

procedure TForm1.WMEndSession(var Msg : TWMEndSession);

begin

if Msg.EndSession = TRUE then

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

inherited;

end;

veya

procedure TForm1.WMQueryEndSession(var Msg : TWMQueryEndSession);

begin

if MessageDlg('Windows kapansınmı ?', mtConfirmation, [mbYes,mbNo], 0) = mrNo then

Msg.Result := 0

else

Msg.Result := 1;

end;

Windowsun kapandığını tespit eden bir bileşen kodu aşağıdadır.

unit winshut;

interface

uses

Messages, SysUtils, Classes, Forms, Windows;

type

TkapanmaOlayi = procedure (Sender: TObject; var TamamKapat: boolean) of object;

type

TSezonuKapat = class(TComponent)

private

FUYG: THandle;

FParent: THandle;

FESKIWINYORD: pointer;

FYeniPencereYordami: pointer;

KAPANIRKEN: TkapanmaOlayi;

TamamKapat: boolean;

procedure YeniPencereYordami(var MESAJ: TMessage);

public

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

procedure Loaded; override;

published

property WINKAPANIS: TkapanmaOlayi read KAPANIRKEN write KAPANIRKEN;

end;

procedure Register;

implementation

constructor TSezonuKapat.Create (AOwner : TComponent);

begin

inherited Create(AOwner);

TamamKapat := TRUE;

FUYG := Application.Handle;

FParent := (AOwner as TForm).Handle;

FYeniPencereYordami := MakeObjectInstance(YeniPencereYordami);

end;

destructor TSezonuKapat.Destroy;

begin

SetWindowLong(FUYG, GWL_WndProc, longint(FESKIWINYORD));

FreeObjectInstance(FYeniPencereYordami);

inherited Destroy;

end;

procedure TSezonuKapat.Loaded;

begin

inherited Loaded;

FESKIWINYORD := pointer(SetWindowLong(FUYG, GWL_WndProc,longint(FYeniPencereYordami)));

end;

procedure TSezonuKapat.YeniPencereYordami(var MESAJ: TMessage);

begin

with MESAJ do

begin

if (Msg=WM_QUERYENDSESSION) then

begin

if Assigned(KAPANIRKEN) then KAPANIRKEN(Self,TamamKapat);

if TamamKapat then

Result := CallWindowProc(FESKIWINYORD, FUYG, Msg, wParam,lParam)

else

Result := 0;

end

else

Result := CallWindowProc(FESKIWINYORD, FUYG, Msg, wParam,lParam);

end;

procedure Register;

begin

RegisterComponents('Kitap', [TSezonuKapat]);

end;

end.

Bir memo veya RichEdit bileşeninde, imlecin istenen yere gönderilmesi

With Memo1 do

SelStart := Perform(EM_LINEINDEX, Line, 0);

Windows çevirmeli ağ bağlantı penceresinin çağırılması

procedure TForm1.Button1Click(Sender: TObject);

begin

winexec(PChar('rundll32.exe rnaui.dll,RnaDial '+Edit1.Text),sw_show);

end;

Otomatik e-mail

//uses satırına shellapi eklenmeli

procedure TForm1.Button1Click(Sender: TObject);

begin

ShellExecute(Handle,'open','mailto:fdemirel@kkk.tsk.mil.tr','','',sw_Normal);

end;

Monitörün kapatılması/Açılması

Kapatılması;

procedure TForm1.Button1Click(Sender: TObject);

begin

SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, 0);

timer1.enabled:=true;

end;

açılması için;

procedure TForm1.Timer1Timer(Sender: TObject);

begin

SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, -1);

timer1.enabled:=false;

end;

Windows'un kapatılması/Yeniden başlatılması

Kapatılması;

procedure TMainForm.RestartWindowsBtnClick(Sender: TObject);

begin

if not ExitWindows(EW_RestartWindows, 0) then

ShowMessage('Bir uyulama kapanmayı reddetti');

end;

Yeniden başlatılması;

procedure TMainForm.RebootSystemBtnClick(Sender: TObject);

begin

if not ExitWindows(EW_RebootSystem, 0) then

ShowMessage(Bir uyulama kapanmayı reddetti ');

end;

Sistemde ses kartı varmı?

Winmm.Dll de bulunan waveOutGetNumDevs fonksiyonu kullanılarak, sistemde ses kartı olup olmadığı anlaşılabilir. Önce interface bölümünde fonksiyon tanımlanmalıdır.

function SoundCardPresent : longint; stdcall; external 'winmm.dll' name 'waveOutGetNumDevs';

Kullanımı;

If SoundCardPresent = 0 then

Showmessage('Ses kartı yok');

Programın arka planda çalıştırılması

Program çalıştığında, hiç bir yerde görünmediği halde, ikonunu Windows görev çubuğuna yerleştirecektir. Üzerinde sağ fare tuşuna basılarak açılacak menü ile görünür hale getirilebilir.

Unit1.dfm;

unit Unit1;

interface

uses

SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,

Forms, Dialogs, ExtCtrls, ShellAPI, Menus;

const WM_MINIMALIZE = WM_USER + 1

type

TForm1 = class(TForm)

PopupMenu1: TPopupMenu;

Show1: TMenuItem;

Hide1: TMenuItem;

Quit1: TMenuItem;

procedure FormCreate(Sender: TObject);

procedure FormDestroy(Sender: TObject);

procedure Show1Click(Sender: TObject);

procedure Hide1Click(Sender: TObject);

procedure Quit1Click(Sender: TObject);

private

FIconData : TNotifyIconData;

public

procedure WMMinimalize(var Message : TMessage); message WM_MINIMALIZE;

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);

var i : Integer;

begin

with FIconData do

begin

cbSize := SizeOf(FIconData);

Wnd := Self.Handle;

uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP;

hIcon := Application.Icon.Handle;

uCallbackMessage := WM_MINIMALIZE; szTip := 'My own application';

end;

Shell_NotifyIcon(NIM_ADD, @FIconData);

end;

procedure TForm1.FormDestroy(Sender: TObject);

begin

Shell_NotifyIcon(NIM_DELETE, @FIconData);

end;

procedure TForm1.WMMinimalize(var Message : TMessage);

var p : TPoint;

begin

case Message.LParam of

WM_RBUTTONUP: begin

GetCursorPos(p);

PopupMenu1.Popup(p.x, p.y);

end;

procedure TForm1.Show1Click(Sender: TObject);

begin

Form1.Visible := TRUE;

ShowWindow(Application.Handle, SW_HIDE);

end;

procedure TForm1.Hide1Click(Sender: TObject);

begin

Self.Visible := FALSE;

end;

procedure TForm1.Quit1Click(Sender: TObject);

begin

Application.Terminate;

end;

end.

Project1.dpr;

program Project1;

uses

Forms,

Unit1 in 'Unit1.pas' {Form1};

{$R *.RES}

begin

Application.Initialize;

Application.CreateForm(TForm1, Form1);

Application.ShowMainForm := FALSE;

Application.Run;

end.

Windows görev çubuğunun gizlenmesi/Gösterilmesi

Gizlenmesi;

procedure TForm1.Button1Click(Sender: TObject);

var

MyTaskbar:Hwnd;

begin

MyTaskBar:= FindWindow('Shell_TrayWnd', nil);

ShowWindow(MyTaskBar, SW_HIDE);

end;

Gösterilmesi

procedure TForm1.Button2Click(Sender: TObject);

var

MyTaskbar:Hwnd;

begin

MyTaskBar:= FindWindow('Shell_TrayWnd', nil);

ShowWindow(MyTaskBar, SW_SHOW);

end;

Çalışan programın, Görev çubuğu üzerinden kaldırılması

program Project1;

uses

Forms,windows,

Unit1 in 'Unit1.pas' {Form1};

{$R *.RES}

var

es:integer;

begin

Application.Initialize;

ES := GetWindowLong(Application.Handle, GWL_EXSTYLE);

ES := ES or WS_EX_TOOLWINDOW and not WS_EX_APPWINDOW;

SetWindowLong(Application.Handle, GWL_EXSTYLE, ES);

Application.CreateForm(TForm1, Form1);

Application.Run;

end.

OCX'kullanımı

Programda OCX örneğin THTML kullanıldığında, programı başka bir makinede çalıştırmak, problem olabilir. Bunun sebebi, OCX'lerin, çalışabilmeleri için Sistem kayıtları veri tabanına kayıtlı olmalarının gerekmesidir. Bu işlem Regsvr32.exe kullanılarak veya programın kendi içerisinden yapılabilir. Başka bir problem nedeni ise OCX kontrolünün birden fazla dosyadan oluşması ihtimalidir. Bunların tümü diğer makineye taşınmalıdır.

OCX için hangi dosyaların gerekli olduğu QuickView programı kullanılarak tespit edilebilir.Aşağıda, kullanılan OCX'leri diğer makineye kaydettiren bir yordam yeralmaktadır.

function CheckOCX:Boolean;

var Reg:TRegistry;

begin

Reg:=TRegistry.Create;

try

Reg.RootKey:=HKEY_CLASSES_ROOT;

// Kontrolün UID bilgisi windows sistem kayıtları veri

//tabanından alınmaktadır.

Result:=Reg.OpenKey('CLSID{B7FC3550-8CE7-11CF-9754-00AA00C00908}',False);

if Result then Reg.CloseKey;

finally

Reg.Free;

end;

procedure RegisterOCX;

var Lib:THandle;

S:String;

P:TProcedure;

begin

OleInitialize(nil);

try

S:=ExtractFilePath(Application.ExeName)+'HTML.OCX';

Lib:=LoadLibrary(PChar(S));

if Lib<HINSTANCE_ERROR then

raise Exception.CreateFmt('Cannot initialize library %s. Internal Windows error %d',[S,Lib]);

try

P:=GetProcAddress(Lib,'DllRegisterServer');

if not Assigned(P) then raise Exception.Create('Cannot find procedure DllRegisterServer');

finally

FreeLibrary(Lib);

end;

finally

OleUninitialize;

end;

procedure Uninstall;

var Lib:THandle;

S:String;

P:TProcedure;

begin

S:=ExtractFilePath(Application.ExeName)+'HTML.OCX';

Lib:=LoadLibrary(PChar(S));

if Lib<HINSTANCE_ERROR then

raise Exception.CreateFmt('Cannot initialize library %s. Internal Windows error %d',[S,Lib]);

try

P:=GetProcAddress(Lib,'DllUnregisterServer');

if not Assigned(P) then raise Exception.Create('Cannot find procedure DllUnregisterServer');

finally

FreeLibrary(Lib);

end;

Bazen, bu kayıtlar diğer makinede olduğu halde dosyalardan biri veya birkaçı eksik olabilir.

Ekran çözünürlüğündeki değişikliklerin tespiti

unit Unit1;

interface

uses

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

type

TForm1 = class(TForm)

private

{ Private declarations }

public

{ Public declarations }

procedure WMDisplayChange( var msg : TWMDisplayChange );message wm_DisplayChange;

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure tform1.WMDisplayChange( var msg : TWMDisplayChange );

begin

showmessage('Renk=2 üzeri '+inttostr(msg.BitsPerPixel)+

' En='+inttostr(msg.width)+

' Boy='+inttostr(msg.height))

end;

end.

Pano Görüntüleme

Panoya kopyalanan metnin, görüntülenmesi

unit ClipboardViewer;

interface

uses

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

Dialogs, StdCtrls;

type

TForm1 = class(TForm)

Memo1: TMemo;

procedure FormCreate(Sender: TObject);

procedure FormDestroy(Sender: TObject);

private

FNextViewerHandle : THandle;

procedure WMDrawClipboard (var message : TMessage);

message WM_DRAWCLIPBOARD;

procedure WMChangeCBCHain (var message : TMessage);

message WM_CHANGECBCHAIN;

public

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);

begin

FNextViewerHandle := SetClipboardViewer(Handle);

end;

procedure TForm1.FormDestroy(Sender: TObject);

begin

ChangeClipboardChain(Handle, FNextViewerHandle);

end;

procedure TForm1.WMDrawClipboard (var message : TMessage);

begin

message.Result := SendMessage(WM_DRAWCLIPBOARD, FNextViewerHandle, 0, 0);

memo1.lines.clear;

memo1.PasteFromClipboard

end;

procedure TForm1.WMChangeCBCHain (var message : TMessage);

begin

if message.wParam = FNextViewerHandle then begin

FNextViewerHandle := message.lParam;

message.Result := 0;

end else begin

message.Result := SendMessage(FNextViewerHandle, WM_CHANGECBCHAIN,

message.wParam, message.lParam);

end;

end.

CPU bilgileri

Bilgisayardaki mikro işlemcinin tipinin ve üreticisinin tepit edilmesi için, aşağıdaki unit kullanılabilir.

unit CpuInfo;

interface

type

TFeatures = record

case integer of

0: (RegEAX,

RegEBX,

RegEDX,

RegECX:integer);

1 : (I :array [0..3] of integer);

2 : (C :array [0..15] of char);

3 : (B :array [0..15] of byte)

end;

const

{$IFNDEF WIN32}

i8086 = 1;

i80286 = 2;

i80386 = 3;

{$ENDIF}

i80486=4;

Chip486=4;

iPentium= 5;

Chip586=5;

iPentiumPro=6;

Chip686=6;

Intel='GenuineIntel';

AMD='AuthenticAMD';

var

CpuType:byte = 0;

VendorId:string [12]= '';

Features:TFeatures

procedure LoadFeatures (I : integer);

implementation

{$O-}

const

CpuId = $0a20f;

var

CpuIdFlag:boolean = false; MaxCPUId:integer;

procedure GetF;

asm

dw CpuId

mov [Features.RegEAX], eax

mov [Features.RegEBX], ebx

mov [Features.RegECX], ecx

mov [Features.RegEDX], edx

end;

procedure ClearF;

asm

mov edi, offset Features

xor eax, eax

mov ecx, eax

mov cl, 4

cld

rep stosd

end;

procedure CheckOutCpu;

asm

{$IFNDEF WIN32}

pushf

pop ax

mov cx, ax

and ax, 0fffh

push ax

popf

pushf

pop ax

and ax, 0f000h

cmp ax, 0f000h

mov [CPUType], 1

je @@2

or cx, 0f000h

push cx

popf

push

pop ax

and ax, 0f000h

mov [CPUType], 2

jz @@2

pushfd

pop eax

mov ecx, eax

xor eax, 40000h

push eax

popfd

pushfd

pop eax

xor eax, ecx

mov [CPUType], 3

jz @@2

push ecx

popfd

{$ENDIF}

mov [CPUType], 4

mov eax, ecx

xor eax, 200000h

push eax

popfd

pushfd

pop eax

xor eax, ecx

je @@2

mov [CPUIdFlag], 1

push ebx

mov eax,0

dw CpuId

mov [MaxCPUId], eax

mov [byte ptr VendorId], 12

mov [dword ptr VendorId+1], ebx

mov [dword ptr VendorId+5], edx

mov [dword ptr VendorId+9], ecx

callClearF

mov eax, 1

cal GetF

shr eax, 8

and eax, 0fh

mov [CPUType], al

@@1: pop ebx

@@2:

end;

procedure LoadFeatures (I : integer);

asm

call ClearF

cmp [CpuIdFlag], 0

je @@1

mov eax, [I]

cmp [MaxCpuId], eax

jl @@1

call GetF

@@1:

end;

initialization

CheckOutCPU;

end.

CPU tipi ile ilgili bilgiler, "Cputype", ve "vendorid" değişkenlerine yüklenmektedirler.;

Aynı maksatla kullanılabilecek başka bir kod örneği de şudur.

unit cpuinfo;

interface

uses

Windows, SysUtils;

type

Freq_info = Record

Raw_Freq: Cardinal; // Ham CPU frekansı MHz.

Norm_Freq: Cardinal; // Ortalama CPU frekansı MHz.

In_Cycles: Cardinal; // Sistem saati hizi

Ex_Ticks: Cardinal; // Test süresi

end;

TCpuInfo = Record

VendorIDString: String;

Manufacturer: String;

CPU_Name: String;

PType: Byte;

Family: Byte;

Model: Byte;

Stepping: Byte;

Features: Cardinal;

MMX: Boolean;

Frequency_Info: Freq_Info;

IDFDIVOK: Boolean;

end;

Const

InfoStrings: Array[0..1] of String = ('FDIV instruction is Flawed',

'FDIV instruction is OK');

Const

// CPU değerlerinin tespitinde kullanılacak sabitler

// Örnek IF (Features and FPU_FLAG = FPU_FLAG) ise CPU'da Floating-Point birim vardır.

FPU_FLAG = $00000001;

VME_FLAG = $00000002;

DE_FLAG = $00000004;

PSE_FLAG = $00000008;

TSC_FLAG = $00000010;

MSR_FLAG = $00000020;

PAE_FLAG = $00000040;

MCE_FLAG = $00000080;

CX8_FLAG = $00000100;

APIC_FLAG = $00000200;

BIT_10 = $00000400;

SEP_FLAG = $00000800;

MTRR_FLAG = $00001000;

PGE_FLAG = $00002000;

MCA_FLAG = $00004000;

CMOV_FLAG = $00008000;

BIT_16 = $00010000;

BIT_17 = $00020000;

BIT_18 = $00040000;

BIT_19 = $00080000;

BIT_20 = $00100000;

BIT_21 = $00200000;

BIT_22 = $00400000;

MMX_FLAG = $00800000;

BIT_24 = $01000000;

BIT_25 = $02000000;

BIT_26 = $04000000;

BIT_27 = $08000000;

BIT_28 = $10000000;

BIT_29 = $20000000;

BIT_30 = $40000000;

BIT_31 = $80000000;

Procedure GetCPUInfo(Var CPUInfo: TCpuInfo);

Function GetRDTSCCpuSpeed: Freq_Info;

Function CPUID: TCpuInfo;

Function TestFDIVInstruction: Boolean;

implementation

Procedure GetCPUInfo(Var CPUInfo: TCpuInfo);

begin

CPUInfo := CPUID;

CPUInfo.IDFDIVOK := TestFDIVInstruction;

IF (CPUInfo.Features and TSC_FLAG = TSC_FLAG) then

CPUInfo.Frequency_Info := GetRDTSCCpuSpeed;

If (CPUInfo.Features and MMX_FLAG) = MMX_FLAG then

CPUInfo.MMX := True

else

CPUInfo.MMX := False;

end;

Function GetRDTSCCpuSpeed: Freq_Info;

var

Cpu_Speed: Freq_Info;

t0, t1: TLargeInteger;

freq, freq2, freq3, Total: Cardinal;

Total_Cycles, Cycles: Cardinal;

Stamp0, Stamp1: Cardinal;

Total_Ticks, Ticks: Cardinal;

Count_Freq: TLargeInteger;

Tries, IPriority, hThread: Integer;

begin

freq := 0;

freq2 := 0;

freq3 := 0;

tries := 0;

total_cycles := 0;

total_ticks := 0;

Total := 0;

hThread := GetCurrentThread();

if (Not QueryPerformanceFrequency(count_freq)) then

begin

Result := cpu_speed;

end

else

begin

while ((tries < 3 ) or ((tries < 20) and ((abs(3 * freq - total) > 3) or

(abs(3 * freq2-total) > 3) or (abs(3 * freq3-total) > 3)))) do

begin

inc(tries);

freq3 := freq2;

freq2 := freq;

QueryPerformanceCounter(t0);

t1.LowPart := t0.LowPart;

t1.HighPart := t0.HighPart;

iPriority := GetThreadPriority(hThread);

if ( iPriority <> THREAD_PRIORITY_ERROR_RETURN ) then

begin

SetThreadPriority(hThread, THREAD_PRIORITY_TIME_CRITICAL);

end;

while ((t1.LowPart - t0.LowPart) < 50) do

begin

QueryPerformanceCounter(t1);

asm

push eax

push edx

db 0Fh

db 31h

MOV stamp0, EAX

pop edx

pop eax

end;

t0.LowPart := t1.LowPart;

t0.HighPart := t1.HighPart;

while ((t1.LowPart - t0.LowPart) < 1000) do

begin

QueryPerformanceCounter(t1);

asm

push eax

push edx

db 0Fh

db 31h

MOV stamp1, EAX

pop edx

pop eax

end;

if ( iPriority <> THREAD_PRIORITY_ERROR_RETURN ) then

begin

SetThreadPriority(hThread, iPriority);

end;

cycles := stamp1 - stamp0;

ticks := t1.LowPart - t0.LowPart;

ticks := ticks * 100000;

ticks := Round(Ticks / (count_freq.LowPart/10));

total_ticks := Total_Ticks + ticks;

total_cycles := Total_Cycles + cycles;

freq := Round(cycles / ticks);

total := (freq + freq2 + freq3);

end;

freq3 := Round((total_cycles * 10) / total_ticks);

freq2 := Round((total_cycles * 100) / total_ticks);

If (freq2 - (freq3 * 10) >= 6) then

inc(freq3);

cpu_speed.raw_freq := Round(total_cycles / total_ticks);

cpu_speed.norm_freq := cpu_speed.raw_freq;

freq := cpu_speed.raw_freq * 10;

if((freq3 - freq) >= 6) then

inc(cpu_speed.norm_freq);

cpu_speed.ex_ticks := total_ticks;

cpu_speed.in_cycles := total_cycles;

Result := cpu_speed;

end;

Function CPUID: TCpuInfo;

type

regconvert = record

bits0_7: Byte;

bits8_15: Byte;

bits16_23: Byte;

bits24_31: Byte;

end;

var

CPUInfo: TCpuInfo;

TEBX, TEDX, TECX: Cardinal;

TString: String;

VString: String;

temp: regconvert;

begin

asm

MOV [CPUInfo.PType], 0

MOV [CPUInfo.Model], 0

MOV [CPUInfo.Stepping], 0

MOV [CPUInfo.Features], 0

MOV [CPUInfo.Frequency_Info.Raw_Freq], 0

MOV [CPUInfo.Frequency_Info.Norm_Freq], 0

MOV [CPUInfo.Frequency_Info.In_Cycles], 0

MOV [CPUInfo.Frequency_Info.Ex_Ticks], 0

push eax

push ebp

push ebx

push ecx

push edi

push edx

push esi

@@Check_80486:

MOV [CPUInfo.Family], 4

MOV TEBX, 0

MOV TEDX, 0

MOV TECX, 0

PUSHFD

POP EAX

MOV ECX, EAX

XOR EAX, 200000H

PUSH EAX

POPFD

PUSHFD

POP EAX

XOR EAX, ECX

JE @@DONE_CPU_TYPE

@@Has_CPUID_Instruction:

MOV EAX, 0

DB 0FH

DB 0A2H

MOV TEBX, EBX

MOV TEDX, EDX

MOV TECX, ECX

MOV EAX, 1

DB 0FH

DB 0A2H

MOV [CPUInfo.Features], EDX

MOV ECX, EAX

AND EAX, 3000H

SHR EAX, 12

MOV [CPUInfo.PType], AL

MOV EAX, ECX

AND EAX, 0F00H

SHR EAX, 8

MOV [CPUInfo.Family], AL

MOV EAX, ECX

AND EAX, 00F0H

SHR EAX, 4

MOV [CPUInfo.MODEL], AL

MOV EAX, ECX

AND EAX, 000FH

MOV [CPUInfo.Stepping], AL

@@DONE_CPU_TYPE:

pop esi

pop edx

pop edi

pop ecx

pop ebx

pop ebp

pop eax

end;

If (TEBX = 0) and (TEDX = 0) and (TECX = 0) and (CPUInfo.Family = 4) then

begin

CPUInfo.VendorIDString := 'Unknown';

CPUInfo.Manufacturer := 'Unknown';

CPUInfo.CPU_Name := 'Generic 486';

end

else

begin

With regconvert(TEBX) do

begin

TString := CHR(bits0_7) + CHR(bits8_15) + CHR(bits16_23) + CHR(bits24_31);

end;

With regconvert(TEDX) do

begin

TString := TString + CHR(bits0_7) + CHR(bits8_15) + CHR(bits16_23) + CHR(bits24_31);

end;

With regconvert(TECX) do

begin

TString := TString + CHR(bits0_7) + CHR(bits8_15) + CHR(bits16_23) + CHR(bits24_31);

end;

VString := TString;

CPUInfo.VendorIDString := TString;

If (CPUInfo.VendorIDString = 'GenuineIntel') then

begin

CPUInfo.Manufacturer := 'Intel';

Case CPUInfo.Family of

4: Case CPUInfo.Model of

1: CPUInfo.CPU_Name := 'Intel 486DX Processor';

2: CPUInfo.CPU_Name := 'Intel 486SX Processor';

3: CPUInfo.CPU_Name := 'Intel DX2 Processor';

4: CPUInfo.CPU_Name := 'Intel 486 Processor';

5: CPUInfo.CPU_Name := 'Intel SX2 Processor';

7: CPUInfo.CPU_Name := 'Write-Back Enhanced Intel DX2 Processor';

8: CPUInfo.CPU_Name := 'Intel DX4 Processor';

else CPUInfo.CPU_Name := 'Intel 486 Processor';

end;

5: CPUInfo.CPU_Name := 'Pentium';

6: Case CPUInfo.Model of

1: CPUInfo.CPU_Name := 'Pentium Pro';

3: CPUInfo.CPU_Name := 'Pentium II';

else CPUInfo.CPU_Name := PChar(Format('P6 (Model %d)', [CPUInfo.Model]));

end;

else CPUInfo.CPU_Name := Format('P%d', [CPUInfo.Family]);

end;

end

else if (CPUInfo.VendorIDString = 'CyrixInstead') then

begin

CPUInfo.Manufacturer := 'Cyrix';

Case CPUInfo.Family of

5: CPUInfo.CPU_Name := 'Cyrix 6x86';

6: CPUInfo.CPU_Name := 'Cyrix M2';

else CPUInfo.CPU_Name := Format('%dx86', [CPUInfo.Family]);

end;

end

else if (CPUInfo.VendorIDString = 'AuthenticAMD') then

begin

CPUInfo.Manufacturer := 'AMD';

Case CPUInfo.Family of

4: CPUInfo.CPU_Name := 'Am486 or Am5x86';

5: Case CPUInfo.Model of

0: CPUInfo.CPU_Name := 'AMD-K5 (Model 0)';

1: CPUInfo.CPU_Name := 'AMD-K5 (Model 1)';

2: CPUInfo.CPU_Name := 'AMD-K5 (Model 2)';

3: CPUInfo.CPU_Name := 'AMD-K5 (Model 3)';

6: CPUInfo.CPU_Name := 'AMD-K6';

else CPUInfo.CPU_Name := 'Unknown AMD Model';

end;

else CPUInfo.CPU_Name := 'Unknown AMD Chip';

end;

end

else

begin

CPUInfo.VendorIDString := TString;

CPUInfo.Manufacturer := 'Unknown';

CPUInfo.CPU_Name := 'Unknown';

end;

Result := CPUInfo;

end;

Function TestFDIVInstruction: Boolean;

var

TestDividend: Double;

TestDivisor: Double;

TestOne: Double;

ISOK: Boolean;

begin

TestDividend := 4195835.0;

TestDivisor := 3145727.0;

TestOne := 1.0;

asm

PUSH EAX

FLD [TestDividend]

FDIV [TestDivisor]

FMUL [TestDivisor]

FSUBR [TestDividend]

FCOMP [TestOne]

FSTSW AX

SHR EAX, 8

AND EAX, 01H

MOV ISOK, AL

POP EAX

end;

Result := ISOK;

end;

end.