Programlama yapalım ve Öğrenelim.

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.

Enter tuşunun Tab yerine kullanılabileceği bir Tedit bileşeni

Enter (Return) tuşuna basıldığında Tab tuşuna basılmış etkisi yaratmak için aşağıdaki kod kullanılabilir.

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);

begin

if key=#13 then

begin

perform(wm_nextdlgctl,0,0);

key:=#0;

end;

Aşağıdaki bileşen kodu, standart bir Tedit bileşenini, değiştirerek Enter ve Ok tuşlarına tepki verebilecek yeni bir Edit kontrolü haline getirmektedir.

unit Entedit;

interface

uses

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

Forms, Dialogs, StdCtrls;

type

TEnterEdit = class(TEdit)

private

protected

procedure KeyPress(var Key: Char); override;

procedure KeyDown(var Key: Word; Shift: TShiftState); override;

public

published

end;

procedure Register;

implementation

procedure Register;

begin

RegisterComponents('Kitap', [TEnterEdit]);

end;

procedure TEnterEdit.KeyPress(var Key: Char);

var

MYForm: TcustomForm;

begin

if Key = #13 then

begin

MYForm := GetParentForm( Self );

if not (MYForm = nil ) then

SendMessage(MYForm.Handle, WM_NEXTDLGCTL, 0, 0);

Key := #0;

end;

if Key <> #0 then inherited KeyPress(Key);

end;

procedure TEnterEdit.KeyDown(var Key: Word; Shift: TShiftState);

var

MYForm: TcustomForm;

CtlDir: Word;

begin

if (Key = VK_UP) or (Key = VK_DOWN) then

begin

MYForm := GetParentForm( Self );

if Key = VK_UP then CtlDir := 1

else CtlDir :=0;

if not (MYForm = nil ) then

SendMessage(MYForm.Handle, WM_NEXTDLGCTL, CtlDir, 0);

end

else inherited KeyDown(Key, Shift);

end;

end.

Tarih doğru mu

Function Tarihgecerlimi(DateString: String): Boolean;

Begin

Try

StrToDateTime(DateString);

Result := True;

Except

Result := False;

End;

Ayda kaç gün var?

Function AydakiGunSayisi(DateValue: TDateTime): Integer;

var

yil : Word;

ay : Word;

gün : Word;

yeniyil : Word;

yeniay : Word;

yenigun : Word;

sayacr : Integer;

yenitarih : TDateTime;

Begin

Result := 30;

Try

DecodeDate(DateValue, Yil, ay, gun);

NewDate := EncodeDate(yil, ay, 26);

For sayac := 26 To 32 Do

Begin

yenitarih := NewDate+1;

DecodeDate(yenitarih, yeniyil, yeniay, yenigun);

If MonthNew <> MonthIn Then

Begin

DecodeDate(yenitarih-1, Yeniyil, yeniay, yenigun);

Result := yenigun;

Break;

End;

Except

End;

Geçen Haftanın ilk Günü

Function GecenHaftaninIlkGunu(DateValue: TDateTime): TDateTime;

Begin

Result := HaftaninIlkGunu(DateValue-7);

End;

Sonraki Ayın ilk Günü

Function SonrakiAyinIlkGunu(DateValue: TDateTime): TDateTime;

Begin

Try

Result := AyinSonGunu(DateValue)+1;

Except

Result := DateValue;

End;

Sonraki haftanın ilk günü

Function SonrakiHaftaninIlkGunu(DateValue: TDateTime): TDateTime;

Begin

Result := HaftaninIlkGunu(DateValue+7);

End;

Haftanın ilk günü

Function HaftaninIlkGunu(DateValue: TDateTime): TDateTime;

Begin

Try

Result := DateValue - (DayOfWeek(DateValue)) +1;

Except

Result := 0;

End;

Ayın son günü

Function AyinSonGunu(DateValue: TDateTime): TDateTime;

