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;
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;
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;
End;
Except
End;
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;
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;
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;
Ay
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;
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;
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;
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;
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;
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;
End;
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;
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
if
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;
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;
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;
end.
