Ekran koruyucu kurulmas ı
Sistemde tan ı ml ı olan ekran koruyucunun de ğ i ş tirilmesi veya en ba ş tan tan ı mlanmas ı i ç in gereken kod a ş a ğı dad ı r . Uses listesine eklenmesi gereken fmxutil . pas demos doc dizini alt ı nda bulunmaktad ı r .
//uses ..demosdocfmxutil.pas
procedure TForm1 . Button1Click ( Sender : TObject );
begin
ExecuteFile ( 'rundll32.exe' ,
'desk.cpl,InstallScreenSaver C:Windowsgpf.scr' ,
'' ,
SW_SHOW );
end ;
ListBox yaz ı tipinin de ğ i ş tirilmesi
Tek bir sat ı r kod yazarak wm_SetFont mesaj ı na duyarl ı bile ş enlerin , yaz ı tipleri de ğ i ş tirilebilir .
SendMessage ( Listbox1 . handle , wm_SetFont , GetStockObject ( System_Fixed_Font ), 1 );
Ta şı nabilir Panel
Program ı n ç al ış mas ı esnas ı nda , form ü zerindeki bile ş enlerin yerleri ancak , program i ç erisinden verilecek komutlarla de ğ i ş tirilebilir . A ş a ğı daki kod ö rne ğ i ile ç al ış an bir programda , normal bir panel , fare yard ı m ı ile ta şı nabilir hale gelmektedir . Bu kod panelin OnMouseDown olay yordam ı i ç erisine yaz ı lmal ı d ı r .
procedure TForm1 . Panel1MouseDown ( Sender : TObject ; Button : TMouseButton ;
Shift : TShiftState ; X , Y : Integer );
const
SC_DragMove = $F012 ;
begin
ReleaseCapture ;
panel1 . perform ( WM_SysCommand , SC_DragMove , 0 );
end ;
CD - ROM kapa ğı n ı n kapat ı lmas ı
TmediaPlayer , bir CD - ROM 'a komuta ediyorsa, Eject tuşuna basıldığında,, CD-ROM kapağını açabilir. Fakat tekrar Eject tuşuna basıldığında açık durumdaki kapağı kapatamaz. Bu nedenle bir adet kapat butonu kullanılmalıdır. Aşağıdaki kod örneğinde, başka bir buton kullanılarak kapağın kapatılması gösterilmektedrir.
procedure TForm1 . Button1Click ( Sender : TObject );
begin
if MediaPlayer1 . Mode = mpOpen then
begin
mciSendCommand ( MediaPlayer1 . DeviceID ,
MCI_SET , MCI_SET_DOOR_CLOSED , 0 );
Button1 . Caption := '&Open'
end
else
begin
mciSendCommand ( MediaPlayer1 . DeviceID
, MCI_SET , MCI_SET_DOOR_OPEN , 0 );
Button1 . Caption := '&Close' ;
end ;
end ;
Genel olarak bu i ş lemin yap ı lmas ı i ç in ise Mmsystem uniti kullan ı larak , a ş a ğı daki fonksiyonlar kullan ı labilir .
CD - ROM Kapa ğı n ı a ç mak i ç in ;
mciSendString ( 'Set cdaudio door open wait' , nil , 0 , handle );
CD - ROM Kapa ğı n ı kapatmak i ç in ;
mciSendString ( 'Set cdaudio door closed wait' , nil , 0 , handle );
Ç al ış ma esnas ı nda , bile ş en say ı s ı n ı n kontrol ü
Uygulama taraf ı ndan kullan ı lmakta olan bile ş en say ı s ı n ı n bulunmas ı m ü mk ü nd ü r . Hen ü z yarat ı lmam ış olanlar , bu say ı ya dahil edilmeyecektir . Uygulamalar taraf ı ndan kullan ı lmakta olan formlar ı n t ü m ü Screen nesnesi ne ba ğ l ı d ı rlar . Her formun ü zerindeki bile ş enlerin say ı s ı ise ComponentCount ö zelli ğ inde saklanmaktad ı r . A ş a ğı daki kod ö rne ğ inde bu ö zelliklerden yararlan ı larak , uygulama ü zerindeki toplam bile ş en say ı s ı bulunmaktad ı r .
function BilesenSayisi : Integer ;
var
TopBilesen ,
F_Form : Integer ;
begin
TopBilesen := 0 ;
for F_Form := 0 to ( Screen . FormCount - 1 ) do begin
TopBilesen := TopBilesen + Screen . Forms [ F_Form ]. ComponentCount ;
end ;
Result := TopBilesen ;
end ;
Fare imlecinin , istenen kontrol ü zerine getirilmesi
Fare imlecinin form ü zerindeki kontrollerden birisi , ö rne ğ in bir buton ü zerine getirilmesi i ç in ;
Butonun orta noktas ı hesaplanmal ı d ı r . Ö rne ğ in butonun eni 24 ve boyu da 24 ise
xC := Buton . Left + ( buton . width div 2 );
yC := buton . Top + ( buton . height div 2 );
Bulunan de ğ erler Tpoint kay ı t tipi i ç erisine yerle ş tirilir .
ptBtn : TPoint ;
Btn := Point ( xC , yC );
Butonun orta noktas ı na kar şı l ı k gelen ekran koordinatlar ı bulunmal ı d ı r .
ptBtn := buton . Parent . ScreenToClient ( buton . ClientToScreen ( ptBtn ));
Fere imlecinin pozisyonunu , bulunan ekran koordinat ı de ğ eri kullan ı larak de ğ i ş tirilir .
SetCursorPos ( ptBtn . X , ptBtn . Y );
Alt -? Tu ş kombinasyonu
Bir ç ok uygulamaya , programc ı lar taraf ı ndan ç e ş itli maksatlarla , genellikle de geli ş tirme ekibi hakk ı nda bilgi vermek i ç in , gizli , s ü rpriz pencereler yerle ş tirilmektedir . Zaman zaman dergilerde bu t ü r uygulamalarla ilgili bilgiler yay ı nlanmaktad ı r . Bu tekni ğ i kendi programlar ı n ı z i ç erisinde de kullanabilirsiniz .. A ş a ğı daki kod ö rne ğ inde , form ü zerinde tu ş a bas ı ld ığı nda , karakterler bir dizi haline getirilip , listedekilerle kar şı la ş t ı r ı lmaktad ı r . listedekilerden bir tanesi ile ç ak ış t ığı nda ise bir mesaj g ö sterilmektedir .
unit surpriz ;
interface
uses
Windows , Messages , SysUtils , Classes , Graphics , Controls , Forms , Dialogs ;
type
Tst = array [ 1 .. 4 ] of string ;
const
strings : Tst = ( 'merhaba' , 'güle güle' , 'sürüm' , 'sürpriz' );
type
TForm1 = class ( TForm )
procedure FormKeyDown ( Sender : TObject ; var Key : Word ;
Shift : TShiftState );
procedure FormCreate ( Sender : TObject );
private
{ Private declarations }
public
{ Public declarations }
s : string ;
end ;
var
Form1 : TForm1 ;
implementation
{$R *.DFM}
procedure TForm1 . FormKeyDown ( Sender : TObject ; var Key : Word ;
Shift : TShiftState );
var
i : integer ;
tamam : integer ;
begin
if ( shift =[ ssalt ]) and ( key >= $41 ) and ( key <= $5A ) then begin
s := s + chr ( key );
tamam := 0 ;
for i := 1 to 4 do
begin
if ( s = copy ( strings [ i ], 1 , length ( s ))) then Tamam :=- i ;
if ( s = strings [ i ]) then Tamam := i ;
end ;
if Tamam = 0 then s := '' ;
if Tamam > 0 then showmessage ( strings [ Tamam ]);
end ;
end ;
procedure TForm1 . FormCreate ( Sender : TObject );
begin
S := '' ;
end ;
end .
Program ı n duraklat ı lmas ı
Uses
....
Winprocs
....;
Procedure delay ( millisecs : longint );
{ Milisaniyelik duraklatma }
var
Bitir : longint ;
begin
bitir := gettickcount + millisecs ;
while bitir - gettickcount < 0 do
Application . ProcessMessages ;
end ; { delay }
Delay ( 5000 ), 5 saniyelik bir duraklamaya sebep olur .
Yaz ı karakteri stilinin de ğ i ş tirilmesi
with edit1 do
begin
Font. Style := Font . Style + [ fsStrikeOut ];
Font. Style := Font . Style + [ fsUnderline ];
Font. Style := Font . Style - [ fsBold ];
end ;
Mevcut bir davran ışı n de ğ i ş tirilmesi
Bir s ı n ı f eleman ı olan davran ışı n , alt s ı n ı flarda de ğ i ş tirilerek kullan ı lmas ı ş u ş ekilde olur .
S ı n ı f tan ı m ı n ı n Protected b ö l ü m ü ndeki tan ı mlama ;
…
procedure Click ; override ;
…
Implementation b ö l ü m ü ndeki tan ı mlama
procedure TYeniButton . Click ;
begin
inherited Click ;
(Owner as TForm ). Close ;
end ;
Kes , Kopyala , Yap ş t ı r
Kesme , Kopyalama ve Yap ış t ı rma i ş lemlerini , Klavye kullan ı larak yapmak olduk ç a kolayd ı r . Bu i ş lemler men ü elemanlar ı vas ı tas ı yla da yap ı labilir . Ş ayet bile ş en , bu komutlar ı ald ığı nda ne yapaca ğı n ı biliyorsa , Windows mesajlar ı n ı kullanmak en uygun hareket tarz ı d ı r .
Kesme ;
if GetFocus <> 0 then { Seçili bir pencere varmı? }
SendMessage ( GetFocus , WM_CUT , 0 , 0
Kopyalama ;
if GetFocus <> 0 then { Seçili bir pencere varmı? }
SendMessage ( GetFocus , WM_COPY , 0 , 0
Yap ış t ı rma ;
if GetFocus <> 0 then { Seçili bir pencere varmı? }
SendMessage ( GetFocus , WM_PASTE , 0 , 0 );
Fare imlecinin , pencere ü zerinde olup olmad ığı n ı n kontrol ü
Form 'un OnMouseMove olayında;
procedure TForm1 . FormMouseMove ( Sender : TObject ; Shift : TShiftState ; X ,
Y : Integer );
var
P : TPoint ;
begin
P . X := X ;
P . Y := Y ;
if PtInRect ( ClientRect , P ) then {bütün pencere için sadece "rect"}
MouseCapture := True
else
begin
MouseCapture := False ;
ShowMessage ( 'Benim üzerimde değil' );
end ;
end ;
GetKeyBoardState
Sistem tu ş lar ı n ı n durumunu öğ renmenin en kolay yolu , klavye ü zerindeki LED 'lere bakmaktır. Kod içerisinden bunu anlamanın yolu ise aşağıdadır.
Tu ş durumlar ı, paneller ü zerindeki yaz ı n ı n s ö n ü k veya koyu olmas ı ile g ö sterilmektedir . Bu nedenle form ü zerine 4 adet panel yerle ş tirip isimlerini Captio ö zelliklerini ayarlay ı n . Ttimer bile ş eninin OnTimer olay ı na da a ş a ğı daki kodu yaz ı n .
procedure TForm1 . Timer1Timer ( Sender : TObject );
const
vkconsts : array [ 0 .. 3 ] of Word =( vk_Scroll , vk_Insert , vk_Capital , vk_NumLock );
PanelColor : array [ Boolean ] of TColor =( clGray , clBlack );
var
Toggles : array [ 0 .. 3 ] of Bool ;
Panels : array [ 0 .. 3 ] of TPanel ;
I : Integer ;
begin
for I := Low ( vkconsts ) to High ( vkconsts ) do
begin
Toggles [ I ] := Bool ( GetKeyState ( vkconsts [ I ]) and 1 );
if stToggles [ I ]<> Toggles [ I ] then
begin
stToggles [ I ] := Toggles [ I ];
case i of
0 : PanelScrollLock . Font . Color := PanelColor [ Toggles [ I ]];
1 : PanelINS . Font . Color := PanelColor [ Toggles [ I ]];
2 : PanelCAPS . Font . Color := PanelColor [ Toggles [ I ]];
3 : PanelNUM . Font . Color := PanelColor [ Toggles [ I ]];
end ;
end ;
end ;
end ;
Olay yakalama yordamlar ı n ı n dinamik olarak atanmas ı
Dinamik olarak bir PopUp men ü yarat ı ld ığı nda , men ü elemanlar ı n ı n alt ı na , se ç ildiklerinde yapacaklar ı i ş lerle ilgili olarak do ğ rudan kod yazmak m ü mk ü n de ğ ildir . Bunun yerine , hangi men ü eleman ı n ı n ne yapaca ğı n ı bilen tek bir yordam yaz ı p , gerekti ğ inde ç a ğı rabilirsiniz . Sender ö zelli ğ ine g ö re , se ç ilen men ü eleman ı da tespit edilip , gereken kod ç al ış t ı r ı labilir .
procedure MyPopUpClick ( Sender : TObject );
begin
end ;
Yukar ı daki yordam PopUp men ü n ü n OnClick olay ı na ş u ş ekilde e ş itlenir .
procedure TForm1 . TestButtonClick ( Sender : TObject );
begin
:
MyPopUp . OnClick = MyPopUpClick ;
:
end ;
Sender parametresinin kullan ı lmas ı
with Sender as TEdit do
begin
case Tag of
1 : bir ş eyler yap
2 : Ba ş ka bir ş eyler yap
end ; {case}
end ;
B ü y ü k metinlerin panodan al ı nmas ı
var
Buffer : PChar ;
MyHandle : THandle ;
TextLength : Integer ;
begin
MyHandle := Clipboard . GetAsHandle ( CF_TEXT );
Buffer := GlobalLock ( MyHandle );
If Buffer = Nil then
begin
GlobalUnlock ( MyHandle );
exit ;
end ;
TextLength := StrLen ( buffer );
Windows s ü r ü m numaras ı n ı n okunmas ı
GetVersion api fonksiyonu kullan ı larak , ç al ış makta olan Windows 'un sürüm numarası nasıl alınabilir. Bu fonksiyonun dödürdüğü sonuç içerisinde sürüm numarası nasıl ayıklanır?
program Winvrsn ;
uses
WinTypes ,
WinProcs ,
SysUtils ;
procedure TForm1 . Button2Click ( Sender : TObject );
var
WinVersion : Word ;
DosVersion : Word ;
VersionString : String ;
begin
WinVersion := GetVersion and $0000FFFF ;
DosVersion := ( GetVersion and $FFFF0000 ) shr 16 ;
VersionString := 'DOS : ' + IntToStr ( Hi ( DOSVersion )) + '.' + IntToStr ( Lo ( DOSVersion )) + #13 +
'Windows : ' + IntToStr ( Lo ( WinVersion )) + '.' + IntToStr ( Hi ( WinVersion )) + #0 ;
MessageBox ( 0 , @ VersionString [ 1 ], 'Version Information' , MB_ICONINFORMATION or MB_OK )
end ;
Program guruplar ı n ı n listbox bile ş enine doldurulmas ı
Sistemde tan ı ml ı olan program guruplar ı n ı n elde edilip , bir listbox i ç erisine doldurulmas ı i ç in neler yap ı lmal ı d ı r ?
unit Unit1 ;
interface
uses
Windows , Messages , SysUtils , Classes , Graphics , Controls , Forms , Dialogs , StdCtrls , DdeMan ;
type
TForm1 = class ( TForm )
Button1 : TButton ;
FGroupsList : TListBox ;
FDDEClient : TDdeClientConv ;
procedure Button1Click ( Sender : TObject );
private
{ Private declarations }
public
{ Public declarations }
Procedure ReadGroups ;
end ;
var
Form1 : TForm1 ;
implementation
{$R *.DFM}
Procedure TForm1 . ReadGroups ;
Var
GroupData : PChar ;
TmpStr : String ;
FNumGroups , i : integer ;
begin
GroupData := FDDEClient . RequestData ( 'Groups' );
FGroupsList . Clear ;
FNumGroups := 0 ;
if GroupData = nil then
exit
else
begin
i := 0 ;
TmpStr := '' ;
While GroupData [ i ] <> #0 do
begin
if GroupData [ i ] = #13 then
begin
FGroupsList . items . Add ( TmpStr );
TmpStr := '' ;
i := i + 1 ;
end
else
TmpStr := TmpStr + GroupData [ i ];
i := i + 1 ;
end ;
end ;
StrDispose ( GroupData );
end ;
procedure TForm1 . Button1Click ( Sender : TObject );
begin
ReadGroups
end ;
end .
Yukar ı daki kod i ç in kullan ı lan form ise ş u ş ekildedir .
object Form1 : TForm1
Left = 200
Top = 111
Width = 374
Height = 486
Caption = 'Form1'
Font . Charset = DEFAULT_CHARSET
Font. Color = clWindowText
Font. Height = - 13
Font . Name = 'MS Sans Serif'
Font . Style = []
PixelsPerInch = 120
TextHeight = 16
object Button1 : TButton
Left = 280
Top = 408
Width = 75
Height = 41
Caption = 'Button1'
TabOrder = 0
OnClick = Button1Click
end
object FGroupsList : TListBox
Left = 8
Top = 0
Width = 265
Height = 449
ItemHeight = 16
TabOrder = 1
end
object FDDEClient : TDdeClientConv
DdeService = 'progman'
Left = 48
Top = 88
LinkInfo = (
'Service progman'
'Topic ')
end
end
TListBox ve TComboBox bile ş enleri i ç erisine resim yerle ş tirilmesi
ListBox ve ComboBox bile ş enleri i ç erisine yerle ş tirilen se ç imlik elemanlar ı n , sadece metin de ğ il , ayn ı zamanda BMP format ı ndaki resimleri de i ç ermesi , tasarlad ığı n ı z kullan ı c ı aray ü zlerinin , di ğ erlerinden farkl ı olmas ı n ı sa ğ lar . Bunun i ç in haz ı rlanm ış olan ö rnek kod a ş a ğı dad ı r .
Unit1 . pas ;
unit Unit1 ;
interface
uses
Windows , Messages , SysUtils , Classes , Graphics , Controls , Forms , Dialogs ,
StdCtrls ;
type
TForm1 = class ( TForm )
ComboBox1 : TComboBox ;
ListBox1 : TListBox ;
procedure FormCreate ( Sender : TObject );
procedure FormClose ( Sender : TObject ; var Action : TCloseAction );
procedure ComboBox1DrawItem ( Control : TWinControl ; Index : Integer ;
Rect : TRect ; State : TOwnerDrawState );
procedure ComboBox1MeasureItem ( Control : TWinControl ; Index : Integer ;
var Height : Integer );
procedure ListBox1DrawItem ( Control : TWinControl ; Index : Integer ;
Rect : TRect ; State : TOwnerDrawState );
procedure ListBox1MeasureItem ( Control : TWinControl ; Index : Integer ;
var Height : Integer );
private
{ Private declarations }
public
{ Public declarations }
end ;
var
Form1 : TForm1 ;
TheBitmap1 , TheBitmap2 , TheBitmap3 , TheBitmap4 ,
TheBitmap5 : TBitmap ;
implementation
{$R *.DFM}
procedure TForm1 . FormCreate ( Sender : TObject );
begin
TheBitmap1 := TBitmap . Create ;
TheBitmap1 . LoadFromFile ( 'C:Program FilesBorlandDelphi 3imagesbuttonsglobe.bmp' );
TheBitmap2 := TBitmap . Create ;
TheBitmap2 . LoadFromFile ( 'C:Program FilesBorlandDelphi 3imagesbuttonsvideo.bmp' );
TheBitmap3 := TBitmap . Create ;
TheBitmap3 . LoadFromFile ( 'C:Program FilesBorlandDelphi 3imagesbuttonsgears.bmp' );
TheBitmap4 := TBitmap . Create ;
TheBitmap4 . LoadFromFile ( 'C:Program FilesBorlandDelphi 3imagesbuttonskey.bmp' );
TheBitmap5 := TBitmap . Create ;
TheBitmap5 . LoadFromFile ( 'C:Program FilesBorlandDelphi 3imagesbuttonstools.bmp' );
ComboBox1 . Items . AddObject ( 'Bitmap1: Globe' , TheBitmap1 );
ComboBox1 . Items . AddObject ( 'Bitmap2: Video' , TheBitmap2 );
ComboBox1 . Items . AddObject ( 'Bitmap3: Gears' , TheBitmap3 );
ComboBox1 . Items . AddObject ( 'Bitmap4: Key' , TheBitmap4 );
ComboBox1 . Items . AddObject ( 'Bitmap5: Tools' , TheBitmap5 );
ListBox1 . Items . AddObject ( 'Bitmap1: Globe' , TheBitmap1 );
ListBox1 . Items . AddObject ( 'Bitmap2: Video' , TheBitmap2 );
ListBox1 . Items . AddObject ( 'Bitmap3: Gears' , TheBitmap3 );
ListBox1 . Items . AddObject ( 'Bitmap4: Key' , TheBitmap4 );
ListBox1 . Items . AddObject ( 'Bitmap5: Tools' , TheBitmap5 );
end ;
procedure TForm1 . FormClose ( Sender : TObject ; var Action : TCloseAction );
begin
TheBitmap1 . Free ;
TheBitmap2 . Free ;
TheBitmap3 . Free ;
TheBitmap4 . Free ;
TheBitmap5 . Free ;
end ;
procedure TForm1 . ComboBox1DrawItem ( Control : TWinControl ; Index : Integer ;
Rect : TRect ; State : TOwnerDrawState );
var
Bitmap : TBitmap ;
Offset : Integer ;
begin
with ( Control as TComboBox ). Canvas do
begin
FillRect ( Rect );
Bitmap := TBitmap ( ComboBox1 . Items . Objects [ Index ]);
if Bitmap <> nil then
begin
BrushCopy ( Bounds ( Rect . Left + 2 , Rect . Top + 2 , Bitmap . Width ,
Bitmap . Height ), Bitmap , Bounds ( 0 , 0 , Bitmap . Width ,
Bitmap . Height ), clRed );
Offset := Bitmap . width + 8 ;
end ;
{ display the text }
TextOut ( Rect . Left + Offset , Rect . Top , Combobox1 . Items [ Index ])
end ;
end ;
procedure TForm1 . ComboBox1MeasureItem ( Control : TWinControl ; Index : Integer ; var Height : Integer );
begin
height := 20 ;
end ;
procedure TForm1 . ListBox1DrawItem ( Control : TWinControl ; Index : Integer ;
Rect : TRect ; State : TOwnerDrawState );
var
Bitmap : TBitmap ;
Offset : Integer ;
begin
with ( Control as TListBox ). Canvas do
begin
FillRect ( Rect );
Bitmap := TBitmap ( ListBox1 . Items . Objects [ Index ]);
if Bitmap <> nil then
begin
BrushCopy ( Bounds ( Rect . Left + 2 , Rect . Top + 2 , Bitmap . Width ,
Bitmap . Height ), Bitmap , Bounds ( 0 , 0 , Bitmap . Width ,
Bitmap . Height ), clRed );
Offset := Bitmap . width + 8 ;
end ;
{ display the text }
TextOut ( Rect . Left + Offset , Rect . Top , Listbox1 . Items [ Index ])
end ;
end ;
procedure TForm1 . ListBox1MeasureItem ( Control : TWinControl ; Index : Integer ;
var Height : Integer );
begin
height := 20 ;
end ;
end .
Unit1 . dfm
object Form1 : TForm1
Left = 211
Top = 155
Width = 526
Height = 320
Caption = 'Form1'
Font . Charset = DEFAULT_CHARSET
Font. Color = clWindowText
Font. Height = - 16
Font . Name = 'System'
Font . Style = []
OnClose = FormClose
OnCreate = FormCreate
PixelsPerInch = 120
TextHeight = 20
object ComboBox1 : TComboBox
Left = 33
Top = 38
Width = 206
Height = 22
Style = csOwnerDrawVariable
ItemHeight = 16
TabOrder = 0
OnDrawItem = ComboBox1DrawItem
OnMeasureItem = ComboBox1MeasureItem
end
object ListBox1 : TListBox
Left = 270
Top = 35
Width = 189
Height = 209
ItemHeight = 16
Style = lbOwnerDrawVariable
TabOrder = 1
OnDrawItem = ListBox1DrawItem
OnMeasureItem = ListBox1MeasureItem
end
end
Basit bir DLL ş ablonu
Delphi 'de DLL hazırlamak hiç te zor değil. Aşağıdaki kod örneği derlendiğinde, uzantısı otomatik olarak,DLL olarak verilecektir.. Bu DLL "Fonksiyon" isimli tek bir fonksiyon ihraç etmektedir.
library Dllframe ;
uses WinTypes ;
function Fonksiyon : string ; export ;
begin
Result := 'DLL' den merhaba ! ' ;
end ;
exports
Fonksiyon ;
begin
end .
İ pucu penceresinin ö zelle ş tirilmesi
Standart ipucu penceresi , k ı smen de olsa ö zelle ş tirilebilir . İş te ö rne ğ i .
Type
TMyHintWindow = Class ( THintWindow )
Constructor Create ( AOwner : TComponent ); override ;
end ;
var
Form1 : TForm1 ;
implementation
Constructor TMyHintWindow . Create ( AOwner : TComponent );
begin
Inherited Create ( AOwner );
canvas . brush . color := clwhite ;
Canvas . Font . Name := 'Courier New' ;
Canvas . Font . Size := 72 ;
end ;
procedure TForm1 . FormCreate ( Sender : TObject );
begin
Application . ShowHint := false ;
HintWindowClass := TMyHintWindow ;
Application . ShowHint := True ;
end ;
Dizi sabiti tan ı m ı
TYPE
NAME1 = Array [ 1 .. 4 , 1 .. 10 ] of Integer ;
Const
NAME2 : NAME1 = (( 1 , 2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 ),
(1 , 2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 ),
(1 , 2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 ),
(1 , 2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 ));
StrinGrid bile ş eni i ç erisindeki metnin hizalamas ı
StringGrid bile ş eni h ü crelerindeki metin , Grid1DrawCell olay yordam ı na eklenecek birka ç sat ı r kodla hizalanabilir .
procedure Tform1 . Grid1DrawCell ( Sender : TObject ; Col , Row : Longint ;
Rect : TRect ; State : TGridDrawState );
var l_oldalign : word ;
begin
if ( row = 0 ) or ( col < 2 ) then
grid1 . canvas . font . style := grid1 . canvas . font . style +[ fsbold ];
if col <> 1 then
begin
l_oldalign := settextalign ( grid1 . canvas . handle , ta_right );
grid1 . canvas . textrect ( rect , rect . right - 2 , Rect . top + 2 , grid1 . cells [ col , row ]);
settextalign ( grid1 . canvas . handle , l_oldalign );
end
else
begin
grid1 . canvas . textrect ( rect , rect . left + 2 , rect . top + 2 , grid1 . cells [ col , row ]);
end ;
grid1 . canvas . font . style := grid1 . canvas . font . style -[ fsbold ];
end ;
end .
TstringGrid bile ş eninden bir sat ı r ı n silinmesi
Bu fonksiyonu " RowNumber " parametresi ile belirtilen sat ı r ı StringGrid bile ş eninden siler .
procedure GridDeleteRow ( RowNumber : Integer ; Grid : TStringGrid );
Var
i : Integer ;
Begin
Grid . Row := RowNumber ;
If ( Grid . Row = Grid . RowCount - 1 ) Then
Begin
{On the last row}
Grid . RowCount := Grid . RowCount - 1 ;
End
Else
Begin
{Not the last row}
For i := RowNumber To Grid . RowCount - 1 Do
Begin
Grid . Rows [ i ] := Grid . Rows [ i + 1 ];
End ;
Grid . RowCount := Grid . RowCount - 1 ;
End ;
End ;
TstringGrid sat ı r ı n ı n en alta g ö nderilmesi
Bu fonksiyon , " RowNumber " parametresi ile belirtilen sat ı r ı, StringGrid bile ş eninin en son sat ı r ı na g ö nderir .
procedure GridMoveRowToBottom ( RowNumber : Integer ; Grid : TStringGrid );
Var
i : Integer ;
Begin
Grid . Row := RowNumber ;
Grid . RowCount := Grid . RowCount + 1 ;
Grid . Rows [ Grid . RowCount - 1 ] := Grid . Rows [ Grid . Row ];
For i := RowNumber + 1 To Grid . RowCount - 1 Do
Begin
Grid . Rows [ i - 1 ] := Grid . Rows [ i ];
End ;
Grid . RowCount := Grid . RowCount - 1 ;
End ;
Sistemde tan ı ml ı yaz ı c ı lar ı n listelenmesi
//uses printers
var
printer : tprinter ;
begin
printer := tprinter . create ;
listbox1 . items . assign ( printer . printers )
end ;
Yazd ı rma
Kullan ı c ı butona bast ığı nda , bir adet Bitmap nesnesi yarat ı l ı p , i ç eri ğ i dosyadan al ı nmakta ve ka ğı d ı ortalayacak ş ekilde resim bas ı lmaktad ı r .
//uses printers
procedure TForm1 . Button1Click ( Sender : TObject );
var
TBitmap bmp ;
begin
bmp = TBitmap . Create ;
bmp . LoadFromFile ( 'MyBitmap.bmp' );
with Printer do
begin
BeginDoc ;
Canvas . Draw (( PageWidth - bmp . Width ) div 2 ,
(PageHeight - bmp . Height ) div 2 , bmp );
EndDoc ;
end ;
bmp . Free ;
end ;
istenen yaz ı c ı n ı n se ç imi
Sistemde tan ı ml ı birden fazla yaz ı c ı varsa , yaz ı c ı lar 0 'dan başlayacak şekilde numaralanır. İstenen yazıcının kullanılabilmesi veya hangi yazıcının seçili olduğunun öğrenilmesi için, Tprinter nesnesininin Printerindex özelliği kullanılır. Kullanılmakta olan yazıcının numarası bu özellikte saklanır. Değiştirilecek ise, kullanılacak yazıcının numarası, yine bu özelliğe atanır. Bu özellikte "-1" değeri varsa, varsayılan yazıcı seçili muamelesi görür.
//uses printers
var
printer : tprinter ;
begin
printer := tprinter . create ;
printer . printerindex := 0 ;
end ;
Yaz ı c ı yaz ı tipleri
Se ç ili durumaki yaz ı c ı taraf ı ndan desteklenmekte olan yaz ı tipleri a ş a ğı daki y ö ntemle listelenir .
//uses printers
var
printer : tprinter ;
begin
printer := tprinter . create ;
listbox1 . items . assign ( printer . fonts )
end ;
HEX -> Dec
A ş a ğı daki fonksiyon , 16 taban ı ndaki bir say ı n ı n ondal ı k say ı ya ç evirilmesi i ç in kullan ı labilecek bir fonksiyondur .
procedure TForm1 . Button1Click ( Sender : TObject );
CONST HEX : ARRAY [ 'A' .. 'F' ] OF INTEGER = ( 10 , 11 , 12 , 13 , 14 , 15 );
VAR str : String ;
Int ,
i : integer ;
BEGIN
STR := EDIT1 . TEXT ;
Int := 0 ;
FOR i := 1 TO Length ( str ) DO
IF str [ i ] < 'A' THEN Int := Int * 16 + ORD ( str [ i ]) - 48
ELSE Int := Int * 16 + HEX [ str [ i ]];
edit1 . text := inttostr ( int );
end ;
Haf ı za miktar ı
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}
Function MyGetExt : Integer ; Assembler ;
asm
Mov AX,$3031;
Out $70,AL;
NOP;
IN AL,$71;
XCHG AH,AL;
Out $70,AL;
NOP;
IN AL,$71;
end ;
procedure TForm1 . Button1Click ( Sender : TObject );
begin
showmessage ( inttostr ( MyGetExt ))
end ;
end .
Fare hareket alan ı n ı n k ı s ı tlanmas ı
A ş a ğı daki kod ö rne ğ inde , farenin sol tu ş una bas ı l ı yken , imle ç form ü zerinden ba ş ka bir yere ta şı namamaktad ı r .
unit Unit1 ;
interface
uses
Windows , Messages , SysUtils , Classes , Graphics , Controls , Forms , Dialogs ;
type
TForm1 = class ( TForm )
procedure FormMouseDown ( Sender : TObject ; Button : TMouseButton ;
Shift : TShiftState ; X , Y : Integer );
procedure FormMouseUp ( Sender : TObject ; Button : TMouseButton ;
Shift : TShiftState ; X , Y : Integer );
private
{ Private declarations }
public
{ Public declarations }
end ;
var
Form1 : TForm1 ;
implementation
{$R *.DFM}
procedure TForm1 . FormMouseDown ( Sender : TObject ; Button : TMouseButton ;
Shift : TShiftState ; X , Y : Integer );
var
r : trect ;
begin
canvas . pen . mode := pmxor ;
canvas . Pen . style := psdot ;
r := boundsrect ;
inflaterect ( r ,- 30 ,- 30 );
clipcursor (@ r );
end ;
procedure TForm1 . FormMouseUp ( Sender : TObject ; Button : TMouseButton ;
Shift : TShiftState ; X , Y : Integer );
begin
clipcursor ( nil );
end ;
end .
PgUp ve PgDown tu ş lar ı ile formu a ş a ğı yukar ı kayd ı rma
Kalabal ı k veya k üçü lt ü lm üş formlarda , baz ı kontroller , g ö r ü nmeyen b ö lgede kal ı rlar . Gerekti ğ inde Kayd ı rma ç ubuklar ı ile formun g ö r ü nmeyen b ö lgelerine ula ş mak elbetteki m ü mk ü nd ü r . Bu i ş lem , klavye kullan ı larak da ş u ş ekilde yap ı labilir .
Form . Keypreview ö zelli ğ i TRUE olmal ı d ı r .
unit Unit1 ;
interface
uses
Windows , Messages , SysUtils , Classes , Graphics , Controls , Forms , Dialogs ,
StdCtrls ;
type
TForm1 = class ( TForm )
Edit1 : TEdit ;
Memo1 : TMemo ;
ListBox1 : TListBox ;
procedure FormKeyDown ( Sender : TObject ; var Key : Word ;
Shift : TShiftState );
private
{ Private declarations }
public
{ Public declarations }
end ;
var
Form1 : TForm1 ;
implementation
{$R *.DFM}
procedure TForm1 . FormKeyDown ( Sender : TObject ; var Key : Word ;
Shift : TShiftState );
const
delta = 10 ;
begin
with vertscrollbar do
if key = vk_next then position := position + delta
else if key = vk_prior then position := position - delta ;
end ;
end .
Ö zel yaz ı karakteri
Kendi yaz ı karakterinizi kullan ı n .
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 );
var
dc : hdc ;
thefont : hfont ;
begin
dc := getdc ( handle );
thefont := createfont ( 24 , //yükseklik
16 , //ortalama karakter genişliği
0 , //yatış açısı
0 , //yönlendiröe açısı
400 , //yazı karakteri ağırlığı
0 , //italiklik bayrağı
0 , //alt çizgi bayrağı
0 , //vurgu bayrağı
oem_charset , // karakter seti
out_default_precis , //çıkış vurgusu
clip_default_precis , //kesme vurgusu
default_quality , //çıktı kalitesi
default_pitch or ff_script , //vurgu ve aile
'script' //ad
);
selectobject ( dc , thefont );
textout ( dc , 10 , 10 , 'Merhaba Dünya' , 24 );
releasedc ( handle , dc );
deleteobject ( thefont );
end ;
end .
Ekran koruyucu
Bir ekran koruyucusu nas ı l olur . İş te ö rne ğ i :
" Proje dosyası na , projenin ekran koruyucu olaca ğı na dair bir bilgi sat ı r ı eklenmelidir .
{$D SCRSAVE <Ekran koruyucu adı} >
" Ana formdaki kenarlı klar , ve ikonlar tamamen kald ı r ı lmal ı d ı r .
" Form aktif hale gelirken, Left ve Top de ğ erleri " 0 " a e ş itlenmelidir .
" Form. Windowstate = WsMaximized olmal ı d ı r .
" Formun yaratı lmas ı esnas ı nda , Application . Onmessage olay yordam ı na , Ekran koruyucunun devreden çı kmas ı n ı sa ğ layacak yordam atanmal ı d ı r .
" Program parametrelerine "/ c " eklenmelidir . ( Run | Parameters men ü s ü nden )
" Program derlendikten sonra uzant ı s ı " SCR " olarak de ğ i ş tirilmeli ve Windows dizinine kopyalanmal ı d ı r .
Scrn . PAS
unit Scrn ;
interface
uses
SysUtils , WinTypes , WinProcs , Messages , Classes , Graphics , Controls ,
Forms , Dialogs , ExtCtrls ;
type
TScrnFrm = class ( TForm )
tmrTick : TTimer ;
procedure tmrTickTimer ( Sender : TObject );
procedure FormShow ( Sender : TObject );
procedure FormHide ( Sender : TObject );
procedure FormActivate ( Sender : TObject );
private
{ Private declarations }
procedure DrawSphere ( x , y , size : integer ; color : TColor );
procedure DeactivateScrnSaver ( var Msg : TMsg ; var Handled : boolean );
public
{ Public declarations }
end ;
var
ScrnFrm : TScrnFrm ;
implementation
{$R *.DFM}
var
crs : TPoint ; {Fare imlecinin orjinal yeri.}
function Min ( a , b : integer ) : integer ;
begin
if b < a then
Result := b
else
Result := a ;
end ; {Min}
procedure TScrnFrm . DrawSphere ( x , y , size : integer ; color : TColor );
var
i , dw : integer ;
cx , cy : integer ;
xy1 , xy2 : integer ;
r , g , b : byte ;
begin
with Canvas do begin
{Fırça ve kalem şekilleri.}
Pen . Style := psClear ;
Brush . Style := bsSolid ;
Brush . Color := color ;
{Renk karışımları.}
r := GetRValue ( color );
g := GetGValue ( color );
b := GetBValue ( color );
{Topların çizimi.}
dw := size div 16 ;
for i := 0 to 15 do begin
xy1 := ( i * dw ) div 2 ;
xy2 := size - xy1 ;
Brush . Color := RGB ( Min ( r + ( i * 8 ), 255 ), Min ( g + ( i * 8 ), 255 ),
Min ( b + ( i * 8 ), 255 ));
Ellipse ( x + xy1 , y + xy1 , x + xy2 , y + xy2 );
end ;
end ;
end ; {TScrnFrm.DrawSphere}
procedure TScrnFrm . DeactivateScrnSaver ( var Msg : TMsg ; var Handled : boolean );
var
done : boolean ;
begin
if Msg . message = WM_MOUSEMOVE then
done := ( Abs ( LOWORD ( Msg . lParam ) - crs . x ) > 5 ) or
( Abs ( HIWORD ( Msg . lParam ) - crs . y ) > 5 )
else
done := ( Msg . message = WM_KEYDOWN ) or ( Msg . message = WM_KEYUP ) or
( Msg . message = WM_SYSKEYDOWN ) or ( Msg . message = WM_SYSKEYUP ) or
( Msg . message = WM_ACTIVATE ) or ( Msg . message = WM_NCACTIVATE ) or
( Msg . message = WM_ACTIVATEAPP ) or ( Msg . message = WM_LBUTTONDOWN ) or
( Msg . message = WM_RBUTTONDOWN ) or ( Msg . message = WM_MBUTTONDOWN );
if done then
Close ;
end ; {TScrnFrm.DeactivateScrnSaver}
procedure TScrnFrm . tmrTickTimer ( Sender : TObject );
const
sphcount : integer = 0 ;
var
x , y : integer ;
size : integer ;
r , g , b : byte ;
color : TColor ;
begin
Inc ( sphcount );
x := Random ( ClientWidth );
y := Random ( ClientHeight );
size := 25 ;
x := x - size div 2 ;
y := y - size div 2 ;
r := Random ( $80 );
g := Random ( $80 );
b := Random ( $80 );
DrawSphere ( x , y , size , RGB ( r , g , b ));
end ; {TScrnFrm.tmrTickTimer}
procedure TScrnFrm . FormShow ( Sender : TObject );
begin
GetCursorPos ( crs );
tmrTick . Interval := 100 ;
tmrTick . Enabled := true ;
Application . OnMessage := DeactivateScrnSaver ;
ShowCursor ( false );
end ; {TScrnFrm.FormShow}
procedure TScrnFrm . FormHide ( Sender : TObject );
begin
Application . OnMessage := nil ;
tmrTick . Enabled := false ;
ShowCursor ( true );
end ; {TScrnFrm.FormHide}
procedure TScrnFrm . FormActivate ( Sender : TObject );
begin
WindowState := wsMaximized ;
end ; {TScrnFrm.FormActivate}
end .
Spheres . DPR
program Spheres ;
uses
Forms ,
SysUtils ,
Scrn in 'SCRN.PAS' {ScrnFrm} ;
{$R *.RES}
{$D SCRNSAVE Spheres Ekran koruyucu}
begin
{Sadece birkez çalışmalı.}
if hPrevInst = 0 then
begin
if ( ParamCount > 0 ) and ( UpperCase ( ParamStr ( 1 )) = '/S' ) then
begin
Application . CreateForm ( TScrnFrm , ScrnFrm );
application . initialize ;
Application . Run ;
end else application . Terminate ;
end ;
end .
Bir nesnedeki ö zelliklerin listesi
procedure ObjectInspector (
Obj : TObject ;
Items : TStrings );
var
n : integer ;
PropList : TPropList ;
begin
n := 0 ;
GetPropList (
Obj . ClassInfo ,
tkProperties + [ tkMethod ],
@PropList );
while ( ( Nil <> PropList [ n ]) and
( n < High ( PropList )) ) do
begin
Items . Add (
PropList [ n ]. Name + ': ' +
PropList [ n ]. PropType ^. Name );
Inc ( n );
end ;
end ;
Haberle ş me portlar ı na eri ş im
Haberle ş me kanallar ı ndan bilgi almak veya kanallara bilgi yazmak i ç in a ş a ğı daki fonksiyonlar kullan ı labilir . Belirtilen numaradaki kanala her seferinde bir Byte bilgi yaz ı labilir veya kanaldan 1 Byte '' ı k bilgi okunabilir .
function ReadPortB
( wPort : Word ) : Byte ;
begin
asm
mov dx, wPort
in al, dx
mov result, al
end ;
end ;
procedure WritePortB
( wPort : Word ; bValue : Byte );
begin
asm
mov dx, wPort
mov al, bValue
out dx, al
end ;
end ;
Bile ş en ö zelliklerinin Kay ı t defterinde saklanmas ı
Bile ş enlerin , Published tipindeki ö zellikleri , kay ı t defterine yaz ı larak , gelecekte tekrar kullan ı lmak ü zere saklanabilir . Ö rnek kod a ş a ğı dad ı r .
unit unit1 ;
interface
uses
Windows , Messages , SysUtils , Classes , Graphics , Controls , Forms , Dialogs , registry , TypInfo ,
StdCtrls ;
type
TForm1 = class ( TForm )
xxzzbtn1 : TButton ;
procedure xxzzbtn1Click ( Sender : TObject );
private
{ Private declarations }
public
{ Public declarations }
end ;
procedure SaveToRegistry ( Obj : TPersistent ; Reg : TRegistry );
procedure SaveToKey ( Obj : TPersistent ; const KeyPath : string );
procedure SaveSetToRegistry ( const Name : string ; Value : Integer ; gTypeInfo : PTypeInfo ; Reg : TRegistry );
procedure SaveObjToRegistry ( const Name : string ; Obj : TPersistent ; Reg : TRegistry );
procedure SavePropToRegistry ( Obj : TPersistent ; PropInfo : PPropInfo ; Reg : TRegistry );
var
Form1 : TForm1 ;
implementation
{$R *.DFM}
{integer sayıların, bitlerine ulaşabilmek için, bir tip kümesi oluşturulmalıdır. }
const
BitsPerByte = 8 ;
type
TIntegerSet = set of 0 .. SizeOf ( Integer )* BitsPerByte - 1 ;
{ Özellik kümesini, ayrı bir alt anahtar altına BOLLEAN olarak kaydederek, sonradan REGEDIT vasıtasıyla düzeltme imkanı elde edilir. }
procedure SaveToRegistry ( Obj : TPersistent ; Reg : TRegistry );
var
PropList : PPropList ;
PropCount : Integer ;
I : Integer ;
begin
{ Published özelliklerin listesini oluştur. }
PropCount := GetTypeData ( Obj . ClassInfo )^. PropCount ;
GetMem ( PropList , PropCount * SizeOf ( PPropInfo ));
try
GetPropInfos ( Obj . ClassInfo , PropList );
{ Her özelliği, mevcut anahtara ait bir değer olarak sakla }
for I := 0 to PropCount - 1 do
SavePropToRegistry ( Obj , PropList ^[ I ], Reg );
finally
FreeMem ( PropList , PropCount * SizeOf ( PPropInfo ));
end ;
end ;
{ Published özellikleri, verilen anahtarın altına değer olarak yaz. Bu anahtar, HKEY_CURRENT_USER.anahtarının altında yer alacaktır. }
procedure SaveToKey ( Obj : TPersistent ; const KeyPath : string );
var
Reg : TRegistry ;
begin
Reg := TRegistry . Create ;
try
if not Reg . OpenKey ( KeyPath , True ) then
raise ERegistryException . CreateFmt ( 'Anahtar yaratılamadı: %s' ,[ KeyPath ]);
SaveToRegistry ( Obj , Reg );
finally
Reg . Free ;
end ;
end ;
procedure SaveSetToRegistry ( const Name : string ; Value : Integer ;
gTypeInfo : PTypeInfo ; Reg : TRegistry );
var
OldKey : string ;
I : Integer ;
pppTypeInfo : PPTypeInfo ;
begin
pppTypeInfo := GetTypeData ( gTypeInfo )^. CompType ;
OldKey := '' + Reg . CurrentPath ;
if not Reg . OpenKey ( Name , True ) then
raise ERegistryException . CreateFmt ( 'Anahtar yaratılamadı: %s' ,[ Name ]);
{ Enumarated tipli değişken değerlerini teker teker dolaş }
with GetTypeData ( gTypeInfo )^ do
for I := MinValue to MaxValue do
{ her küme elemanı için, bir BOOLEAN değer yaz. }
Reg . WriteBool ( GetEnumName ( gTypeInfo , I ), I in TIntegerSet ( Value ));
{ Üst anahtara dön. }
Reg . OpenKey ( OldKey , False );
end ;
{Bütün alt nesnelerin özelliklerini, alt anahtar altına yaz}
procedure SaveObjToRegistry ( const Name : string ; Obj : TPersistent ; Reg : TRegistry );
var
OldKey : string ;
begin
OldKey := '' + Reg . CurrentPath ;
{ Nesne için bir alt anahtar aç. }
if not Reg . OpenKey ( Name , True ) then
raise ERegistryException . CreateFmt ( 'Anahtar yaratılamadı: %s' ,[ Name ]);
{ Nesne özelliklerini sakla }
SaveToRegistry ( Obj , Reg );
{Üst anahtara dön }
Reg . OpenKey ( OldKey , False );
end ;
{ Bir davranışın kayıt defterine saklanması. }
procedure SaveMethodToRegistry ( const Name : string ; const Method : TMethod ; Reg : TRegistry );
var
MethodName : string ;
begin
{ Method işaretçisi nil ise sadece boş bir karakter dizisi yaz. }
if Method . Code = nil then
MethodName := ''
else
{ davranışın adını bul. }
MethodName := TObject ( Method . Data ). MethodName ( Method . Code );
Reg . WriteString ( Name , MethodName );
end ;
{ Tek bir özelliği kayıt defterine mevcut anahtarın altına kaydetmek için }
procedure SavePropToRegistry ( Obj : TPersistent ; PropInfo : PPropInfo ; Reg : TRegistry );
begin
with PropInfo ^ do
case PropType ^. Kind of
tkInteger ,
tkChar ,
tkWChar :
begin
{ ordinal özellikleri integer olarak sakla. }
Reg . WriteInteger ( Name , GetOrdProp ( Obj , PropInfo ));
end ;
tkEnumeration :
{ enumerated değerleri kendi isimleriyle sakla. }
Reg . WriteString ( Name , GetEnumName ( PropType ^, GetOrdProp ( Obj , PropInfo )));
tkFloat :
{ floating point değerleri Double olarak sakla. }
Reg . WriteFloat ( Name , GetFloatProp ( Obj , PropInfo ));
tkString ,
tkLString :
{ Store değerler strin olarak kalsın. }
Reg . WriteString ( Name , GetStrProp ( Obj , PropInfo ));
tkVariant :
{ variant değerler string olarak saklansın. }
Reg . WriteString ( Name , GetVariantProp ( Obj , PropInfo ));
tkSet :
{ kümeler alt anahtara saklansın. }
SaveSetToRegistry ( Name , GetOrdProp ( Obj , PropInfo ), PropType ^, Reg );
tkClass :
{ sınıflar da alt sınıf olarak saklansın, özellikleri de bu anahtarın altına değer olarak yazılsın.}
SaveObjToRegistry ( Name , TPersistent ( GetOrdProp ( Obj , PropInfo )), Reg );
tkMethod :
{ davranışlar isim olarak yazılsın. }
SaveMethodToRegistry ( Name , GetMethodProp ( Obj , PropInfo ), Reg );
end ;
end ;
procedure TForm1 . xxzzbtn1Click ( Sender : TObject );
var
r : tregistry ;
begin
r:= tregistry . create ;
r. openkey ( 'f1delphi' + form1 . name , true );
SaveToRegistry( form1 , R );
r. free ;
end ;
end .
ListBox i ç erisinde artan arama
Bir listbox i ç erisinden se ç ilerek ba ş ka bir alana , ö rne ğ in bir edit kontrol ü ne atanacak de ğ erlerin se ç im i ç in , artan arama yap ı labilir . Artan arama , edit i ç erisine yazd ığı n ı z bilgiye uygun olan ListBox eleman ı n ı n otomatik olarak se ç ili hale gelmesi demektir .
Kod ö rne ğ i a ş a ğı dad ı r .
unit incsearch ;
interface
uses
Windows , Messages , SysUtils , Classes , Graphics , Controls , Forms , Dialogs ,
StdCtrls ;
type
TForm1 = class ( TForm )
ListBox1 : TListBox ;
Edit1 : TEdit ;
procedure FormCreate ( Sender : TObject );
procedure Edit1Change ( Sender : TObject );
procedure Edit1KeyDown ( Sender : TObject ; var Key : Word ;
Shift : TShiftState );
private
{ Private declarations }
public
{ Public declarations }
end ;
var
Form1 : TForm1 ;
implementation
{$R *.DFM}
procedure TForm1 . FormCreate ( Sender : TObject );
begin
// ComboBox'un içine birşeyler doldurun
end ;
procedure TForm1 . Edit1Change ( Sender : TObject );
var
S : Array [ 0 .. 255 ] of Char ;
begin
StrPCopy ( S , Edit1 . Text );
with ListBox1 do
ItemIndex := Perform ( LB_SELECTSTRING , 0 , LongInt (@ S ));
end ;
procedure TForm1 . Edit1KeyDown ( Sender : TObject ; var Key : Word ;
Shift : TShiftState );
begin
if key = vk_return then edit1 . text := listbox1 . Items [ listbox1 . itemindex ];
end ;
end .
Sistem men ü s ü n ü n geli ş tirilmesi
unit sysmenu ;
interface
uses
SysUtils , WinTypes , WinProcs , Messages , Classes ,
Graphics , Controls , Forms , Dialogs , Menus ;
type
TForm1 = class ( TForm )
procedure FormCreate ( Sender : TObject );
private
{ Private declarations }
public
{Aşağıdaki tanım, mesaj yakalama yordamı içindir.
Yeni eklenen menü elemanına tıklandığının tespiti
için kullanılacaktır.}
procedure WinMsgHandler ( var Msg : TMsg ;
var Handled : Boolean );
end ;
var
Form1 : TForm1 ;
const
MyItem = 100 ; {Herhangi bir WORD değer olabilir.}
implementation
{$R *.DFM}
procedure TForm1 . FormCreate ( Sender : TObject );
begin
{Varolandan farklı bir mesaj yakalama yordamı kullanılacak}
Application . OnMessage := WinMsgHandler ;
{Menüye Bir ayıraç ekleniyor.}
AppendMenu ( GetSystemMenu ( Self . Handle , False ), MF_SEPARATOR , 0 , ' ' );
{Mevcut sistem menüsünün en sonuna,
Yeni menü ekleniyor}
AppendMenu ( GetSystemMenu ( Self . Handle , False ), F_BYPOSITION , MyItem , 'Yeni &Menü' );
end ;
procedure TForm1 . WinMsgHandler ( var Msg : TMsg ;
var Handled : Boolean );
begin
{Eğer mesaj, sistem mesajı ise...}
if Msg . Message = WM_SYSCOMMAND then
if Msg . wParam = MyItem then
{Menünüzün yapacağı işle ilgili kod buraya yazılacak}
ShowMessage ( 'Yenü menüye tıkladınız!!!' );
end ;
end .
Bir Tedit . text bilgisindeki de ğ i ş ikli ğ in farkedilmesi
var
changed : boolean ;
i : integer ;
begin
changed := false ;
for i := 0 to componentcount - 1 do
if components [ i ] is tedit then
changed :=( components [ i ] as tedit ). modified ;
if changed then showmessage ( 'değişti' );
end ;
ComboBox bile ş eninin , i ç ine girildi ğ inde a çı lmas ı ve kapanmas ı
Sendmessage ( combobox1 . handle , cb_showdropdown , integer ( true ), 0 );
Sendmessage ( combobox1 . handle , cb_showdropdown , integer ( false ), 0 );
Yaz ı c ı ya do ğ rudan bask ı g ö nderme i ş lemi
unit Esc1 ;
interface
uses
SysUtils , WinTypes , WinProcs , Messages , 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
uses
Printers ;
{$R *.DFM}
{ "PASSTHROUGH" yapısını belirle }
type TPrnBuffRec = record
BuffLength : word ;
Buffer : array [ 0 .. 255 ] of char ;
end ;
procedure TForm1 . Button1Click ( Sender : TObject );
var
Buff : TPrnBuffRec ;
TestInt : integer ;
s : string ;
begin
{ "PASSTHROUGH" işleminin desteklendiğinden emin ol }
TestInt := PASSTHROUGH ;
if Escape ( Printer . Handle ,
QUERYESCSUPPORT ,
sizeof ( TestInt ),
@TestInt ,
nil ) > 0 then
begin
{ Baskıyı başlat }
Printer . BeginDoc ;
{ Doğrudan gönderilecek metni hazırla }
s := ' Test satırı ' ;
{ Mtni Buffer'a kopyala }
StrPCopy ( Buff . Buffer , s );
{ Buffer uzunluğunu ayarla }
Buff . BuffLength := StrLen ( Buff . Buffer );
{ Gönder}
Escape ( Printer . Canvas . Handle ,
PASSTHROUGH ,
0 ,
@Buff ,
nil );
{ Baskıyı bitir }
Printer . EndDoc ;
end ;
end ;
end .
Bilgisayar ı kapat ı p yeniden ba ş latma
Bilgisayar ı kapat ı p , yeniden ba ş latmak i ç in kullan ı labilecek bir kod par ç ac ığı a ş a ğı dad ı r . Not : Bu kodu denemeden ö nce , dosyalar ı n ı z ı kaydedin .
asm
cli
@@WaitOutReady: {Meşgul- 8042 yeni bir komut için hazır olana kadar bekle}
in al,64h {8042 durumunu oku}
test al,00000010b { 1 nolu bit veri giriş bufferinin dolu olduğunu gösterişri }
jnz @@WaitOutReady
mov al,0FEh { "reset" = 8042 pin 0 }
out 64h,al
{ PC kapanıp yeniden açılacak }
End ;
Delphi - .....................................
Delphide yazdığınız program içinden başka bir pencerenin boyutlarını değiştirmek
//
// Diyelimki bir program içerisinden ekranda çalışır durumdaki Not Defterinin boyutlarını ve/veya konumunu değiştirmek istediniz
// İşte size güzel bir örnek. Formunuza 1 Buton koyun ve Click olayına aşağıdaki kodları ekleyin.
// Not Defterinin ekranda açık durduğundan emin olun ve butona basın. Boyut değişecektir.
//
Unit Unit1 ;
Interface
Uses
Windows , Messages , SysUtils , Variants , 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}
Function PencereninBoyutunuDegistir ( PencereAdresi : Hwnd ; Yukseklik , Genislik : Integer ; EkraniOrtala : Boolean ): Boolean ;
Var
Pencere : TRect ;
Begin
Result := False ;
Try
GetWindowRect ( PencereAdresi , Pencere );
If EkraniOrtala Then MoveWindow ( PencereAdresi ,( Screen . Width - Genislik ) Div 2 ,( Screen . Height - Yukseklik ) Div 2 , Yukseklik , Genislik , True )
Else MoveWindow ( PencereAdresi , Pencere . Left , Pencere . Top , Yukseklik , Genislik , True );
Except
Result := False ;
End ;
Result := True ;
End ;
Procedure TForm1 . Button1Click ( Sender : TObject );
Var
NotDefteri : Hwnd ;
Begin
NotDefteri := FindWindow ( nil , 'Adsız - Not Defteri' );
PencereninBoyutunuDegistir ( NotDefteri , 250 , 175 , True );
End ;
End .
// Kolay gelsin.
// Hakan HAMURCU
// hakan@hamurcu.com
Delphi - .....................................
Herhangibir programın çalışır durumda olup olmadığını öğrenmek
//
// Şu anda sisteminizde hesap makinasının ve/veya not defterinin çalışır durumda olup olmadığını merak ediyorsanız
// işte size basit bir çözüm. Formunuza 2 adet buton koyun ve aşağıdaki kodları ekleyin.
// Buton1'e basıldığında Hesap Makinasının (calc.exe) o anda çalışıp çalışmadığını
// Buton2'ye basıldığında Not Defterinin (notepad.exe) o anda çalışıp çalışmadığını öğrenebilirsiniz.
// Tabi ki siz sorgulamak istediğiniz EXE dosyasının adını yazarak programı kendinize göre değiştirin.
//
Unit Calisiyormu ;
Interface
Uses
Windows , Messages , SysUtils , Variants , Classes , Graphics , Controls , Forms ,
Dialogs , StdCtrls , TlHelp32 ; // TlHelp32 ünitesini eklemeyi unutmayın
Type
TForm1 = Class ( TForm )
Button1 : TButton ;
Button2 : TButton ;
Procedure Button1Click ( Sender : TObject );
Procedure Button2Click ( Sender : TObject );
Private
{ Private declarations }
Public
{ Public declarations }
End ;
Var
Form1 : TForm1 ;
Implementation
{$R *.dfm}
Function Calisiyormu ( DosyaAdi : String ): Boolean ;
Var
DonguDevam : BOOL ;
FSnapshotHandle : THandle ;
FProcessEntry32 : TProcessEntry32 ;
Begin
FSnapshotHandle := CreateToolhelp32Snapshot ( TH32CS_SNAPPROCESS , 0 );
FProcessEntry32 . dwSize := SizeOf ( FProcessEntry32 );
DonguDevam := Process32First ( FSnapshotHandle , FProcessEntry32 );
Result := False ;
While Integer ( DonguDevam )<> 0 Do
Begin
If (( UpperCase ( ExtractFileName ( FProcessEntry32 . szExeFile ))= UpperCase ( DosyaAdi )) Or ( UpperCase ( FProcessEntry32 . szExeFile )= UpperCase ( DosyaAdi ))) Then Result := True ;
DonguDevam := Process32Next ( FSnapshotHandle , FProcessEntry32 );
End ;
CloseHandle ( FSnapshotHandle );
End ;
Procedure TForm1 . Button1Click ( Sender : TObject );
Begin
If Calisiyormu ( 'calc.exe' ) Then ShowMessage ( 'Evet Hesap makinası şu anda çalışıyor' )
Else ShowMessage ( 'Hayır Hesap makinası şu anda çalışmıyor' );
End ;
Procedure TForm1 . Button2Click ( Sender : TObject );
Begin
If Calisiyormu ( 'notepad.exe' ) Then ShowMessage ( 'Evet Not Defteri şu anda çalışıyor' )
Else ShowMessage ( 'Hayır Not Defteri şu anda çalışmıyor' );
End ;
End .
// Kolay gelsin.
//
// Hakan HAMURCU
//
// hakan@hamurcu.com
//
Delphi - .....................................
Tablo İçinde Seçili Alanların Toplamını Alma
//Alınan DBGrid nesnesini seçerek Özellikler kısmından Option/MultiSelect
//özelliğini True yapınız
procedure TForm1 . Button1Click ( Sender : TObject );
var
i : Integer ;
topla : Single ;
begin
if DBGrid1 . SelectedRows . Count > 0 then
begin
topla := 0 ;
with DBGrid1 . DataSource . DataSet do
begin
for i := 0 to DBGrid1 . SelectedRows . Count - 1 do
begin
GotoBookmark ( Pointer ( DBGrid . SelectedRows . Items [ i ]));
topla := topla + ADOTable1 . FieldByName ( 'sayi' ). AsFloat ;
end ;
end ;
Edit1 . Text := FloatToStr ( topla );
end ;
end ;
//Ctrl tuşu ile toplamını almak istediniz alanları seçebilirsiniz.
Delphi - .....................................
DbGrid Nesnesine CheckBox ekleme
procedure TForm1 . DBGrid1DrawColumnCell ( Sender : TObject ; const Rect : TRect ;
DataCol : Integer ; Column : TColumn ; State : TGridDrawState );
const
IsChecked : array [ Boolean ] of Integer = ( DFCS_BUTTONCHECK , DFCS_BUTTONCHECK or DFCS_CHECKED );
var
DrawState : Integer ;
DrawRect : TRect ;
begin
if ( gdFocused in State ) then
begin
if ( Column . Field . FieldName = DBCheckBox1 . DataField ) then
begin
DBCheckBox1 . Left := Rect . Left + DBGrid1 . Left + 2 ;
DBCheckBox1 . Top := Rect . Top + DBGrid1 . top + 2 ;
DBCheckBox1 . Width := Rect . Right - Rect . Left ;
DBCheckBox1 . Height := Rect . Bottom - Rect . Top ;
DBCheckBox1 . Visible := True ;
end ;
end
else
begin
if ( Column . Field . FieldName = DBCheckBox1 . DataField ) then
begin
DrawRect := Rect ;
InflateRect ( DrawRect ,- 1 ,- 1 );
DrawState := ISChecked [ Column . Field . AsBoolean ];
DBGrid1 . Canvas . FillRect ( Rect );
DrawFrameControl ( DBGrid1 . Canvas . Handle , DrawRect , DFC_BUTTON , DrawState );
end ;
end ;
end ;
procedure TForm1 . DBGrid1ColExit ( Sender : TObject );
begin
if DBGrid1 . SelectedField . FieldName = DBCheckBox1 . DataField then
DBCheckBox1 . Visible := False
end ;
procedure TForm1 . DBGrid1KeyPress ( Sender : TObject ; var Key : Char );
begin
if ( key = Chr ( 9 )) then Exit ;
if ( DBGrid1 . SelectedField . FieldName = DBCheckBox1 . DataField ) then
begin
DBCheckBox1 . SetFocus ;
SendMessage ( DBCheckBox1 . Handle , WM_Char , word ( Key ), 0 );
end ;
end ;
procedure TForm1 . DBCheckBox1Click ( Sender : TObject );
begin
if DBCheckBox1 . Checked then DBCheckBox1 . Caption := DBCheckBox1 . ValueChecked
else DBCheckBox1 . Caption := DBCheckBox1 . ValueUnChecked ;
end ;
Delphi - .....................................
String Parse
// byDOMUR+
//%100 Çalışan kod...
procedure ParseDelimited ( const sl : TStrings ; const value : string ; const delimiter : string ) ;
var
dx : integer ;
ns : string ;
txt : string ;
delta : integer ;
begin
delta := Length ( delimiter ) ;
txt := value + delimiter ;
sl . BeginUpdate ;
sl . Clear ;
try
while Length ( txt ) > 0 do
begin
dx := Pos ( delimiter , txt ) ;
ns := Copy ( txt , 0 , dx - 1 ) ;
sl . Add ( ns ) ;
txt := Copy ( txt , dx + delta , MaxInt ) ;
end ;
finally
sl . EndUpdate ;
end ;
end ;
Delphi - .....................................
Explorer'ı istenen izinle açma shellapi'siz
Selam arkadaş lar
A ş a ğı daki kod ile gezgini istedi ğ imiz dizine a ç abiliriz . Fakat
Shellapi unitini kullanmam ı z gereklidir . Bu da program ı n boyutunu b ü y ü t ü r .
En alttaki kod ile ise buna gerek kalmadan ayn ı islemi yapabiliyoruz .
*******************************************************
//Windows Gezginini istediğiniz bir klasörle açma
uses k ı sm ı na ShellApi unitini ekleyin .
procedure TForm1 . Button1Click ( Sender : TObject );
begin
ShellExecute ( 0 , 'explore' , 'C:WINDOWS' , //buraya açmak istediğiniz klasörü yazın.
nil , nil , SW_SHOWNORMAL );
end ;
*******************************************************
procedure TForm1 . Button1Click ( Sender : TObject );
var pyol : string ;
begin
pyol := 'C:WINDOWS' ; //buraya açmak istediğiniz klasörü yazın.
WinExec ( Pchar ( 'Explorer.exe ' + pyol ), SW_SHOW );
end ;
Delphi - .....................................
Blue Game Box v.1.01
Blue Game Box v. 1.01
Delphi 7.0 ve MySQL İ le Yaz ı lm ış G ü zel Bir Oyun Makinesi
Link : www . bluegamebox . com
Delphi - .....................................
GetLocalFormatSettings düzeltme
NOT : A ş a ğı daki ö rnekteki DecimalSeperator kelimesi yanl ış t ı r .
Do ğ rusu DecimalSeparator olmal ı d ı r .
Delphi - .....................................
GetLocaleFormatSettings
Selam arkadaş lar ,
GetLocaleFormatsettings komutunu kullanarak standart sistem ( say ı, yaz ı, tarih vb )
formatlama ayarlar ı okunabilir . Bulunun i ç in ilk parametresi 0 verilmelidir . E ğ er
belli diller i ç in okunmak isteniyorsa ilk parametre o dil i ç in belirlenmi ş integer
tipindeki say ı verilmelidir .
Ö rne ğ in
1033 Amerikan
1055 T ü rk ç e
Di ğ er diller i ç in gerekli say ı lar ı internette " List of Locale ID " veya " LCID "
ş eklinde arama ile bulmak m ü mk ü nd ü r .
A ş a ğı da Floattostr ve GetLocaleFormatSettings komutlar ı n ı n kullan ı m ı na
ö rnek bulunmaktad ı r :
Var s : string ; fs : TFormatSettings ;
Begin
GetLocaleFormatSettings ( 0 , fs ); // Sistem formatlama ayarı okunuyor
s := Floattostr ( 123.456 , fs ); // Sonuc = 123,456 (Sistemi Türkçe format ayarlı bilgisayarda)
GetLocaleFormatSettings ( 1033 , fs ); // Amerikan sistem formatlama ayarı okunuyor (1033)
s := Floattostr ( 123.456 , fs ); // Sonuc = 123.456 (Amerikan format ayarı)
GetLocaleFormatSettings ( 1055 , fs ); // Türkçe sistem formatlama ayarı okunuyor (1055)
s := Floattostr ( 123.456 , fs ); // Sonuc = 123,456 (Türkçe format ayarı)
fs . DecimalSeperator := '#' ;
s := Floattostr ( 123.456 , fs ) ; // Sonuc = 123#456 (Kullanıcının değiştirdiği ayar)
Delphi - .....................................
Advantage bazı sql komutları
Virtual Table Support
One of the new system tables is the IOTA table . The IOTA table contains a single row with one
logical field whose value is NULL . The main purpose of the IOTA table is to provide an efficient
method for evaluating an SQL expression on the server . Examples of using the IOTA table include :
To get the current date and time ( timestamp ) from the server :
SELECT NOW () FROM System . IOTA
Get the currently logged in user :
SELECT USER () FROM System . IOTA
Get a random number from the server :
SELECT RAND FROM System . IOTA
Aggregate Functions
Aggregate functions are used to run calculations on a set of records . These functions generally use
a GROUP BY clause to organize the data to be aggregated into appropriate groups . Advantage supports
the following aggregate functions; AVG , COUNT , MAX , MIN , SUM .
The following example shows the total number of orders and total sales by customer .
SELECT CustID , COUNT ( OrderID ) as " Orders ", SUM ( SubTotal ) as " Total Sales ", AVG ( SubTotal ) as
" Average Sale " FROM Invoice GROUP BY 1
Mathematical Functions
Many standard mathematical functions are available in the Advantage Query Engine
including conversion functions such as DEGREES and RADIANS which convert the
given values . Many trigonometric functions such as SIN , COS , TAN and PI are
also available.
The RAND function generates a random floating point value between 0 and 1 each
time it is called . It can be initialized by passing in an integer value .
It should only be initialized once per connection . It will use the system
time as a seed value by default so there is generally no need to initialize
the function . The following SQL statement will return 10 random customers
from the customer table.
SELECT TOP 10 ( RAND () * 1000 ) AS SortOrder , CustID , FirstName , LastName
FROM Customer ORDER BY 1 ;
Date / Time Functions
Most applications have the need to store date and time information .
This data is often used as conditions for reports and other business logic .
For example , the date an invoice is paid is usually a critical item .
The amount of time that has passed since an order was entered and shipped
is a good measure of customer service . There are many date / time functions
that assist with the manipulation of date / time values .
The DAY , HOUR , MINUTE , MONTH , SECOND , QUARTER , WEEK and YEAR functions extract
a portion of the date , time or timestamp value . This information can be used
very effectively in report generation . Allowing the sorting of the information
by any one of these factors . The example SQL statement below shows a summary
of sales by day for 2006.
SELECT SUM ( SubTotal ) as " Total Sales ", DAYNAME ( OrderDate ) as " Day " FROM Invoice
WHERE YEAR( OrderDate ) = 2006 GROUP BY 2 ORDER BY 1 DESC
Manipulating date and time fields is relatively simple . Dates and times are
stored as numbers within the database ; therefore , simple math can be used to
manipulate the value . However , if you need to add a specific value , 1 min 30
seconds for example , you can use the TIMESTAMPADD function . This function allows
for adding the exact amount of time you wish . The interval can be in seconds ,
minutes , hours , days , weeks , months , quarters or years .
Determining how much time has passed between two dates is another important
operation . This can be accomplished using the TIMESTAMPDIFF function .
Like the TIMESTAMPADD function this function can determine the difference
between two date , time or timestamp fields based on the same intervals mentioned
above. The following SQL statement shows the average and maximum days between
an order and the payment .
SELECT CustID , COUNT ( OrderID ) as " Orders ", AVG ( TIMESTAMPDIFF ( SQL_TSI_DAY ,
OrderDate , PayDate )) as " Average Days ", MAX ( TIMESTAMPDIFF ( SQL_TSI_DAY , OrderDate ,
PayDate )) as " Max Days " FROM Invoice GROUP BY 1
Miscellaneous Functions
Several other functions are available which do not fit into the categories
listed above. The first set of these are administrative type functions .
These include ; APPLICATIONID , DATABASE , LASTAUTOINC , NEWIDSTRING and USER .
The LASTAUTOINC function returns the last value assigned to an autoinc field .
This is very useful when you must programmatically determine the value after
an INSERT statement. The NEWIDSTRING returns a Globally Unique Identifier
( GUID ) in various formats . The example statement below will display all of
the supported display formats . The screenshot shows two of the most commonly
used GUID formats.
SELECT NEWIDSTRING (" M ") as " MIME ", NEWIDSTRING (" F ") as " File ", NEWIDSTRING (" N ")
as " Numbers ", NEWIDSTRING (" D ") as " Delimited ", NEWIDSTRING (" B ") as " Bracketed ",
NEWIDSTRING (" P ") as " Parenthesis " FROM system . iota
A variety of information can be obtained about the current connection using the
other administrative functions. The following example SQL statement shows the
current user, database and currently connected application . This functionality
is very useful when creating an audit trail .
SELECT USER () as " User Name ", DATABASE () as " Database ", APPLICATIONID () as
" Application " FROM system . iota
http : //devzone.advantagedatabase.com/dz/content.aspx?Key=42&ID=49
Delphi - .....................................
Kullanıcı şifresini değiştirmek
//
// Windows kullanıcı şifrenizi değiştirmek için aşağıdaki fonksiyonu kullanabilirsiniz.
// Örnek olması açısından forma 1 adet Button koyun ve Click olayına aşağıdaki komutu girin.
//
unit Unit1 ;
interface
uses
Windows , Messages , SysUtils , Variants , Classes , Graphics , Controls , Forms ,
Dialogs ;
type
TForm1 = class ( TForm )
Button1 : TButton ;
procedure Button1Click ( Sender : TObject );
private
{ Private declarations }
public
{ Public declarations }
end ;
var
Form1 : TForm1 ;
function NetUserChangePassword ( Domain : PWideChar ; UserName : PWideChar ; OldPassword : PWideChar ;
NewPassword : PWideChar ): Longint ; stdcall ; external 'netapi32.dll' Name 'NetUserChangePassword' ;
implementation
{$R *.dfm}
procedure TForm1 . Button1Click ( Sender : TObject );
begin
NetUserChangePassword ( PWideChar ( WideString ( 'HAMURCU' )), // Bilgisayar adınız
PWideChar ( WideString ( 'Hakan' )), // Kullanıcı adınız
PWideChar ( WideString ( '1234' )), // Mevcut/eski şifreniz
PWideChar ( WideString ( '5678' ))); // Yeni şifreniz
end ;
end .
//
// Kolay gelsin.
//
// Hakan HAMURCU
// hakan@hamurcu.com
//
Delphi - .....................................
Şu anda sistemde ADMIN miyiz?
// Şu anda sistemde ADMIN olup olmadığınızı öğrenmek istiyorsanız aşağıdaki kodu kullanabilirsiniz.
// Formunuza 1 adet Button bırakın ve Click olayını aşağıdaki gibi oluşturun
// Butona bastığınızda şu anda admin olup olmadığınızı öğrenebilirsiniz.
unit unit1 ;
interface
uses
Windows , Messages , SysUtils , Variants , 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 ;
const
SECURITY_NT_AUTHORITY : TSIDIdentifierAuthority = ( Value : ( 0 , 0 , 0 , 0 , 0 , 5 ));
SECURITY_BUILTIN_DOMAIN_RID = $00000020 ;
DOMAIN_ALIAS_RID_ADMINS = $00000220 ;
implementation
{$R *.dfm}
function IsAdmin : Boolean ;
var
hAccessToken : THandle ;
ptgGroups : PTokenGroups ;
dwInfoBufferSize : DWORD ;
psidAdministrators : PSID ;
x : Integer ;
bSuccess : BOOL ;
begin
Result := False ;
bSuccess := OpenThreadToken ( GetCurrentThread , TOKEN_QUERY , True , hAccessToken );
if not bSuccess then
begin
if GetLastError = ERROR_NO_TOKEN then bSuccess := OpenProcessToken ( GetCurrentProcess , TOKEN_QUERY , hAccessToken );
end ;
if bSuccess then
begin
GetMem ( ptgGroups , 1024 );
bSuccess := GetTokenInformation ( hAccessToken , TokenGroups , ptgGroups , 1024 , dwInfoBufferSize );
CloseHandle ( hAccessToken );
if bSuccess then
begin
AllocateAndInitializeSid ( SECURITY_NT_AUTHORITY , 2 , SECURITY_BUILTIN_DOMAIN_RID , DOMAIN_ALIAS_RID_ADMINS , 0 , 0 , 0 , 0 , 0 , 0 , psidAdministrators );
{$R-}
for x := 0 to ptgGroups . GroupCount - 1 do
Begin
if EqualSid ( psidAdministrators , ptgGroups . Groups [ x ]. Sid ) then
begin
Result := True ;
Break ;
end ;
End ;
{$R+}
FreeSid ( psidAdministrators );
End ;
FreeMem ( ptgGroups );
end ;
End ;
procedure TForm1 . Button1Click ( Sender : TObject );
begin
If IsAdmin Then ShowMessage ( 'Evet Adminsiniz' )
Else ShowMessage ( 'Hayır Admin değilsiniz' );
end ;
end .
//
// Kolay gelin.
//
// Hakan HAMURCU
// hakan@hamurcu.com
//
Delphi - .....................................
Çalışan uygulama ve/veya Processler hangi kullanıcıya ait?
// Sistemde aktif olarak çalışmakta olan uygulamalar ve processleri hangi kullanıcılar ve hangi domainler altından çalıştırmışlar?
// öğrenmek istiyorsanız aşağıdaki kodları kullanabilirsiniz. Bunun için formunuza 1 adet Button ve 1 adet ListBox yerleştirin
// sonrasında Button'un Click özelliğine aşağıdaki kodları girin.
unit Unit1 ;
interface
uses
Windows , Messages , SysUtils , Variants , Classes , Graphics , Controls , Forms ,
Dialogs , StdCtrls , TlHelp32 ;
type
TForm1 = class ( TForm )
Button1 : TButton ;
ListBox1 : TListBox ;
procedure Button1Click ( Sender : TObject );
private
{ Private declarations }
public
{ Public declarations }
end ;
Type
PTOKEN_USER = ^ TOKEN_USER ;
RTOKEN_USER = record
User : TSidAndAttributes ;
end ;
TOKEN_USER = RTOKEN_USER ;
var
Form1 : TForm1 ;
implementation
{$R *.dfm}
function GetUserAndDomainFromPID ( ProcessId : DWORD ; var User , Domain : string ): Boolean ;
var
hToken : THandle ;
cbBuf : Cardinal ;
ptiUser : PTOKEN_USER ;
snu : SID_NAME_USE ;
ProcessHandle : THandle ;
UserSize : DWORD ;
DomainSize : DWORD ;
bSuccess : Boolean ;
begin
Result := False ;
ProcessHandle := OpenProcess ( PROCESS_QUERY_INFORMATION , False , ProcessId );
if ProcessHandle <> 0 then
begin
if OpenProcessToken ( ProcessHandle , TOKEN_QUERY , hToken ) then
begin
bSuccess := GetTokenInformation ( hToken , TokenUser , nil , 0 , cbBuf );
ptiUser := nil ;
while ( not bSuccess ) and ( GetLastError = ERROR_INSUFFICIENT_BUFFER ) do
begin
ReallocMem ( ptiUser , cbBuf );
bSuccess := GetTokenInformation ( hToken , TokenUser , ptiUser , cbBuf , cbBuf );
end ;
CloseHandle ( hToken );
if not bSuccess then Exit ;
UserSize := 0 ;
DomainSize := 0 ;
LookupAccountSid ( nil , ptiUser . User . Sid , nil , UserSize , nil , DomainSize , snu );
if ( UserSize <> 0 ) and ( DomainSize <> 0 ) then
begin
SetLength ( User , UserSize );
SetLength ( Domain , DomainSize );
if LookupAccountSid ( nil , ptiUser . User . Sid , PChar ( User ), UserSize , PChar ( Domain ), DomainSize , snu ) then
begin
Result := True ;
User := StrPas ( PChar ( User ));
Domain := StrPas ( PChar ( Domain ));
end ;
end ;
if bSuccess then FreeMem ( ptiUser );
end ;
CloseHandle ( ProcessHandle );
end ;
end ;
procedure TForm1 . Button1Click ( Sender : TObject );
var
hProcSnap : THandle ;
pe32 : TProcessEntry32 ;
Domain : string ;
User : string ;
s : string ;
begin
hProcSnap := CreateToolHelp32SnapShot ( TH32CS_SNAPALL , 0 );
if hProcSnap = INVALID_HANDLE_VALUE then Exit ;
pe32 . dwSize := SizeOf ( ProcessEntry32 );
if Process32First ( hProcSnap , pe32 ) = True then
begin
while Process32Next ( hProcSnap , pe32 ) = True do
begin
if GetUserAndDomainFromPID ( pe32 . th32ProcessID , User , Domain ) then
begin
s := Format ( 'Process : %s --> User: %s --> Domain: %s' ,[ StrPas ( pe32 . szExeFile ), User , Domain ]);
Listbox1 . Items . Add ( s );
end else Listbox1 . Items . Add ( StrPas ( pe32 . szExeFile ));
end ;
end ;
CloseHandle ( hProcSnap );
end ;
end .
//
// Kolay gelsin
//
// Hakan HAMURCU
// hakan@hamurcu.com
//
Delphi - .....................................
kablosuz kameraya baglanan kod acil lütfeeeeeeeeeeeen
kablosuz kameraya baglanan kodu istiyourum var m ı biilen ö devi yapamassam d ö nem uzat ı oyurum
Delphi - .....................................
re:arkadaslar.acil yardım yoksa dönem uztıcam lütfen
ş imdi benim tam olarak istedigim kod su hocam kablosuz kameran ı n cal ı smas ı n ı delphi kodu yazarak yapmam ı istiyour nas ı l yapabilirim bilen varsa rica ediyourum yoksa d ö nem uzat ı yourum yoruldum .............:(
Delphi - .....................................
fast report dil seçimi
uses frxRes ;
....
frxResources . LoadFromFile ( 'Turkish.frc' );
frxReport1 . ShowReport ();
Delphi - .....................................
Tablo Kopyalama verileri ile birlikte
procedure TForm1 . KopyaTblBtnClick ( Sender : TObject );
var
p : CURProps ;
XStr : string ;
begin
Table2 . Close ;
XStr := 'KopyaTable.db' ; // hazır verilerin kopyalanacağı veri taban adı
Check ( DbiGetCursorProps ( Table1 . Handle , p ));
Check ( DbiCopyTable ( Table1 . DBHandle , True , PChar ( Table1 . TableName ), p . szTableType ,
PChar ( XStr )));
Table2 . Open ;
end ;
fuatkilinc41 @ hotmail . com // balıkesir gönen
Altuni ş Bilgisayar ve yaz ı l ı m
Delphi - .....................................
Case de String Kullanimi
Link : http : //delphi.about.com/cs/adptips2002/a/bltip0202_5.htm
function StringToCaseSelect
( Selector : string ;
CaseList : array of string ): Integer ;
var cnt : integer ;
begin
Result :=- 1 ;
for cnt := 0 to Length ( CaseList )- 1 do
begin
if CompareText ( Selector , CaseList [ cnt ]) = 0 then
begin
Result := cnt ;
Break ;
end ;
end ;
end ;
//Usage:
case StringToCaseSelect ( 'Delphi' ,
['About' , 'Borland' , 'Delphi' ]) of
0 : ShowMessage ( 'You''ve picked About' ) ;
1 : ShowMessage ( 'You''ve picked Borland' ) ;
2 : ShowMessage ( 'You''ve picked Delphi' ) ;
end ;
2. yontem
Link : http : //www.delphi3000.com/articles/article_2810.asp?SK=
How can you use case .. of on a string ? Normally you cannot because it only allows ordinal types ( numeric - char is numeric Ord () ).
I recently figured ( though it isn 't a new idea) to create some sort of numeric representation of the string.
My favoured way is CRC - 32 , though you could use any method AS LONG AS the turned number is unique .
I won 't include the CRC-32 details here, just the ideology/theory.
Example :
procedure CompareStrings ( S : String );
begin
case Crc32OfString ( S ) of
Crc32OfString ( 'Hello' ): // Do wotever...
Crc32OfString ( 'Goodbye' ): // Do wotever...
end ;
end ;
See it 's as simple as that!
It isn 't very efficent calling it like that, to optimize it you can HARD CODE the case..of values to speed up the process.
I orignally said mail me for the CRC - 32 routine but because I 've had a few people e-mail me showing interest you can download by whole CRC unit from:
http : //www.workshell.co.uk/dev/delphi/crc.pas
As well as CRC - 32 , it offers similar routines for CRC - 16 , Adler32 , Kermit16 and other hash routines .
I hope its useful to you ...
Enjoy !
Delphi - .....................................
checkbox da secilen değer nasıl database e gönderilir (yardımmmmm)
checkbox da secilen değ er nas ı l database e g ö nderilir yard ı m edebilecek olan varm ı
Delphi - .....................................
Find file Dosya Arama (FARKLI)
/// buda farklı bir dosya arama şekli
///component değildir , söz dizimidir
/// harika bir şekilde belirttiğiniz bir dizinde istediğiniz kriterdeki dosyaları
///tarayıp listboxa atıtıyor,,, Denemiştir...
procedure GetAllFilesEM ( Path , ExtMask : String ; List : TStrings ;
SubFolder : Boolean );
var
Attrib , k : Integer ;
Search : TSearchRec ;
begin
Attrib := faArchive + faReadOnly + faHidden ;
if Path [ Length ( Path )] <> '' then Path := Path + '' ;
with TStringList . Create do
try
CommaText := ExtMask ;
for k := 0 to Count - 1 do
if FindFirst ( Path + '*.' + Strings [ k ], Attrib , Search ) = 0 then
repeat
List . Add ( AnsiUpperCase ( Path + Search . Name ));
until FindNext ( Search ) <> 0 ;
FindClose ( Search );
finally Free end ;
if SubFolder then
begin
if FindFirst ( Path + '*.*' , faDirectory , Search ) = 0 then
begin
repeat
if (( Search . Attr and faDirectory ) = faDirectory ) and
( Search . Name [ 1 ] <> '.' ) then
GetAllFilesEM ( Path + Search . Name , ExtMask , List , SubFolder );
until FindNext ( Search ) <> 0 ;
FindClose ( Search );
end ;
end ;
end ; {Popov}
////////////// kullanımı mesela yani
procedure TForm1 . Button1Click ( Sender : TObject );
begin
GetAllFilesEM ( 'c:windowssystem32' , 'bmp, gif, jpg, ico' , ListBox1 . Items , True ); // mesela
end ;
procedure TForm1 . Button2Click ( Sender : TObject );
begin
GetAllFilesEM ( 'c:' , '*.*' , ListBox1 . Items , True ); // mesela Muzaffer
end ;
end .
Delphi - .....................................
Programdan Disket Formatlamak
unit Unit1 ;
interface
uses
Windows , Messages , SysUtils , Variants , 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 ;
const
SHFMT_OPT_FULL = $0001 ;
SHFMT_ERROR = $FFFFFFFF ;
SHFMT_CANCEL = $FFFFFFFE ;
SHFMT_ID_DEFAULT = $FFFF ;
SHFMT_OPT_QUICKFORMAT = $0000 ;
SHFMT_OPT_SYSONLY = $0002 ;
implementation
{$R *.dfm}
function SHFormatDrive ( hWnd : HWND ; Drive , fmtID , Options : Word ) :
Longint ; stdcall ;
external 'Shell32.dll' name 'SHFormatDrive'
function FormatDrive ( Drive : Char ): Integer ;
var DriveNo : Word ;
begin
if Drive in [ 'a' .. 'z' ] then Dec ( Drive , $20 );
DriveNo := Ord ( Drive ) - $41 ;
try
Result := ShFormatDrive ( Application . Handle , DriveNo ,
SHFMT_ID_DEFAULT ,
SHFMT_OPT_FULL );
except
Result := - 1 ;
end ;
end ;
procedure TForm1 . Button1Click ( Sender : TObject );
var Result : Integer ;
begin
Result := FormatDrive ( 'A' );
if Result < 0 then
ShowMessage ( 'Formatlama islemi basarisiz' )
else
ShowMessage ( 'Formatlama islemi basarili' );
end ;
end .
Delphi - .....................................
İki Tarih Arası Sorgulama AdoQuery
adoquery1. close ;
adoquery1 . sql . clear ;
adoquery1 . sql . add ( 'select CekNo,islemtarihi, TakasBankasi,Takassubesi,CekBanka, CekSube,Aciklama, Vade, Tutar from _TakasCekleri where Vade BETWEEN :tarih1 and :tarih2 order by Vade' );
AdoQuery1 . Parameters . Parambyname ( 'tarih1' ). DataType := ftDate ;
AdoQuery1 . Parameters . Parambyname ( 'tarih1' ). Value := datetimepicker1 . date ;
AdoQuery1 . Parameters . Parambyname ( 'tarih2' ). DataType := ftDate ;
AdoQuery1 . Parameters . Parambyname ( 'tarih2' ). Value := datetimepicker2 . date ;
adoquery1 . Open ;
Delphi - .....................................
dll form in pagecontrol
The DLL:
library Project1 ;
uses
SysUtils ,
Classes , Forms ,
Unit1 in 'Unit1.pas' {Form1} ;
{$R *.res}
function GetFormClass : TFormClass ;
begin
Result := TForm1 ;
end ;
exports GetFormClass ;
begin
end .
unit Unit1 ;
interface
uses
Windows , Messages , SysUtils , Variants , Classes , Graphics , Controls , Forms ,
Dialogs , StdCtrls , ExtCtrls , Buttons , ComCtrls ;
type
TForm1 = class ( TForm )
Button1 : TButton ;
Memo1 : TMemo ;
procedure Button1Click ( Sender : TObject );
private
{ Private declarations }
public
{ Public declarations }
end ;
var
Form1 : TForm1 ;
implementation
{$R *.dfm}
procedure TForm1 . Button1Click ( Sender : TObject );
begin
memo1 . Lines . Add ( 'testing' );
end ;
end .
The Main Application :
unit Unit2 ;
interface
uses
Windows , Messages , SysUtils , Variants , Classes , Graphics , Controls , Forms ,
Dialogs , ComCtrls , StdCtrls ;
type
TFormMain = class ( TForm )
PageControl1 : TPageControl ;
TabSheet1 : TTabSheet ;
procedure FormCreate ( Sender : TObject );
private
DLLForm : TForm ;
{ Private declarations }
public
{ Public declarations }
end ;
var
FormMain : TFormMain ;
implementation
{$R *.dfm}
type
TGetFormClass = function : TFormClass ;
const
GetFormClassName = 'GetFormClass' ;
procedure TFormMain . FormCreate ( Sender : TObject );
var
DLL : THandle ;
DLLFormClass : TFormClass ;
GetClass : TGetFormClass ;
TabSheet : TTabSheet ;
begin
DLL := LoadLibrary ( 'Project1.DLL' );
if DLL > HINSTANCE_ERROR then
begin
GetClass := GetProcAddress ( DLL , GetFormClassName );
if assigned ( GetClass ) then
begin
DLLFormClass := GetClass ;
TabSheet := TTabSheet . Create ( PageControl1 );
TabSheet . PageControl := PageControl1 ;
DLLForm := DLLFormClass . Create ( Application );
DLLForm . Parent := TabSheet ;
DLLForm . Top := 0 ;
DLLForm . Left := 0 ;
DLLForm . Show ;
end ;
end ;
end ;
end .
Delphi - .....................................