Var

LastDay : String;

Begin

LastDay := IntToStr(AydakiGunSayisi(DateValue));

Result := StrToDate(

FormatDateTime('mm',DateValue)+

'/'+

LastDay+

'/'+

FormatDateTime('yyyy',DateValue));

End;

Function Ay(DateValue: TDateTime): Integer;

Var

Year, Month, Day: Word;

Begin

Result := -1;

Try

DecodeDate(DateValue, Year, Month, Day);

Result := Integer(Month);

Except

Result := -1;

End;

Gelecek ay

Function GelecekAy(DateValue: TDateTime): Integer;

Var

Year, Month, Day: Word;

CurMonth : Integer;

NewMonth : Integer;

Begin

Result := -1;

Try

DecodeDate(DateValue, Year, Month, Day);

CurMonth := Integer(Month);

NewMonth := ((CurMonth + 12 + 1) mod 12);

If NewMonth = 0 Then NewMonth := 12;

Result := NewMonth;

Except

Result := -1;

End;

Geçen ay

Function GecenAy(DateValue: TDateTime): Integer;

Var

Year, Month, Day: Word;

CurMonth : Integer;

NewMonth : Integer;

Begin

Result := -1;

Try

DecodeDate(DateValue, Year, Month, Day);

CurMonth := Integer(Month);

NewMonth := ((CurMonth + 24 - 1) mod 12);

If NewMonth = 0 Then NewMonth := 12;

Result := NewMonth;

Except

Result := -1;

End;

Gün sonra

Function nGunSonra(

DateValue : TDateTime;

DateMovement : Integer): TDateTime;

Begin

Result := DateValue + DateMovement;

End;

Gelecek ay

Function GelecekAy(DateValue: TDateTime): TDateTime;

Begin

Result := nGumSonra(DateValue,1);

End;

Önceki gün

Function onceki_gun(DateValue: TDateTime): TDateTime;

Begin

Result := NGunSonra(DateValue,-1);

End;

Geçen hafta

Function GecenHaftak(DateValue: TDateTime): TDateTime;

Begin

Result := nGunSonra(DateValue,-7);

End;

Metin içerisinden bir karakter silme

Function DeleteCharacterInString(InputCharacter,InputString: String): String;

Var

CharPos : Integer;

Begin

Result := InputString;

While True Do

Begin

CharPos := Pos(InputCharacter,InputString);

If Not (CharPos = 0) Then

Begin

Delete(InputString,CharPos,1);

End

Else

Begin

Break;

End;

Result := InputString;

End;

Metin içerisinden, bir karakteri değiştirme

Function ReplaceCharInString(S,OldChar,NewChar :String): String;

Var

NewString : String;

i : Integer;

L : Integer;

C : String;

Begin

Result := '';

NewString := '';

L := Length(S);

If L = 0 Then Exit;

If Pos(UpperCase(OldChar),UpperCase(S)) = 0 Then

Begin

Result := S;

Exit;

End;

For i := 1 To L Do

Begin

C := SubStr(S,i,1);

If UpperCase(C) = UpperCase(OldChar) Then

Begin

NewString := NewString + NewChar;

End

Else

Begin

NewString := NewString + C;

End;

Result := NewString;

End;

Bir metni belli bir uzunluğa tamamlama

Function StringPad(

InputStr,//tamamlanacak metin

FillChar: String;//tamamlama karakteri

StrLen: Integer;//uzunluk

StrJustify: Boolean): String;//tamamlama yönü

Var

TempFill: String;

Counter : Integer;

Begin

If Not (Length(InputStr) = StrLen) Then

Begin

If Length(InputStr) > StrLen Then

Begin

InputStr := SubStr(InputStr,1,StrLen);

End

Else

Begin

TempFill := '';

For Counter := 1 To StrLen-Length(InputStr) Do

Begin

TempFill := TempFill + FillChar;

End;

If StrJustify Then

Begin

InputStr := InputStr + TempFill;

End

Else

Begin

InputStr := TempFill + InputStr ;

End;

Result := InputStr;

End;

Metin değiştirme

Function String_Replace(

OldSubString : String;//atılacak metin

NewSubString : String;//atılanın yerine konacak metin

SourceString : String): String;//üzerinde dğişiklik

//yapılacak metin

Var

P : Integer;

S : String;

R : String;

LOld : Integer;

LNew : Integer;

Begin

S := SourceString;

R := '';

LOld := Length(OldSubString);

LNew := Length(NewSubString);

Result := S;

If OldSubString = '' Then Exit;

If SourceString = '' Then Exit;

P := Pos(OldSubString,S);

If P = 0 Then

Begin

R := S;

End

Else

Begin

While P <> 0 Do

Begin

Delete(S,P,LOld);

R := R + Copy(S,1,P-1)+NewSubString;

S := Copy(S,P,Length(S)-(P-1));

P := Pos(OldSubString,S);

If P = 0 Then R := R + S;

End;

Result := R;

End;

Program içerisinden, başka bir uygulamaya tuş gönderme

WinHand := FindWindow(nil,'Untitled - Notepad');

SetForegroundWindow(WinHand);

keybd_event(VK_MENU, 0, 0, 0);

keybd_event(VK_Menu, 0, KEYEVENTF_KEYUP, 0);

keybd_event(VK_right, 0, 0, 0);

keybd_event(VK_right, 0, KEYEVENTF_KEYUP, 0);

keybd_event(VK_right, 0, 0, 0);

keybd_event(VK_right, 0, KEYEVENTF_KEYUP, 0);

keybd_event(VK_right, 0, 0, 0);

keybd_event(VK_right, 0, KEYEVENTF_KEYUP, 0);

keybd_event(VK_down, 0, 0, 0);

keybd_event(VK_down, 0, KEYEVENTF_KEYUP, 0);

keybd_event(VK_down, 0, 0, 0);

keybd_event(VK_down, 0, KEYEVENTF_KEYUP, 0);

keybd_event(VK_return, 0, 0, 0);

keybd_event(VK_return, 0, KEYEVENTF_KEYUP, 0);

Programı Deneme sürümü haline getirme

Programcıların kabusu, ürünlerinin kolaylıkla bedavacıların eline geçmesidir. Bu durum ürünlerin tanıtım sürümlerinin dağıtılmasında bir takım tedbirleri gerektirir. Bunun çok çeşitli yolları vardır. İşte bunlardan birisi. Aşağıdaki fonksiyon, Windows'un global atom tablosuna belirli bir not yazarak, çalışma esnasında bu notu okumaktadır. Şayet not okunabilirse, programın daha önce çalıştırılmış olduğu ortaya çıkar ve uyarı mesajını takiben çalışması durdurulur. Programın yeniden çalıştırılabilmesi için, Windowsun yeniden başlatılması gerekir.

procedure TForm1.FormShow(Sender : TObject);

var atom : integer;

CRLF : string;

begin

GlobalFindAtom('Kontrol için kullanılacak metin') = 0 then

atom := GlobalAddAtom(' Kontrol için kullanılacak metin ')

else

begin

CRLF := #10 + #13;

ShowMessage('Bu program, her windows sezonunda 1

kez çalışır.'+crlf+'+

Windows'u yeniden başlatın.'+crlf+

'Ya da bizi arayıp satın alın');

Close;

end;

ListBox bileşenine yatay kaydırma çubuğu eklenmesi

Delphi'nin TlistBox Bileşeni, satır sayısı gösterebileceğinden fazla ise, otomatik olarak dikey kaydırma çubuğunu kullanıma açar. Fakat satır uzunluğu gösterebileceği genişlikten daha fazla ise, bir kolaylık sağlamaz. Aşağıdaki kod kullanılarak, yatay kaydırma çubuğununda eklenmesi sağlanabilir.

Aşağıdaki kod, formun OnCrate olay yordamına yazılmalıdır.

procedure TForm1.FormCreate(Sender: TObject);

var

i, MaxWidth: integer;

begin

MaxWidth := 0;

for i := 0 to ListBox1.Items.Count - 1 do

if MaxWidth < ListBox1.Canvas.TextWidth(ListBox1.Items.Strings[i]) then

MaxWidth := ListBox1.Canvas.TextWidth(ListBox1.Items.Strings[i]);

SendMessage(ListBox1.Handle, LB_SETHORIZONTALEXTENT, MaxWidth+2, 0);

end;

Kod öncelikle, listbox içerisindeki en uzun satırın uzunluğunun Piksel cinsinden hesaplar. Ondan sonra LB_SETHORIZONTALEXTENT mesajını kullanarak, yatay kaydırma çubuğunu ayarlar.

Kontrol panel apletlerinin Delphi içerisinden kullanılması

Bazı sistem ayarları, kontrol panelden yapılmaktadır. Program içerisinden bu ayarlara müdahele etmek gerektiğinde, en kolay yol yine kontrol panel apletlerini kullanmaktır. Aşağıdaki fonksiyon, istenen kontrol panel apletini çalıştırmaktadır.

unit open_cpl;

interface

function RunControlPanelApplet(

sAppletFileName : string) : integer;

implementation

uses Windows;

//sAppletFileName değeri aşağıdaki tablodan seçilebilir.

function RunControlPanelApplet(

sAppletFileName : string) : integer;

begin

Result :=

WinExec(

PChar('rundll32.exe shell32.dll,'+

'Control_RunDLL '+sAppletFileName),

SW_SHOWNORMAL);

end;

end.

Windows95 ve NT de ortak olan kontrol panel apletleri şunlardır.

access.cpl Erişilebilirlik

appwiz.cpl Program ekle/kaldır

desk.cpl Görüntü

intl.cpl Bölgesel ayarlar

joy.cpl Oyun çubuğu

main.cpl Fare

mmsys.cpl Çoklu ortam

modem.cpl Modem

sysdm.cpl Sistem

timedate.cpl Tarih/Saat

Sistem Tarih/Saat ayarının değiştirilmesi

Sistemin tarih ve saat ayarları programsal olarak da değiştirilebilir. Bunun için Aşağıdaki fonksiyonu kullanabilirsiniz.

function SetPCSystemTime(tDati: TDateTime): Boolean;

var

tSetDati: TDateTime;

vDatiBias: Variant;

tTZI: TTimeZoneInformation;

tST: TSystemTime;

begin

GetTimeZoneInformation(tTZI);

vDatiBias := tTZI.Bias / 1440;

tSetDati := tDati + vDatiBias;

with tST do

begin

wYear := StrToInt(FormatDateTime('yyyy', tSetDati));

wMonth := StrToInt(FormatDateTime('mm', tSetDati));

wDay := StrToInt(FormatDateTime('dd', tSetDati));

wHour := StrToInt(FormatDateTime('hh', tSetDati));

wMinute := StrToInt(FormatDateTime('nn', tSetDati));

wSecond := StrToInt(FormatDateTime('ss', tSetDati));

wMilliseconds := 0;

end;

SetPCSystemTime := SetSystemTime(tST);

end;

procedure TForm1.Button1Click(Sender: TObject);

var

tti:tdatetime;

begin

tti:=strtodatetime('11.11.98 14:15:20');

Setpcsystemtime(tti)

" ALT+TAB ve CTRL+ALT+DEL tuş kombinasyonlarının kullanıma kapatılması

Eğer programınız çalışırken, kullanıcıların bu tuş kombinasyonlarını kullanmasını istemiyorsanız, aşağıdaki kod örneği tam size göre

uses

WinProcs;

{$R *.RES}

var

Dummy : integer;

begin

Dummy := 0;

//ALT+TAB kombinasyonu için

SystemParametersInfo( SPI_SETFASTTASKSWITCH, 1, @Dummy, 0);

//CTRL+ALT+DEL kombinasyonu için

SystemParametersInfo( SPI_SCREENSAVERRUNNING, 1, @Dummy, 0);

end.

Ekran koruyucunun devreden çıkarılması

SystemParametersInfo(SPI_GETSCREENSAVEACTIVE, 0, Addr(SaverActive), 0);

if SaverActive then

SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, 0, nil, SPIF_UPDATEINIFILE);

Burada "SaverActive" global bir Boolean değişkendir. Ekran koruyucu tekrar aktif hale getirilmek istendiğinde ise

if SaverActive then

SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, 1, nil, SPIF_UPDATEINIFILE);

Diğer bir yol ise, şu şekildedir. Bir ekran koruyucu çalışmaya başlamadan önce "WM_SYSCOMMAND" mesajı gönderir. Bu mesaj yakalanarak ekran koruyucunun devreye girmesi engellenir. TApplication nesnesinin OnMessage. Olayı yerine kullanılacak yeni bir davranış yaratıp bu mesajı herkesden önce yakalayabiliriz.

Bu işlem şöyle olur.

procedure AppMessage(var Msg: TMsg; var Handled: Boolean);

Daha sonra ana formun OnCreate davranışı içerisinde,

Application.OnMessage := AppMessage;

Appmessage yordamında yakalanan mesajın WM_sysCommand ve Wparam değerinin de SC_ScreenSave olup olmadığı kontrol edilir. Eğer öyle ise, Handled parametresi True yapılarak, o mesajın işlem gördüğü imajı yaratılarak, windows'un ekran koruyucuyu başlatması engellenir.

procedure TForm1.AppMessage(var Msg: TMsg; var Handled: Boolean);

begin

if (Msg.Message = WM_SYSCOMMAND) and

((Msg.wParam) = SC_SCREENSAVE) then begin

Handled := True;

end;

Programın, windowsun başlangıcında çalıştırılması

Windows Startup klasörüne konan programlar, windowsun başlaması ile birlikte çalışmaya başlarlar. Fakat bunu program içerisinden yapmak istiyorsanız, veya programınız, bir kereye mahsus başlangıçta çalışsın istiyorsanız,aşağıdaki fonksiyonu kullanarak geçici veya kalıcı olarak gerekeni yapabilirsiniz.

procedure RunOnStartup(

sProgTitle,

sCmdLine : string;

bRunOnce : boolean );

var

sKey : string;

reg : TRegIniFile;

begin

if( bRunOnce )then

sKey := 'Once'

else

sKey := '';

reg := TRegIniFile.Create( '' );

reg.RootKey := HKEY_LOCAL_MACHINE;

reg.WriteString(

'SoftwareMicrosoft'

+ 'WindowsCurrentVersionRun'

+ sKey + #0,

sProgTitle,

sCmdLine );

reg.Free;

end;

Hata mesajı kontrolü

Herhangi bir iş yapılırken, örneğin, diskete erişilmek istendiğinde, eğer sürücüde disket yoksa, windows bir hata mesajı verir. Bu tür mesajlara krıtik hata mesajı denir. Eğer kendiniz bu hataları kontrol edip, gereğini yapacaksanız, windowsun mesaj vermesinin engellenmesi gerekir.Bu işlem "SetErrorMode" fonksiyonu ile yapılabilir.

var

wOldErrorMode : Word;

begin

wOldErrorMode :=

SetErrorMode(

SEM_FAILCRITICALERRORS );

try

{

hata mesajına sebep olabilecek kod buraya yazılır.

}

finally

{

bir önceki hata moduna dön.

}

SetErrorMode( wOldErrorMode );

end;