neoturk: Forum - "Tlistview hakkinda bir soru.."
Arkadaslar , yapmakta oldugum program icin TListView ile bu goruntuyu
elde etmem gerekiyor . Yalniz sekildekinin aksine disket surucu ve cdrom
gibi cikarilabilir suruculerin goruntulenmemesini istiyorum .
Kapasite ve bos kapasite icin diskfree , disksize komutlarindan baska
hangi komutlar kullanilabilir ?
Yardimlariniz icin tesekkurler .
Not : Yardim edecek arkadaslar mumkunse hem diskfree hem de diger olasi komutlari soyleyebilirler mi ?
bloodfloweur
"
listview nesnesinde imageleri kullanmak istiyor isen ,
bir adet image list ekle ve forma yerle ş tir .
imageindex de ğ erlerini d ö ng ü ile listview nesnesine kodlama ile
aktaracaks ı n . ş u anda buna ili ş kin bir kod g ö nderemiyorum .
( cd ar ş ivime bakmam laz ı m )
eski program ı mda kulland ığı m disk kapasiteleri ve bo ş yer miktarlar ı na
ili ş kin kod ö rnekleri a ş a ğı dad ı r . kendine g ö re d ü zenleyeceksin .
( pc info adl ı program ı mda a ş a ğı daki kodlar ı m ı kulland ı m ,
genel de ğ i ş kenlerle ba ğ lant ı l ı oldu ğ u i ç in sadece function kodlar ı n ı belirttim .
kulland ığı m kodlama ve mant ığ a bakarak kendine g ö re d ü zenleyebilirsin )
//written by neoturk 2005
{*************** drivers info **********************}
function get_driversinfo ( sender : Tobject ): string ;
const mb = 1024 * 1024 ;
var
n : integer ; x : string ;
tx : tstringlist ;
dfree , used , total : string ;
begin
tx := tstringlist . Create ;
for n := 3 to 10 do
begin
if directoryexists ( chr ( 64 + n )+ ':' ) then //c:
begin
x := 'Drive ' + chr ( 64 + n )+ ': ' ;
total := 'Total: ' + formatfloat ( '#,' , trunc ( disksize ( n )/ mb ))+ ' MB' ;
dfree := 'Free : ' + formatfloat ( '#,' , trunc ( diskfree ( n )/ mb ))+ ' MB' ;
used := 'Used : ' + formatfloat ( '#,' , trunc ( disksize ( n )/ mb )- trunc ( diskfree ( n )/ mb ))+ ' MB' ;
tx . Add ( x );
tx . Add ( total );
tx . Add ( dfree );
tx . Add ( used );
end ;
end ;
//final
result := tx . Text ;
end ;
{*************** drivers info **********************}
function get_driversinfo ( sender : Tobject ): string ;
const mb = 1024 * 1024 ;
var
n : integer ; x : string ;
tx : tstringlist ;
dfree , used , total : string ;
begin
tx := tstringlist . Create ;
for n := 3 to 10 do
begin
if directoryexists ( chr ( 64 + n )+ ':' ) then //c:
begin
x := 'Drive ' + chr ( 64 + n )+ ': ' ;
total := 'Total: ' + formatfloat ( '#,' , trunc ( disksize ( n )/ mb ))+ ' MB' ;
dfree := 'Free : ' + formatfloat ( '#,' , trunc ( diskfree ( n )/ mb ))+ ' MB' ;
used := 'Used : ' + formatfloat ( '#,' , trunc ( disksize ( n )/ mb )- trunc ( diskfree ( n )/ mb ))+ ' MB' ;
tx . Add ( x );
tx . Add ( total );
tx . Add ( dfree );
tx . Add ( used );
end ;
end ;
//final
result := tx . Text ;
end ;
a ş a ğı da listview ö rneklerini g ö receksin .
ESK İ YAZIMDAN ALINTIDIR :
"
size birka ç sorum olacakt ı
ben bi remote admin tool yap ı yorum . Bayaa bi ilerledim .
Pano okuyup , yazma , klitleme ...
pc biligisi alma ...
dosya arama ...
program ç al ış t ı rma ...
chat ...
uygulama g ö sterme kapatma
pencere g ö sterme maximize , minimize ...
d ö k ü man yazd ı rma ...
gibi bir ç ok i ş lem yapt ı rabiliyorum ama tak ı ld ığı m birka ç nokta var .
1 _ ) Dosya y ö neticisi yapamad ı m . yani 1 listview var ve 2 columnu
var . Dosya , kalas ö r ad ı ve boyutu die .
windows dosya ve klas ö rleri nas ı l bu listviewda g ö saterilir ve serverdan
clientte yollan ı r .Çü nk ü server client aras ı string i ş lem g ö r ü rken tlistview
nas ı l g ö nderilmeli
2 Ayn ı ş ekilde Registry edit ö rde tak ı l ı yorum . 1 combobox ( drivelar
i ç in ), 1 listbox ( anahtarlar i ç in ), 1 listview yine 2 columnlu ( 1.column
ad , 2.column veri ). Yine fonksiyonel olmas ı n ı istiyorum . Serverdan cliennte
gelmeli yine .
3 Nt Servisler ü zerine yine 1 listview kullanmal ı y ı m . msconfig teki nt
servisleri gibi bi ş i olmal ı.
4 Dosya g ö nderimi ile ilgili yaz ı n ı z ı okudum . ve uygulad ı m her ş ey okey fakat
app kapat ı lmadan dosya kullan ı lam ı yor .
Bu konularda yard ı mc ı olursan ı z sevinirim . iyi g ü nler
"
cevap :
----------------
merhaba , bu konu hakk ı nda bana birka ç mail geldi , burada bilgim dahilinde
yan ı t vermeye ç al ış aca ğı m ,
u ğ ra ş alan ı m socket programlama oldu ğ u i ç in epeyce bi ş eyler yazabilirim ,
ama vaktim ne kadar m ü said olursa o kadar yazabilirim , bir de ayn ı ş eyleri
tekrarlamaktan ka çı naca ğı m .
cevap1 - 2 - 3 :
KURAL : Her t ü rl ü dosya transferini bir ş ekilde functionel hale getirmelisin ,
ö rne ğ in ben şö yle kullan ı yorum ,
procedure Tform1 . sendfiletoserver ( sender : Tobject ; terminalno : integer ; sourcefile , targetfolder : string );
i ç eri ğ ini kendime g ö re yazd ığı m i ç in buraya paste etmedim ,
kullan ı m mant ığı ş u ş ekilde yap ı yorum ,
sendfiletoserver ( sender , 1 , 'c:deneme.txt' , 'c:windowstest.txt' );
ş eklinde kulland ığı m zaman dosya g ö nderme i ş lemini yap ı yor .
ö nce sa ğ l ı kl ı olarak dosya g ö nderme olay ı n ı yapabilmelisin .
bu k ı sm ı a ş t ı ktan sonra ,
".. uygulad ı m her ş ey okey fakat app kapat ı lmadan dosya kullan ı lam ı yor " diye
sormu ş sun ,
nedeni ş u , ben o ö rne ğ i kabaca anlatt ığı m i ç in a çı k olan dosyay ı fileclose
yapt ı rmad ı m . bunu kendin koda manuel olarak s ö yletebilirsin .
yani dosya g ö nderme i ş lemi tamamland ı ktan sonra server taraf ı da client taraf ı da
fileclose ( dosyahandlesi ) ile dosyay ı kapats ı n . sorun olmayacakt ı r .
bu k ı sm ı da a ş t ı ktan sonra , ( dosya transfer olay ı OK kabul ),
her t ü rl ü dosyay ı kar şı ya g ö nderebilir ve alabilirsin . bunu multy ş ekilde de
yapt ı rabilirsin hatta . ben epeyce abart ı denemeler filan da yapt ı yd ı m .
kulland ığı m ve test etti ğ im deneyimlerim ş u ş ekilde olmu ş tu :
1 ) bire bir dosya g ö nderiyordum
2 ) dosyay ı N adet par ç aya b ö ld ü r ü p o kadar port ü zerinden ayn ı anda send ediyordum
3 ) dosyay ı zipleyip g ö nderiyordum upload tamamland ı ktan sonra server bunu unzip yap ı yordu
4 ) dosyay ı N adet par ç alara b ö l ü p hepsini ayr ı ayr ı zipleyip ayn ı e ş zamanl ı N adet porttan
( o anda create edilmi ş socketler ) g ö nderip server side k ı sm ı nda hepsini unzip yap ı p merge
yapt ı r ı yordum .
5 ) ayn ı anda multy bu i ş lemleri N adet dosya i ç in yapt ı r ı yordum . h ı z son derece iyiydi .
( normal dosya transferine g ö re )
bunlar ı pratikte denemen senin yarar ı na olacakt ı r diye d üşü n ü yorum arkada şı m ,
epeyce socket programming konusuna ı s ı nm ış olursun .
gelelim listview olaylar ı na ,
ö ncelikle , static listview tan ı mlamalar ı ndan ka çı nmal ı s ı n ,
yani şö yle ,
2 kolonlu static olarak sabit ç ivi gibi listviewlerini tutma formda .
b ı rak i ç i bo ş kals ı n . kolonlar ı n ı dinamik olarak kendisi d ü zenlesin ,
ben ş u ş ekilde kullan ı yorum , diyelimki elimde bir . txt dosyas ı var ve i ç eri ğ i ,
name ; size ; attirbute ; datetime
test . txt ; 1234 ; ah ; 01.08.2005
test2 . txt ; 2356 ; ahrs ; 01.08.2005
.....
ş eklinde bir text dosyas ı olsun .
( bu t ü r text dosyalar ı n ı genellikle findfiles procedurleriyle dosyaya
yazd ı r ı rken kendin dinamik olu ş turuyorsundur zaten ! olu ş turmuyorum deme )
daha sonra bu dosyan ı n ilk 1. sat ı r ı n ı listviewin kolonlar ı na atama yapacaks ı n
b ö ylece otomatik kolon isimleri dosyadan al ı nm ış olacak . ne kadar şı k dimi !
ben b ö yle kullan ı yorum . 2.sat ı r ve dosyan ı n sonuna kadar hemen okutup listview nesnesine
aktar ı yorum . ( not : 1000 den fazla kay ı tlar i ç in listview nesnesi bira ş i ş er )
dolay ı s ı yla , ö nce listviewi her zaman s ı f ı rlaman gerekiyor ,
kodu da ş u ş ekilde kullanabilirsin ,
//listview2 kolonlarını sil
listview2 . Clear ;
while ( listview2 . Columns . Count > 0 ) do listview2 . Column [ 0 ]. Destroy ;
//dosyalistesi tstring nesnesinden elemanları yerleştir
xcaption := dosyalistesi . strings [ 0 ]; //1.SATIRı aldım
xcaptionx . text := getlines ( xcaption , ';' ); //1.SATIRI ; lerle ayırdım Tstringliste aktardım ( xcaptionx dedim)
//kolonların titlelerini otomatik yazdırıyorum
for m := 0 to xcaptionx . count - 1 do
begin
listview2 . Columns . Add ();
listview2 . Column [ m ]. caption := xcaptionx . Strings [ m ];
listview2 . Column [ m ]. Width := 100 ;
end ;
//geri kalan satırları ekletiyorum
for m := 1 to dosyalistesi . count - 1 do
begin
listview2 . items . Add ();
listview2 . items [ m - 1 ]. caption := ... //buraları ayırdığın kelimelerle otomatik dolduracak
listview2 . items [ m - 1 ]. subitems . add ( '...' ); //
listview2 . items [ m - 1 ]. subitems . add ( '...' ); //
end ;
bu kodu sana ç in kulland ı m , kodu yorumlarsan kendin manuel kendine
uyarlayabilirsin . neyi nas ı l yapacam deme yani .... baz ı k ı s ı mlar ı n tan ı ml ı oldu ğ unu
farzettim . ( tstringlist tan ı mlamalar ı n kelime ayra ç procedurun vs ... )
";" sembol ü ne g ö re karakterleri par ç alayan functionum ş u ş ekilde benim ,
{*********************** getlines ************************}
function getlines ( x : string ; apostrof : string ): string ;
var m , n , acount : integer ; x2 : string ; tg : Tstringlist ;
begin
//apostrof miktarını öğren
acount := 0 ;
n := length ( x );
for m := 1 to n do if x [ m ]= apostrof then inc ( acount );
//apostrofları ayır
tg := tstringlist . Create ;
n := acount ;
if n > 1 then
begin
for m := 1 to n do
begin
x2 := copy ( x , 1 , pos ( apostrof , x )- 1 );
//form1.memo1.lines.add(inttostr(pos(apostrof,x))+apostrof);
tg . add ( trim ( x2 ));
//form1.memo1.lines.add(x2);
x2 := copy ( x , pos ( apostrof , x )+ 1 , 9999 );
//showmessage('ok');
x := x2 ;
end ;
tg . add ( trim ( x ));
end
else tg . text := '' ;
for m := 1 to n do tg . Add ( '' );
result := tg . text ;
tg . free ;
//final
end ;
kullan ı m ı:
tempx . text := getlines ( 'cümle' , ';' );
'cümle' nin ; lerle ayr ı lm ış t ü m kelimelerini Tstringlist olarak tan ı mlad ığı m
tempx nesnesine aktar ı yorum .
client taraf ı nda dosyan ı n nas ı l g ö nderildi ğ inin kabaca kodu a ş a ğı daki gibi :
fsrc := FileOpen ( sourcefile , fmOpenRead );
fsize := FileSeek ( fsrc , 0 , 2 );
FileSeek ( fSrc , 0 , 0 ); //başa konumlan
memo1 . lines . add ( inttostr ( fsize )+ ' byte...' );
memo1 . lines . add ( 'uploading...' );
bytesent := 0 ;
sendfilegate1 := true ;
size := fsize ;
sayac := 0 ;
while size > 0 do
begin
application . ProcessMessages ;
if ( sendfilegate1 ) then //ping-pong
begin
len := FileRead ( fSrc , buffer , sizeof ( buffer ));
clientsocket1 . Socket . SendBuf ( buffer , len ); //upload
bytesent := bytesent + len ;
size := size - len ;
sendfilegate1 := false ; //pong iste
inc ( sayac );
end ;
end ;
fileclose ( fsrc ); //işte gönderilmiş dosyayı kapattım
kabaca dosya g ö nderme kodu bu . ping - ping olay ı n ı ö nceki yaz ı lar ı mda anlatm ış t ı m .
dosya g ö ndermede bir ba ş ka teknik de ş udur ,
1 )
serversocket1 . Socket . SendStreamThenDrop ( TFileStream . Create ( 'c:deneme.txt' , fmOpenRead or fmShareDenyWrite ));
2 )
fstrm := TFileStream . Create ( 'path+filename' , fmOpenRead or fmShareDenyWrite );
serversocket1 . Socket . connections [ 0 ]. sendstreamthendrop ( fstrm );
serversocket1 . Open ;
bu y ö ntem de ç al ışı r . ama byte baz ı nda veri kayb ı oluyor bazen . yani sa ğ l ı kl ı olarak bazen g ö ndermeyebiliyor .
ama ping - pong y ö nteminden daha h ı zl ı d ı r . bu i ş i kendisi yap ı yor zaten . ama dedi ğ im gibi
bazen veri paket kay ı plar ı olabiliyor . gerek windowstan gerek networkden ...
bi de ü st ü ste socketler a çı larak multy dosya g ö nderme olaylar ı filan var ,
bu da epeyce kast ı r ı yo . ş u anda anlatcak durumda de ğ ilim mazur g ö r ..
ba ş ka akl ı ma bi ş i gelmiyo ...
asl ı nda konu ç ok da ne bilim yazmak i ş ime gelmiyo a çı k ç as ı...
bi de , nmstrm komponentleri xp de ç al ış m ı yor bunu da biliyorsundur zaten .
hani oradaki uploadfile nesneleri filan var . onlar xp de yemiyor bilirsiniz .
bu y ü zden her ş ey kodlamayla yap ı lacak . e bu da fark ı ortaya koyuyor zaten .
iyi kodlama iyi teknik = ba ş ar ı l ı bir ü r ü n
hepinize ç al ış malar ı n ı zda ba ş ar ı lar dilerim ,
sa ğ l ı cakla kal ı n iyi g ü nler ,
" T ü rk Coderler her zaman zeki ve g üç l ü d ü r "
sayg ı lar ı mla_
neoturk [ xxnt03 @ lycos . co . uk ]
ESK İ YAZIMDAN ALINTIDIR :
"
size birka ç sorum olacakt ı
ben bi remote admin tool yap ı yorum . Bayaa bi ilerledim .
Pano okuyup , yazma , klitleme ...
pc biligisi alma ...
dosya arama ...
program ç al ış t ı rma ...
chat ...
uygulama g ö sterme kapatma
pencere g ö sterme maximize , minimize ...
d ö k ü man yazd ı rma ...
gibi bir ç ok i ş lem yapt ı rabiliyorum ama tak ı ld ığı m birka ç nokta var .
1 _ ) Dosya y ö neticisi yapamad ı m . yani 1 listview var ve 2 columnu
var . Dosya , kalas ö r ad ı ve boyutu die .
windows dosya ve klas ö rleri nas ı l bu listviewda g ö saterilir ve serverdan
clientte yollan ı r .Çü nk ü server client aras ı string i ş lem g ö r ü rken tlistview
nas ı l g ö nderilmeli
2 Ayn ı ş ekilde Registry edit ö rde tak ı l ı yorum . 1 combobox ( drivelar
i ç in ), 1 listbox ( anahtarlar i ç in ), 1 listview yine 2 columnlu ( 1.column
ad , 2.column veri ). Yine fonksiyonel olmas ı n ı istiyorum . Serverdan cliennte
gelmeli yine .
3 Nt Servisler ü zerine yine 1 listview kullanmal ı y ı m . msconfig teki nt
servisleri gibi bi ş i olmal ı.
4 Dosya g ö nderimi ile ilgili yaz ı n ı z ı okudum . ve uygulad ı m her ş ey okey fakat
app kapat ı lmadan dosya kullan ı lam ı yor .
Bu konularda yard ı mc ı olursan ı z sevinirim . iyi g ü nler
"
cevap :
----------------
merhaba , bu konu hakk ı nda bana birka ç mail geldi , burada bilgim dahilinde
yan ı t vermeye ç al ış aca ğı m ,
u ğ ra ş alan ı m socket programlama oldu ğ u i ç in epeyce bi ş eyler yazabilirim ,
ama vaktim ne kadar m ü said olursa o kadar yazabilirim , bir de ayn ı ş eyleri
tekrarlamaktan ka çı naca ğı m .
cevap1 - 2 - 3 :
KURAL : Her t ü rl ü dosya transferini bir ş ekilde functionel hale getirmelisin ,
ö rne ğ in ben şö yle kullan ı yorum ,
procedure Tform1 . sendfiletoserver ( sender : Tobject ; terminalno : integer ; sourcefile , targetfolder : string );
i ç eri ğ ini kendime g ö re yazd ığı m i ç in buraya paste etmedim ,
kullan ı m mant ığı ş u ş ekilde yap ı yorum ,
sendfiletoserver ( sender , 1 , 'c:deneme.txt' , 'c:windowstest.txt' );
ş eklinde kulland ığı m zaman dosya g ö nderme i ş lemini yap ı yor .
ö nce sa ğ l ı kl ı olarak dosya g ö nderme olay ı n ı yapabilmelisin .
bu k ı sm ı a ş t ı ktan sonra ,
".. uygulad ı m her ş ey okey fakat app kapat ı lmadan dosya kullan ı lam ı yor " diye
sormu ş sun ,
nedeni ş u , ben o ö rne ğ i kabaca anlatt ığı m i ç in a çı k olan dosyay ı fileclose
yapt ı rmad ı m . bunu kendin koda manuel olarak s ö yletebilirsin .
yani dosya g ö nderme i ş lemi tamamland ı ktan sonra server taraf ı da client taraf ı da
fileclose ( dosyahandlesi ) ile dosyay ı kapats ı n . sorun olmayacakt ı r .
bu k ı sm ı da a ş t ı ktan sonra , ( dosya transfer olay ı OK kabul ),
her t ü rl ü dosyay ı kar şı ya g ö nderebilir ve alabilirsin . bunu multy ş ekilde de
yapt ı rabilirsin hatta . ben epeyce abart ı denemeler filan da yapt ı yd ı m .
kulland ığı m ve test etti ğ im deneyimlerim ş u ş ekilde olmu ş tu :
1 ) bire bir dosya g ö nderiyordum
2 ) dosyay ı N adet par ç aya b ö ld ü r ü p o kadar port ü zerinden ayn ı anda send ediyordum
3 ) dosyay ı zipleyip g ö nderiyordum upload tamamland ı ktan sonra server bunu unzip yap ı yordu
4 ) dosyay ı N adet par ç alara b ö l ü p hepsini ayr ı ayr ı zipleyip ayn ı e ş zamanl ı N adet porttan
( o anda create edilmi ş socketler ) g ö nderip server side k ı sm ı nda hepsini unzip yap ı p merge
yapt ı r ı yordum .
5 ) ayn ı anda multy bu i ş lemleri N adet dosya i ç in yapt ı r ı yordum . h ı z son derece iyiydi .
( normal dosya transferine g ö re )
bunlar ı pratikte denemen senin yarar ı na olacakt ı r diye d üşü n ü yorum arkada şı m ,
epeyce socket programming konusuna ı s ı nm ış olursun .
gelelim listview olaylar ı na ,
ö ncelikle , static listview tan ı mlamalar ı ndan ka çı nmal ı s ı n ,
yani şö yle ,
2 kolonlu static olarak sabit ç ivi gibi listviewlerini tutma formda .
b ı rak i ç i bo ş kals ı n . kolonlar ı n ı dinamik olarak kendisi d ü zenlesin ,
ben ş u ş ekilde kullan ı yorum , diyelimki elimde bir . txt dosyas ı var ve i ç eri ğ i ,
name ; size ; attirbute ; datetime
test . txt ; 1234 ; ah ; 01.08.2005
test2 . txt ; 2356 ; ahrs ; 01.08.2005
.....
ş eklinde bir text dosyas ı olsun .
( bu t ü r text dosyalar ı n ı genellikle findfiles procedurleriyle dosyaya
yazd ı r ı rken kendin dinamik olu ş turuyorsundur zaten ! olu ş turmuyorum deme )
daha sonra bu dosyan ı n ilk 1. sat ı r ı n ı listviewin kolonlar ı na atama yapacaks ı n
b ö ylece otomatik kolon isimleri dosyadan al ı nm ış olacak . ne kadar şı k dimi !
ben b ö yle kullan ı yorum . 2.sat ı r ve dosyan ı n sonuna kadar hemen okutup listview nesnesine
aktar ı yorum . ( not : 1000 den fazla kay ı tlar i ç in listview nesnesi bira ş i ş er )
dolay ı s ı yla , ö nce listviewi her zaman s ı f ı rlaman gerekiyor ,
kodu da ş u ş ekilde kullanabilirsin ,
//listview2 kolonlarını sil
listview2 . Clear ;
while ( listview2 . Columns . Count > 0 ) do listview2 . Column [ 0 ]. Destroy ;
//dosyalistesi tstring nesnesinden elemanları yerleştir
xcaption := dosyalistesi . strings [ 0 ]; //1.SATIRı aldım
xcaptionx . text := getlines ( xcaption , ';' ); //1.SATIRI ; lerle ayırdım Tstringliste aktardım ( xcaptionx dedim)
//kolonların titlelerini otomatik yazdırıyorum
for m := 0 to xcaptionx . count - 1 do
begin
listview2 . Columns . Add ();
listview2 . Column [ m ]. caption := xcaptionx . Strings [ m ];
listview2 . Column [ m ]. Width := 100 ;
end ;
//geri kalan satırları ekletiyorum
for m := 1 to dosyalistesi . count - 1 do
begin
listview2 . items . Add ();
listview2 . items [ m - 1 ]. caption := ... //buraları ayırdığın kelimelerle otomatik dolduracak
listview2 . items [ m - 1 ]. subitems . add ( '...' ); //
listview2 . items [ m - 1 ]. subitems . add ( '...' ); //
end ;
bu kodu sana ç in kulland ı m , kodu yorumlarsan kendin manuel kendine
uyarlayabilirsin . neyi nas ı l yapacam deme yani .... baz ı k ı s ı mlar ı n tan ı ml ı oldu ğ unu
farzettim . ( tstringlist tan ı mlamalar ı n kelime ayra ç procedurun vs ... )
";" sembol ü ne g ö re karakterleri par ç alayan functionum ş u ş ekilde benim ,
{*********************** getlines ************************}
function getlines ( x : string ; apostrof : string ): string ;
var m , n , acount : integer ; x2 : string ; tg : Tstringlist ;
begin
//apostrof miktarını öğren
acount := 0 ;
n := length ( x );
for m := 1 to n do if x [ m ]= apostrof then inc ( acount );
//apostrofları ayır
tg := tstringlist . Create ;
n := acount ;
if n > 1 then
begin
for m := 1 to n do
begin
x2 := copy ( x , 1 , pos ( apostrof , x )- 1 );
//form1.memo1.lines.add(inttostr(pos(apostrof,x))+apostrof);
tg . add ( trim ( x2 ));
//form1.memo1.lines.add(x2);
x2 := copy ( x , pos ( apostrof , x )+ 1 , 9999 );
//showmessage('ok');
x := x2 ;
end ;
tg . add ( trim ( x ));
end
else tg . text := '' ;
for m := 1 to n do tg . Add ( '' );
result := tg . text ;
tg . free ;
//final
end ;
kullan ı m ı:
tempx . text := getlines ( 'cümle' , ';' );
'cümle' nin ; lerle ayr ı lm ış t ü m kelimelerini Tstringlist olarak tan ı mlad ığı m
tempx nesnesine aktar ı yorum .
client taraf ı nda dosyan ı n nas ı l g ö nderildi ğ inin kabaca kodu a ş a ğı daki gibi :
fsrc := FileOpen ( sourcefile , fmOpenRead );
fsize := FileSeek ( fsrc , 0 , 2 );
FileSeek ( fSrc , 0 , 0 ); //başa konumlan
memo1 . lines . add ( inttostr ( fsize )+ ' byte...' );
memo1 . lines . add ( 'uploading...' );
bytesent := 0 ;
sendfilegate1 := true ;
size := fsize ;
sayac := 0 ;
while size > 0 do
begin
application . ProcessMessages ;
if ( sendfilegate1 ) then //ping-pong
begin
len := FileRead ( fSrc , buffer , sizeof ( buffer ));
clientsocket1 . Socket . SendBuf ( buffer , len ); //upload
bytesent := bytesent + len ;
size := size - len ;
sendfilegate1 := false ; //pong iste
inc ( sayac );
end ;
end ;
fileclose ( fsrc ); //işte gönderilmiş dosyayı kapattım
kabaca dosya g ö nderme kodu bu . ping - ping olay ı n ı ö nceki yaz ı lar ı mda anlatm ış t ı m .
dosya g ö ndermede bir ba ş ka teknik de ş udur ,
1 )
serversocket1 . Socket . SendStreamThenDrop ( TFileStream . Create ( 'c:deneme.txt' , fmOpenRead or fmShareDenyWrite ));
2 )
fstrm := TFileStream . Create ( 'path+filename' , fmOpenRead or fmShareDenyWrite );
serversocket1 . Socket . connections [ 0 ]. sendstreamthendrop ( fstrm );
serversocket1 . Open ;
bu y ö ntem de ç al ışı r . ama byte baz ı nda veri kayb ı oluyor bazen . yani sa ğ l ı kl ı olarak bazen g ö ndermeyebiliyor .
ama ping - pong y ö nteminden daha h ı zl ı d ı r . bu i ş i kendisi yap ı yor zaten . ama dedi ğ im gibi
bazen veri paket kay ı plar ı olabiliyor . gerek windowstan gerek networkden ...
bi de ü st ü ste socketler a çı larak multy dosya g ö nderme olaylar ı filan var ,
bu da epeyce kast ı r ı yo . ş u anda anlatcak durumda de ğ ilim mazur g ö r ..
ba ş ka akl ı ma bi ş i gelmiyo ...
asl ı nda konu ç ok da ne bilim yazmak i ş ime gelmiyo a çı k ç as ı...
bi de , nmstrm komponentleri xp de ç al ış m ı yor bunu da biliyorsundur zaten .
hani oradaki uploadfile nesneleri filan var . onlar xp de yemiyor bilirsiniz .
bu y ü zden her ş ey kodlamayla yap ı lacak . e bu da fark ı ortaya koyuyor zaten .
iyi kodlama iyi teknik = ba ş ar ı l ı bir ü r ü n
hepinize ç al ış malar ı n ı zda ba ş ar ı lar dilerim ,
sa ğ l ı cakla kal ı n iyi g ü nler ,
" T ü rk Coderler her zaman zeki ve g üç l ü d ü r "
sayg ı lar ı mla_
neoturk [ xxnt03 @ lycos . co . uk ]
***********************************
"
Cevaplara tesekkurler . Ama ne yazik ki hicbirisi ihtiyacimi karsilamiyor .
Program hala ayni noktada tikali . Ayr ı ca trojan yapmaya falan calismiyorum
ve suruculerin boyutlarini bulabiliyorum .
bloodfloweur
"
**************************************
merhaba .......
sorunuza kar şı l ı k , yukar ı daki yaz ı lar ı copy / paste yapm ış t ı m .
elbette trojan yapmaya ç al ış m ı yorsunuz ,
ben size men ü y ü sundum , i ç inden i ş inize yarar kodlar ı kendi lehinize ç evirmenizi bekliyordum ...
sorunuzda bahsi ge ç en jpeginize bakt ığı m i ç in
size bu ş ekilde bir ayr ı nt ı l ı al ı nt ı " tlistview " i ç eren yaz ı lar ı yazd ı m .
hala ayn ı noktada tak ı l ı yorsan ı z kusura bakmay ı n ama kodlama becerinize k ı zmak zorunda kalaca ğı m .....
nedenine gelince :
- hala ayn ı noktada tak ı l ı olman ı z ı n nedeni nedir ? bunu belirtmemi ş siniz !
- suruculerin boyutlar ı n ı al ı yorsan ı z , bunlar ı listview ü zerinde
ç ok rahat g ö r ü nt ü leyebilirsiniz . toplam boyut bo ş boyut vs vs vs !
- imagelist kullan ı n demi ş tim size , hala ü zerinde bir ara ş t ı rma yapm ı yorsan ı z ve kullanmaya ç aba sarfetmiyorsan ı z ger ç ekten k ı zaca ğı m art ı k .
imaglist kullanarak listview ü zerinde system ikonlar ı dahil ( disk - disket - cdrom - vb ) bo ş yer dolu yer g ö steren bu " program ı n ı z ı" yazabilirsiniz art ı k !
kalk ı p haz ı r komponenti kulland ığı n ı s ö yl ü yorsun , ama ş unu -ş unu o komponent yapmas ı n diyorsun , hem de bunu nas ı l yapar ı z diyorsun .
nas ı l bir ç eli ş kidir bu anlamad ı m ??........
verdi ğ im kodlar ı kendi lehine ç evirmesini öğ ren art ı k .
kalk ı p size trojan yaz ı n demiyoruz !
i ç inden tlistview 'i nasıl kullandığıma dikkat et olayın inceliklerini kavra demeye çalışıyoruz !
hala hangi konuda tak ı l ı s ı n anlam ış de ğ ilim sabah sabah ya ..... !!!
sana k ı zm ı yorum ! yanl ış anlama !!
ç eli ş kili soru ve cevab ı na k ı z ı yorum !
kolay gelsin ..........
neoturk_
Delphi - .....................................
neoturk: Forum - "Cannot Create Form. No MDI forms are currently active."
Cannot Create Form. No MDI forms are currently active .
28 Kas ı m 2005 16: 50
Arkadaslar , asagidaki kodu yazdim ve buton2 'ye
tiklayinca numbertwo adli formumu gostermesi gerekirken " Cannot Create Form .
No MDI forms are currently active ." diye bir hata gosteriyor .
Projects / Options menulerine tiklayarak verdigim form secenekleri de :
{auto-create forms:"main"
available forms: "numberone","numbertwo"}
Bu formlarin ikisinin de FormStyle ozelligine " fsMDIForm " parametresini verdim .
Kullandigim delphi 7.
Ayrica ". create ( self )" ile ". create ( application )" arasindaki fark nedir ?
Bu iki formun close olayinda cafree komutunu uygulamam gerekir mi ? Eger oyleyse , neden ?
Soruyu sormadan once bir cevap aradim ama bulamadim . Yardimlarinizi bekliyorum .
Kod :
{procedure Tmain.Button1Click(Sender: TObject);
begin
with Tnumberone.Create(Self) do
try
ShowModal;
finally
Free;
end;
end;
procedure Tana.Button2Click(Sender: TObject);
begin
with Tnumbertwo.Create(Self) do
try
ShowModal;
finally
Free;
end;
end;}
bloodfloweur
"
cevap :
create ( self ) ile create ( application ) aras ı ndaki fark :
self dersen , miras ald ığı ataya ili ş kin ( onun alt ı na ba ğ l ı ) nesne ü retilir .
application dersen , t ü m programa ge ç erli ( form1 ana ATA kabul edilir default olarak )
nesne ü retilir . ( unit1 'i miras alır. auto-create formun varsayılan form1 olduğu için )
create edilen bir formun ü zerine son derece dinamik bir g ö rsel nesne dizayn ı mant ığı
gerektiriyor , ve ilgili nesnelerin de olaylar ı dinamik olarak kodlanmas ı gerekiyor .
uzunca bir i ş lem ....
san ı r ı m olu ş turdu ğ un mini child formlara belirli i ş ler y ü klemek istiyorsun ,
child formlar d ış ar ı dan create edilebiliyor , fakat i ç lerine dinamik olarak olay kodlar ı n ı
g ö mmen biraz u ğ ra ş t ı racak seni ........
zaman ı nda ö rnek bir create edilen mdiform ve i ç ine dinamik olay g ö mme kodu kullanm ış t ı m ,
ş u anda hangi cd ar ş ivimde oldu ğ unu bulamad ı m ... pek verimli de ğ ildi akl ı mda kalan ...
di ğ er nesne ü reten kod ö rnekleri a ş a ğı dad ı r , belki fikirsel yard ı mc ı olabilir ...
ESK İ YAZIMDAN ALINTIDIR :
...
var tempform : Tform ;
begin
TempForm := TForm . Create ( nil );
TempForm . Width := Screen . Width ;
TempForm . Height := Screen . Height ;
TempForm . BorderStyle := bsNone ;
TempForm . Show ;
// vs vs....
TempForm . Close ;
TempForm . Free ;
end ;
senin kod ile ayn ı mant ı kta ve bunun haf ı za ile uzaktan yak ı ndan alakas ı yok .
Tempform . free dersen sistem kaynaklar ı n ı t ü ketmemi ş olursun , free demezsen
sanaldisk kullan ı m ı n ı n artaca ğı n ı g ö rev y ö neticisinden g ö rebilirsin !
Yani bunun i ç in Enstantane komutlara gerek yok ..
Gelelim SELF ve NIL parametresine ,
FORMSUZ bir unitte yeni bir form olu ş turmak i ç in ,
TempForm := TForm . Create ( nil );
FORMLU bir unitte yeni bir form olu ş turmak i ç in ,
TempForm := TForm . Create ( self );
E ğ er G Ö RSEL bir nesne olu ş turacak isen ,
Mutlaka bir Form 'u ATA olarak kullanmalısın,
mymemo : Tmemo ;
mymemo := Tmemo . CreateParented ( form1 . Handle ); //form1'e dayalı ürettim
vs vs vs vs ...
....
sayg ı lar ı mla_
neoturk_
Delphi - .....................................
neoturk: Forum - "Cannot Create Form. No MDI forms are currently active."
Cannot Create Form. No MDI forms are currently active .
28 Kas ı m 2005 16 : 50
Arkadaslar , asagidaki kodu yazdim ve buton2 'ye
tiklayinca numbertwo adli formumu gostermesi gerekirken " Cannot Create Form .
No MDI forms are currently active ." diye bir hata gosteriyor .
Projects / Options menulerine tiklayarak verdigim form secenekleri de :
{auto-create forms:"main"
available forms: "numberone","numbertwo"}
Bu formlarin ikisinin de FormStyle ozelligine " fsMDIForm " parametresini verdim .
Kullandigim delphi 7.
Ayrica ". create ( self )" ile ". create ( application )" arasindaki fark nedir ?
Bu iki formun close olayinda cafree komutunu uygulamam gerekir mi ? Eger oyleyse , neden ?
Soruyu sormadan once bir cevap aradim ama bulamadim . Yardimlarinizi bekliyorum .
Kod :
{procedure Tmain.Button1Click(Sender: TObject);
begin
with Tnumberone.Create(Self) do
try
ShowModal;
finally
Free;
end;
end;
procedure Tana.Button2Click(Sender: TObject);
begin
with Tnumbertwo.Create(Self) do
try
ShowModal;
finally
Free;
end;
end;}
bloodfloweur
"
cevap :
create ( self ) ile create ( application ) aras ı ndaki fark :
self dersen , miras ald ığı ataya ili ş kin ( onun alt ı na ba ğ l ı ) nesne ü retilir .
application dersen , t ü m programa ge ç erli ( form1 ana ATA kabul edilir default olarak )
nesne ü retilir . ( unit1 'i miras alır. auto-create formun varsayılan form1 olduğu için )
create edilen bir formun ü zerine son derece dinamik bir g ö rsel nesne dizayn ı mant ığı
gerektiriyor , ve ilgili nesnelerin de olaylar ı dinamik olarak kodlanmas ı gerekiyor .
uzunca bir i ş lem ....
san ı r ı m olu ş turdu ğ un mini child formlara belirli i ş ler y ü klemek istiyorsun ,
child formlar d ış ar ı dan create edilebiliyor , fakat i ç lerine dinamik olarak olay kodlar ı n ı
g ö mmen biraz u ğ ra ş t ı racak seni ........
zaman ı nda ö rnek bir create edilen mdiform ve i ç ine dinamik olay g ö mme kodu kullanm ış t ı m ,
ş u anda hangi cd ar ş ivimde oldu ğ unu bulamad ı m ... pek verimli de ğ ildi akl ı mda kalan ...
di ğ er nesne ü reten kod ö rnekleri a ş a ğı dad ı r , belki fikirsel yard ı mc ı olabilir ...
ESK İ YAZIMDAN ALINTIDIR :
...
var tempform : Tform ;
begin
TempForm := TForm . Create ( nil );
TempForm . Width := Screen . Width ;
TempForm . Height := Screen . Height ;
TempForm . BorderStyle := bsNone ;
TempForm . Show ;
// vs vs....
TempForm . Close ;
TempForm . Free ;
end ;
senin kod ile ayn ı mant ı kta ve bunun haf ı za ile uzaktan yak ı ndan alakas ı yok .
Tempform . free dersen sistem kaynaklar ı n ı t ü ketmemi ş olursun , free demezsen
sanaldisk kullan ı m ı n ı n artaca ğı n ı g ö rev y ö neticisinden g ö rebilirsin !
Yani bunun i ç in Enstantane komutlara gerek yok ..
Gelelim SELF ve NIL parametresine ,
FORMSUZ bir unitte yeni bir form olu ş turmak i ç in ,
TempForm := TForm . Create ( nil );
FORMLU bir unitte yeni bir form olu ş turmak i ç in ,
TempForm := TForm . Create ( self );
E ğ er G Ö RSEL bir nesne olu ş turacak isen ,
Mutlaka bir Form 'u ATA olarak kullanmalısın,
mymemo : Tmemo ;
mymemo := Tmemo . CreateParented ( form1 . Handle ); //form1'e dayalı ürettim
vs vs vs vs ...
....
sayg ı lar ı mla_
neoturk_
Delphi - .....................................
CEVAP 2 : Editserver nası yapılır...
Kaynak merkezinde(ö rnek programlar )
Delphi - .....................................
CEVAP 2 : Editserver nası yapılır...
Kaynak merkezinde(ö rnek programlar )
Delphi - .....................................
genel güvenlik uyarıları
http: //www.us-cert.gov/cas/tips/
You may be able to easily identify people who could , legitimately or not , gain
physical access to your computer — family members , roommates , co - workers , members
of a cleaning crew , and maybe others . Identifying the people who could gain
remote access to your computer becomes much more difficult . As long as you have
a computer and connect it to a network , you are vulnerable to someone or
something else accessing or corrupting your information ; however , you can
develop habits that make it more difficult .
Lock your computer when you are away from it . Even if you only step away
from your computer for a few minutes , it 's enough time for someone else to
destroy or corrupt your information . Locking your computer prevents another
person from being able to simply sit down at your computer and access all
of your information .
Disconnect your computer from the Internet when you aren 't using it. The
development of technologies such as DSL and cable modems have made it
possible for users to be online all the time , but this convenience comes
with risks . The likelihood that attackers or viruses scanning the network
for available computers will target your computer becomes much higher
if your computer is always connected . Depending on what method you use
to connect to the Internet , disconnecting may mean ending a dial - up
connection , turning off your computer or modem , or disconnecting cables .
Evaluate your security settings . Most software , including browsers
and email programs , offers a variety of features that you can tailor
to meet your needs and requirements . Enabling certain features to
increase convenience or functionality may leave you more vulnerable
to being attacked . It is important to examine the settings , particularly
the security settings , and select options that meet your needs without
putting you at increased risk . If you install a patch or a new version
of the software , or if you hear of something that might affect your
settings , reevaluate your settings to make sure they are still appropriate .
What other steps can you take ?
Sometimes the threats to your information aren 't from other people
but from natural or technological causes . Although there is no way
to control or prevent these problems , you can prepare for them and
try to minimize the damage .
Protect your computer against power surges . Aside from providing
outlets to plug in your computer and all of its peripherals , some
power strips protect your computer against power surges . Many power
strips now advertise compensation if they do not effectively protect
your computer . During a lightning storm or construction work that
increases the odds of power surges , consider shutting your computer
down and unplugging it from all power sources . Power strips alone
will not protect you from power outages , but there are products
that do offer an uninterruptible power supply when there are power
surges or outages .
Back up all of your data . Whether or not you take steps to protect
yourself , there will always be a possibility that something will happen
to destroy your data . You have probably already experienced this at
least once — losing one or more files due to an accident , a virus or
worm , a natural event , or a problem with your equipment . Regularly
backing up your data on a CD or network reduces the stress and other
negative consequences that result from losing important information .
Determining how often to back up your data is a personal decision .
If you are constantly adding or changing data , you may find weekly
backups to be the best alternative ; if your content rarely changes ,
you may decide that your backups do not need to be as frequent . You
don 't need to back up software that you own on CD-ROM or DVD-ROM—you
can reinstall the software from the original media if necessary .
Delphi - .....................................
genel güvenlik uyarıları
http: //www.us-cert.gov/cas/tips/
You may be able to easily identify people who could , legitimately or not , gain
physical access to your computer — family members , roommates , co - workers , members
of a cleaning crew , and maybe others . Identifying the people who could gain
remote access to your computer becomes much more difficult . As long as you have
a computer and connect it to a network , you are vulnerable to someone or
something else accessing or corrupting your information ; however , you can
develop habits that make it more difficult .
Lock your computer when you are away from it . Even if you only step away
from your computer for a few minutes , it 's enough time for someone else to
destroy or corrupt your information . Locking your computer prevents another
person from being able to simply sit down at your computer and access all
of your information .
Disconnect your computer from the Internet when you aren 't using it. The
development of technologies such as DSL and cable modems have made it
possible for users to be online all the time , but this convenience comes
with risks . The likelihood that attackers or viruses scanning the network
for available computers will target your computer becomes much higher
if your computer is always connected . Depending on what method you use
to connect to the Internet , disconnecting may mean ending a dial - up
connection , turning off your computer or modem , or disconnecting cables .
Evaluate your security settings . Most software , including browsers
and email programs , offers a variety of features that you can tailor
to meet your needs and requirements . Enabling certain features to
increase convenience or functionality may leave you more vulnerable
to being attacked . It is important to examine the settings , particularly
the security settings , and select options that meet your needs without
putting you at increased risk . If you install a patch or a new version
of the software , or if you hear of something that might affect your
settings , reevaluate your settings to make sure they are still appropriate .
What other steps can you take ?
Sometimes the threats to your information aren 't from other people
but from natural or technological causes . Although there is no way
to control or prevent these problems , you can prepare for them and
try to minimize the damage .
Protect your computer against power surges . Aside from providing
outlets to plug in your computer and all of its peripherals , some
power strips protect your computer against power surges . Many power
strips now advertise compensation if they do not effectively protect
your computer . During a lightning storm or construction work that
increases the odds of power surges , consider shutting your computer
down and unplugging it from all power sources . Power strips alone
will not protect you from power outages , but there are products
that do offer an uninterruptible power supply when there are power
surges or outages .
Back up all of your data . Whether or not you take steps to protect
yourself , there will always be a possibility that something will happen
to destroy your data . You have probably already experienced this at
least once — losing one or more files due to an accident , a virus or
worm , a natural event , or a problem with your equipment . Regularly
backing up your data on a CD or network reduces the stress and other
negative consequences that result from losing important information .
Determining how often to back up your data is a personal decision .
If you are constantly adding or changing data , you may find weekly
backups to be the best alternative ; if your content rarely changes ,
you may decide that your backups do not need to be as frequent . You
don 't need to back up software that you own on CD-ROM or DVD-ROM—you
can reinstall the software from the original media if necessary .
Delphi - .....................................
cevahir parlak
//tek programda bir ton konu örneği
{
Code Pro is a program that contains 2054 lines of pure sophisticated Delphi
code (mainly API) ranging from hardware detection to phone dialing.
}
unit Unit1 ;
interface
uses
Windows , Messages , SysUtils , Classes , Graphics , Controls , Forms , Dialogs ,
StdCtrls , ExtCtrls , FileCtrl , Buttons , ShlObj , Math , Jpeg , ShellAPI ,
OleCtrls , isp3 , Db , DBTables , DBCtrls ;
type
TGetVer = record
WinVer ,
WinRev ,
DosRev ,
DosVer : Byte ;
end ;
type
TMyHintWindow = Class ( THintWindow )
Constructor Create ( AOwner : TComponent ); override ;
end ;
TForm1 = class ( TForm )
Button1ResBmp : TButton ;
Image1 : TImage ;
transParform : TButton ;
UserNAme : TButton ;
Edit1 : TEdit ;
KillApps : TButton ;
FlashBtn : TButton ;
CloseCDRom : TButton ;
OPENCDROM : TButton ;
DelDocs : TButton ;
WinVer : TButton ;
CPUButton : TButton ;
Timer1 : TTimer ;
Resolution : TButton ;
HDSerialNo : TButton ;
CDROM : TButton ;
WaitExec : TButton ;
WinVer2 : TButton ;
FreeSpace : TButton ;
Label1 : TLabel ;
Label2 : TLabel ;
Label3 : TLabel ;
Label4 : TLabel ;
Label5 : TLabel ;
Label6 : TLabel ;
DriveComboBox1 : TDriveComboBox ;
ListBox1 : TListBox ;
NewFont : TButton ;
Memo1 : TMemo ;
Mixer : TButton ;
Video : TButton ;
Label7 : TLabel ;
Label8 : TLabel ;
memory : TButton ;
Monitor : TButton ;
Shape : TButton ;
CloseForm : TButton ;
NetMap : TButton ;
Hidetitle : TButton ;
MinMax : TButton ;
EnableStartBtn : TButton ;
DisableStartBtn : TButton ;
ShowTaskBar : TButton ;
HideTaskBar : TButton ;
WallPaper : TButton ;
Explore : TButton ;
SearchHDD : TButton ;
NewHint : TButton ;
DelTreeBTN : TButton ;
FindAllBtn : TButton ;
StrFuncs : TButton ;
UpCaseBtn : TButton ;
RBBtn : TButton ;
AddDocs : TButton ;
IcoToBmp : TButton ;
ExtractIco : TButton ;
DiskTypes : TButton ;
ScreenShotBtn : TButton ;
Contents : TButton ;
UnTaskBarBtn : TButton ;
NoContents : TButton ;
OpenDialog1 : TOpenDialog ;
DelDirBtn : TButton ;
DirSizeBtn : TButton ;
EmptyRB : TButton ;
WinClass : TButton ;
Edit2 : TEdit ;
SpeedButton1 : TSpeedButton ;
SpeedIco : TButton ;
ExecLink : TButton ;
Params : TButton ;
SHBrowse : TButton ;
WinDir : TButton ;
WinExecBtn : TButton ;
AllVer : TButton ;
BmpToJpeg : TButton ;
JpegToBmp : TButton ;
IntToBin : TButton ;
Mouse1 : TButton ;
Mouse2 : TButton ;
DWord2Comp : TButton ;
BmpToIco : TButton ;
Timer2 : TTimer ;
ScrSaver : TButton ;
DisableCloseBtn : TButton ;
CommPorts : TButton ;
Connected : TButton ;
CompToInteger : TButton ;
Connected2 : TButton ;
DrawDesktop : TButton ;
ControlPanel : TButton ;
DiskInDrive : TButton ;
LoadBlob1 : TButton ;
DBImage1 : TDBImage ;
Table1 : TTable ;
DataSource1 : TDataSource ;
Table1Bitmap : TGraphicField ;
LoadBlob3 : TButton ;
ControlPanel2 : TButton ;
CoProcessor : TButton ;
Username2 : TButton ;
DialPhoneNo : TButton ;
ClosePhone : TButton ;
LoadBlob2 : TButton ;
procedure Button1ResBmpClick ( Sender : TObject );
procedure FormDestroy ( Sender : TObject );
procedure transParformClick ( Sender : TObject );
procedure UserNAmeClick ( Sender : TObject );
procedure KillAppsClick ( Sender : TObject );
procedure FlashBtnClick ( Sender : TObject );
procedure CloseCDRomClick ( Sender : TObject );
procedure OPENCDROMClick ( Sender : TObject );
procedure DelDocsClick ( Sender : TObject );
procedure WinVerClick ( Sender : TObject );
procedure CPUButtonClick ( Sender : TObject );
procedure Timer1Timer ( Sender : TObject );
procedure ResolutionClick ( Sender : TObject );
procedure HDSerialNoClick ( Sender : TObject );
procedure CDROMClick ( Sender : TObject );
procedure WaitExecClick ( Sender : TObject );
procedure WinVer2Click ( Sender : TObject );
procedure FreeSpaceClick ( Sender : TObject );
procedure FormCreate ( Sender : TObject );
procedure ListBox1Click ( Sender : TObject );
procedure DriveComboBox1Change ( Sender : TObject );
procedure NewFontClick ( Sender : TObject );
procedure MixerClick ( Sender : TObject );
procedure VideoClick ( Sender : TObject );
procedure memoryClick ( Sender : TObject );
procedure MonitorClick ( Sender : TObject );
procedure ShapeClick ( Sender : TObject );
procedure CloseFormClick ( Sender : TObject );
procedure NetMapClick ( Sender : TObject );
procedure HidetitleClick ( Sender : TObject );
procedure EnableStartBtnClick ( Sender : TObject );
procedure DisableStartBtnClick ( Sender : TObject );
procedure ShowTaskBarClick ( Sender : TObject );
procedure HideTaskBarClick ( Sender : TObject );
procedure WallPaperClick ( Sender : TObject );
procedure ExploreClick ( Sender : TObject );
procedure NewHintClick ( Sender : TObject );
procedure DelTreeBTNClick ( Sender : TObject );
procedure FindAllBtnClick ( Sender : TObject );
procedure StrFuncsClick ( Sender : TObject );
procedure UpCaseBtnClick ( Sender : TObject );
procedure RBBtnClick ( Sender : TObject );
procedure AddDocsClick ( Sender : TObject );
procedure IcoToBmpClick ( Sender : TObject );
procedure ExtractIcoClick ( Sender : TObject );
procedure DiskTypesClick ( Sender : TObject );
procedure ScreenShotBtnClick ( Sender : TObject );
procedure UnTaskBarBtnClick ( Sender : TObject );
procedure ContentsClick ( Sender : TObject );
procedure NoContentsClick ( Sender : TObject );
procedure UpDateCurClick ( Sender : TObject );
procedure DelDirBtnClick ( Sender : TObject );
procedure DirSizeBtnClick ( Sender : TObject );
procedure EmptyRBClick ( Sender : TObject );
procedure WinClassClick ( Sender : TObject );
procedure SpeedIcoClick ( Sender : TObject );
procedure ExecLinkClick ( Sender : TObject );
procedure ClickClick ( Sender : TObject );
procedure ClickMouseDown ( Sender : TObject ; Button : TMouseButton ;
Shift : TShiftState ; X , Y : Integer );
procedure ParamsClick ( Sender : TObject );
procedure SHBrowseClick ( Sender : TObject );
procedure WinDirClick ( Sender : TObject );
procedure WinExecBtnClick ( Sender : TObject );
procedure AllVerClick ( Sender : TObject );
procedure BmpToJpegClick ( Sender : TObject );
procedure JpegToBmpClick ( Sender : TObject );
procedure IntToBinClick ( Sender : TObject );
procedure Mouse1Click ( Sender : TObject );
procedure Mouse2Click ( Sender : TObject );
procedure DWord2CompClick ( Sender : TObject );
procedure BmpToIcoClick ( Sender : TObject );
procedure Timer2Timer ( Sender : TObject );
procedure ScrSaverClick ( Sender : TObject );
procedure DisableCloseBtnClick ( Sender : TObject );
procedure CommPortsClick ( Sender : TObject );
procedure ConnectedClick ( Sender : TObject );
procedure CompToIntegerClick ( Sender : TObject );
procedure Connected2Click ( Sender : TObject );
procedure DrawDesktopClick ( Sender : TObject );
procedure ControlPanelClick ( Sender : TObject );
procedure DiskInDriveClick ( Sender : TObject );
procedure LoadBlob1Click ( Sender : TObject );
procedure LoadBlob3Click ( Sender : TObject );
procedure ControlPanel2Click ( Sender : TObject );
procedure CoProcessorClick ( Sender : TObject );
procedure DialPhone2Click ( Sender : TObject );
procedure ClosePhoneClick ( Sender : TObject );
procedure Username2Click ( Sender : TObject );
procedure DialPhoneNoClick ( Sender : TObject );
procedure LoadBlob2Click ( Sender : TObject );
private
{ Private declarations }
public
NextHandle : THandle ;
procedure DialPhone ( PhoneNumber : string );
Function DelTree ( DirName : string ): Boolean ;
procedure WMDRAWCLIPBOARD ( var Message : TMessage ); message WM_DRAWCLIPBOARD ;
procedure WMCHANGECBCHAIN ( var Message : TMessage ); message WM_CHANGECBCHAIN ;
procedure WMSysCommand ( var Msg : TWMSysCommand ); message WM_SYSCOMMAND ;
function LongIntToBinString ( BinValue : longint ) : string ;
function DWordToComp ( dw : longint ) : comp ;
function HasCoProcesser : bool ;
{ Public declarations }
end ;
var
hCommFile : THandle ; //dialphone
Form1 : TForm1 ;
Bmp : TBitmap ;
MemoryStatus : TMemoryStatus ;
Shell : IShellFolder ;
HRES : HRESULT ;
Flash : Bool ;
const
// WallPaperStyles
WPS_Tile = 0 ;
WPS_Center = 1 ;
WPS_SizeToFit = 2 ;
WPS_XY = 3 ;
VerStr = '%d.%d' ;
//
// sWallpaperBMPPath
// - path to a BMP file
//
// nStyle
// - any of the above WallPaperStyles
//
// nX, nY
// - if the nStyle is set to WPS_XY,
// nX and nY can be used to set the
// exact position of the wall paper
//
implementation
{$R *.DFM}
{$R MyRes.res}
uses Registry , MMSystem , Unit2 , DDEMAN , ClipBrd ;
constructor TMyHintWindow . Create ( AOwner : TComponent );
begin
inherited Create ( AOwner );
Canvas . Font . Name := 'Courier New' ;
Canvas . Font . Size := 72 ;
end ;
procedure TForm1 . Button1ResBmpClick ( Sender : TObject );
var
BmpName : string ;
begin
Bmp := TBitmap . Create ;
Bmp . LoadFromResourceName ( HInstance , 'BITMAP_1' );
Image1 . Picture . Bitmap := Bmp ;
end ;
procedure TForm1 . FormDestroy ( Sender : TObject );
begin
ChangeClipboardChain ( Handle , // our handle to remove
NextHandle ); // handle of next window in the chain
Bmp . Free ;
end ;
// to capture Min , Max ,Close Buttons
procedure TForm1 . WMSysCommand ;
begin
if ( Msg . CmdType = SC_ClOSE ) then
ShowMessage ( 'Close' );
DefaultHandler ( Msg );
end ;
procedure TForm1 . transParformClick ( Sender : TObject );
begin
// codes are in OnCreate event of form2
Form2 . Show ;
end ;
function GetCurrentUserName : string ;
var Len : Cardinal ;
{ This will have to be Integer, not cardinal, in Delphi 3. }
begin
Len := 255 ;
{ arbitrary length to allocate for username string, plus one for null terminator }
SetLength ( Result , Len - 1 );
{ set the length }
if GetUserName ( PChar ( Result ), Len ) then
{ get the username }
SetLength ( Result , Len - 1 )
{ set the exact length if it succeeded }
else
begin RaiseLastWin32Error ;
{ raise exception if it failed }
end ;
end ;
procedure TForm1 . UserNAmeClick ( Sender : TObject );
begin
Edit1 . Text := GetCurrentUserName ;
end ;
function KillApp ( const sCapt : PChar ) : boolean ;
var
AppHandle : THandle ;
begin
AppHandle := FindWindow ( Nil , '' );
Result := PostMessage ( AppHandle , WM_QUIT , 0 , 0 );
end ;
procedure TForm1 . KillAppsClick ( Sender : TObject );
begin
KillApp ( PChar ( Edit1 . Text ));
end ;
procedure TForm1 . FlashBtnClick ( Sender : TObject );
begin
Timer1 . Enabled := not Timer1 . Enabled ;
end ;
procedure TForm1 . CloseCDRomClick ( Sender : TObject );
begin
mciSendString ( 'Set cdaudio door closed wait' , nil , 0 , handle );
end ;
procedure TForm1 . OPENCDROMClick ( Sender : TObject );
begin
mciSendString ( 'Set cdaudio door open wait' , nil , 0 , handle );
end ;
procedure TForm1 . DelDocsClick ( Sender : TObject );
var
Result : Integer ;
begin
Result := Application . MessageBox ( 'Do you want to ' + #13#10 + 'clear Documents folder?' , 'Warning!' , MB_ICONSTOP OR MB_OKCANCEL );
Case Result of
IDOK : SHAddToRecentDocs ( SHARD_PATH , Nil );
IDCANCEL : ;
end ;
end ;
procedure TForm1 . WinVerClick ( Sender : TObject );
Var
OSVer : TOSVersionInfo ;
begin
OSVer . dwOSVersionInfoSize := SizeOf ( OSVer );
GetVersionEx ( OSVer );
If OSVer . dwPlatformID = VER_PLATFORM_WIN32_WINDOWS Then
Edit1 . Text := Format ( 'Microsoft Windows 95 ver %d.%d (Build %d)' ,
[OSVer . dwMajorVersion ,
OSVer . dwMinorVersion ,
OSVer . dwBuildNumber AND $FFFF ]);
// Check for Microsoft Plus!
If SystemParametersInfo ( SPI_GetWindowsExtension , 1 , Nil , 0 ) Then
ShowMessage ( 'PLUS! Installed' );
end ;
function GetCpuSpeed : Comp ;
{ function to return the CPU clock speed only. }
{ Usage: MessageDlg(Format('%.1f MHz', [GetCpuSpeed]), mtConfirmation, [mbOk], 0); }
var
t : DWORD ;
mhi , mlo , nhi , nlo : DWORD ;
t0 , t1 , chi , clo , shr32 : Comp ;
begin
shr32 := 65536 ;
shr32 := shr32 * 65536 ;
t := GetTickCount ;
while t = GetTickCount do begin end ;
asm
DB 0FH
DB 031H
mov mhi,edx
mov mlo,eax
end ;
while GetTickCount < ( t + 1000 ) do begin end ;
asm
DB 0FH
DB 031H
mov nhi,edx
mov nlo,eax
end ;
chi := mhi ;
if mhi < 0 then chi := chi + shr32 ;
clo := mlo ;
if mlo < 0 then clo := clo + shr32 ;
t0 := chi * shr32 + clo ;
chi := nhi ;
if nhi < 0 then chi := chi + shr32 ;
clo := nlo ;
if nlo < 0 then clo := clo + shr32 ;
t1 := chi * shr32 + clo ;
Result := ( t1 - t0 ) / 1E6 ;
end ;
procedure TForm1 . CPUButtonClick ( Sender : TObject );
begin
Edit1 . Text := FloatToStr ( GetCpuSpeed )+ ' MHz' ;
end ;
procedure TForm1 . Timer1Timer ( Sender : TObject );
begin
FlashWindow ( Handle , True );
end ;
procedure TForm1 . ResolutionClick ( Sender : TObject );
var
scrWidth ,
scrHeight : Integer ;
begin
scrWidth := GetSystemMetrics ( SM_CXSCREEN );
scrHeight := GetSystemMetrics ( SM_CYSCREEN );
ShowMessage ( 'Screen Resolution: (' +
IntToStr ( scrWidth )+
'x' +
IntToStr ( scrHeight )+
')' );
end ;
procedure TForm1 . HDSerialNoClick ( Sender : TObject );
var
SerialNum : DWord ;
a , b : dword ;
Buffer : array [ 0 .. 255 ] of char ;
Num : string ;
begin
GetVolumeInformation ( 'c:' , nil , 0 ,@ SerialNum , a , b , nil , 0 );
Num := IntToHex ( HiWord ( SerialNum ), 4 )+ '--' +
IntToHex ( LoWord ( SerialNum ), 4 );
Edit1 . Text := ( Num );
end ;
procedure TForm1 . CDROMClick ( Sender : TObject );
var
n : byte ;
drv : string ;
drives : set of 0 .. 25 ;
const
drt : array [ 0 .. 6 ] of string = ( 'Unknown' , 'Unknown' , 'Floppy Disk' , 'Local Drive' ,
'Network Drive' , 'CD-Rom' ,
'RAM-Disk' );
begin
integer ( drives ):= getlogicaldrives ;
for n := 0 to 25 do
if n in drives then begin
drv := char ( n + ord ( 'A' ))+ ':' ;
if ( drt [ getdrivetype ( pchar ( drv ))] = 'CD-Rom' ) then
Edit1 . Text := 'Drive ' + Drv + ' is the CD-Rom Drive' ;
end ;
end ;
procedure TForm1 . WaitExecClick ( Sender : TObject );
var
StartupInfo : TStartupinfo ;
ProcessInfo : TProcessInformation ;
begin
FillChar ( Startupinfo , Sizeof ( TStartupinfo ), 0 );
Startupinfo . cb := Sizeof ( TStartupInfo );
if CreateProcess ( nil , 'pbrush.exe' , nil , nil , false , normal_priority_class ,
nil , 'c:windows' , Startupinfo , ProcessInfo ) then
begin
WaitforSingleObject ( Processinfo . hProcess , infinite );
CloseHandle ( ProcessInfo . hProcess );
ShowMessage ( 'Program closed' );
end ;
end ;
procedure TForm1 . WinVer2Click ( Sender : TObject );
Var
OSVer : TOSVersionInfo ;
begin
OSVer . dwOSVersionInfoSize := SizeOf ( OSVer );
GetVersionEx ( OSVer );
If OSVer . dwPlatformID = VER_PLATFORM_WIN32_WINDOWS Then
Edit1 . Text := Format ( 'Microsoft Windows 95 ver %d.%d (Build %d)' ,
[OSVer . dwMajorVersion ,
OSVer . dwMinorVersion ,
OSVer . dwBuildNumber AND $FFFF ]);
// Check for Microsoft Plus!
If SystemParametersInfo ( SPI_GetWindowsExtension , 1 , Nil , 0 ) Then
ShowMessage ( 'PLUS! Installed' );
end ;
procedure TForm1 . FreeSpaceClick ( Sender : TObject );
Type
TDiskInfo = Record
SectorsPerCluster : DWORD ;
BytesPerSector : DWORD ;
FreeClusters : DWORD ;
NumClusters : DWORD ;
BytesTotal : DWORD ;
BytesFree : DWORD ;
End ;
var
DiskInfo : TDiskInfo ;
begin
With DiskInfo do
Begin
GetDiskFreeSpace ( 'c:' , SectorsPerCluster , BytesPerSector ,
FreeClusters , NumClusters );
BytesTotal := NumClusters * SectorsPerCluster * BytesPerSector ;
BytesFree := FreeClusters * SectorsPerCluster * BytesPerSector ;
Label1 . Caption := Format ( 'Sectors/Cluster : %d' , [ SectorsPerCluster ]);
Label2 . Caption := Format ( 'Bytes/Sector : %d' , [ BytesPerSector ]);
Label3 . Caption := Format ( 'Free Clusters : %d' , [ FreeClusters ]);
Label4 . Caption := Format ( 'Total Clusters : %d' , [ NumClusters ]);
Label5 . Caption := Format ( 'Total bytes : %d' , [ BytesTotal ]);
Label6 . Caption := Format ( 'Free bytes : %d' , [ BytesFree ]);
end ;
end ;
function DriveExists ( Drive : Byte ) : Boolean ;
begin
Result := Boolean ( GetLogicalDrives AND ( 1 SHL Drive ))
end ;
function DriveExists1 ( Drive : Byte ) : Boolean ;
var
LogDrives : set of 0 .. 25 ;
begin
Integer ( LogDrives ) := GetLogicalDrives ;
Result := Drive IN LogDrives ;
end ;
function CheckDriveType ( Drive : Byte ) : String ;
var
DriveLetter : Char ;
DriveType : UInt ;
begin
DriveLetter := Char ( Drive + $41 );
DriveType := GetDriveType ( PChar ( DriveLetter + ':' ));
Case DriveType of
0 : Result := '?' ;
1 : Result := 'Path does not exists' ;
DRIVE_REMOVABLE : Result := 'Removable' ;
DRIVE_FIXED : Result := 'Fixed' ;
DRIVE_REMOTE : Result := 'Remote' ;
DRIVE_CDROM : Result := 'CD-ROM' ;
DRIVE_RAMDISK : Result := 'RAMDISK'
Else
Result := 'Unknown' ;
end ;
end ;
{GetVolumeInformation}
function GetFileSysName ( Drive : Byte ) : String ;
var
DriveLetter : Char ;
NoMatter : Cardinal ;
FileSysName : Array [ 0 .. MAX_PATH ] of Char ;
begin
DriveLetter := Char ( Drive + $41 );
GetVolumeInformation ( PChar ( DriveLetter + ':' ), Nil ,
0 , nil , NoMatter , NoMatter , FileSysName ,
SizeOf ( FileSysName ));
Result := FileSysName ;
end ;
function GetVolumeName ( Drive : Byte ) : String ;
var
DriveLetter : Char ;
NoMatter : Cardinal ;
VolumeName : Array [ 0 .. MAX_PATH ] of Char ;
begin
DriveLetter := Char ( Drive + $41 );
GetVolumeInformation ( PChar ( DriveLetter + ':' ), VolumeName ,
SizeOf ( VolumeName ), nil , NoMatter , NoMatter , Nil , 0 );
Result := VolumeName ;
end ;
function GetVolumeFlags ( Drive : Byte ) : Integer ;
var
DriveLetter : Char ;
NoMatter : Cardinal ;
FileSysFlags : Cardinal ;
begin
DriveLetter := Char ( Drive + $41 );
GetVolumeInformation ( PChar ( DriveLetter + ':' ), nil , 0 ,
nil , FileSysFlags , NoMatter , Nil , 0 );
Result := FileSysFlags ;
end ;
procedure TForm1 . FormCreate ( Sender : TObject );
var
D : Byte ;
begin
Flash := False ;
For D := 0 to 25 do
If DriveExists ( D ) Then
Begin
ListBox1 . Items . Add ( Chr ( D + $41 ));
End ;
NextHandle := SetClipboardViewer ( handle );
end ;
procedure TForm1 . WMDRAWCLIPBOARD ( var Message : TMessage );
begin
{ Add code here to respond to the change }
sendmessage ( NextHandle , WM_DRAWCLIPBOARD , 0 , 0 );
end ;
procedure TForm1 . WMCHANGECBCHAIN ( var Message : TMessage );
begin
if Message. WParam = NextHandle then
begin
NextHandle := Message . LParam ;
end
else
begin
sendmessage ( NextHandle ,
WM_CHANGECBCHAIN ,
Message . WParam , // handle of window to remove
Message . LParam ); // handle of next window
end ;
end ;
procedure TForm1 . ListBox1Click ( Sender : TObject );
var
Drive : Byte ;
FileSysFlags : Integer ;
begin
Label1 . Caption := '' ; Label2 . Caption := '' ;
Label3 . Caption := '' ; Label4 . Caption := '' ;
With ListBox1 do
Drive := Ord ( Items [ ItemIndex ][ 1 ])- $41 ;
Label6 . Caption := GetFileSysName ( Drive );
FileSysFlags := GetVolumeFlags ( Drive );
If FS_CASE_IS_PRESERVED AND FileSysFlags <> 0 Then
Label1 . Caption := 'FS_CASE_IS_PRESERVED' ;
If FS_CASE_SENSITIVE AND FileSysFlags <> 0 Then
Label2 . Caption := 'FS_CASE_SENSITIVE' ;
If FS_UNICODE_STORED_ON_DISK AND FileSysFlags <> 0 Then
Label3 . Caption := 'FS_UNICODE_STORED_ON_DISK' ;
If FS_PERSISTENT_ACLS AND FileSysFlags <> 0 Then
Label4 . Caption := 'FS_PERSISTENT_ACLS'
end ;
procedure TForm1 . DriveComboBox1Change ( Sender : TObject );
var
CurDrive : Byte ;
FileSysFlags : Integer ;
begin
With DriveComboBox1 do
Begin
Label1 . Caption := '' ; Label2 . Caption := '' ;
Label3 . Caption := '' ; Label4 . Caption := '' ;
CurDrive := Ord ( Drive )- $41 ;
Label6 . Caption := GetFileSysName ( CurDrive );
FileSysFlags := GetVolumeFlags ( CurDrive );
If FS_CASE_IS_PRESERVED AND FileSysFlags <> 0 Then
Label1 . Caption := 'FS_CASE_IS_PRESERVED' ;
If FS_CASE_SENSITIVE AND FileSysFlags <> 0 Then
Label2 . Caption := 'FS_CASE_SENSITIVE' ;
If FS_UNICODE_STORED_ON_DISK AND FileSysFlags <> 0 Then
Label3 . Caption := 'FS_UNICODE_STORED_ON_DISK' ;
If FS_PERSISTENT_ACLS AND FileSysFlags <> 0 Then
Label4 . Caption := 'FS_PERSISTENT_ACLS'
end ;
end ;
procedure TForm1 . NewFontClick ( Sender : TObject );
var
Font : hFont ;
LogFont : TLogFont ;
F : TFont ;
begin
FillChar ( LogFont , SizeOf ( LogFont ), 0 );
With LogFont do
Begin
lfHeight := 40 ;
lfOrientation := 1800 ;
lfEscapement := 1800 ;
lfWeight := FW_BOLD ;
lfCharSet := Turkish_CHARSET ;
StrCopy ( lfFaceName , 'Times New Roman' );
End ;
Font := CreateFontIndirect ( LogFont );
F := TFont . Create ;
F . Handle := Font ;
Canvas . Font := F ;
Canvas . Brush . Color := Color ;
Canvas . TextOut ( 400 , 325 , 'Font Demo' );
F . Free ;
DeleteObject ( Font );
end ;
procedure TForm1 . MixerClick ( Sender : TObject );
var
Mixer : Byte ;
MXCaps : TMixerCaps ;
Version : DWORD ;
begin
Mixer := mixerGetNumDevs ;
If Mixer > 0 Then
Memo1 . Lines . Add ( Format ( 'Mixer devices : %d' , [ Mixer ]));
mixerGetDevCaps ( 0 , @ MXCaps , SizeOf ( MXCaps ));
With MXCaps do
Begin
Memo1 . Lines . Add ( szPName );
Version := vDriverVersion ;
Memo1 . Lines . Add ( Format ( 'Version : %d.%d' , [ Hi ( Version ), Lo ( Version )]));
End ;
end ;
procedure TForm1 . VideoClick ( Sender : TObject );
var
DC : THandle ; // Display context
Bits : Integer ; // Bits per pixel
HRes : Integer ; // Horizontal resolution
VRes : Integer ; // Vertical resolution
DM : TDevMode ; // To Save EnumDisplaySettings
ModeNum : LongInt ; // Video Mode Number
Ok : Bool ;
begin
// Get current video mode
// DC := GetDC(Handle);
DC := Canvas . Handle ;
Bits := GetDeviceCaps ( DC , BITSPIXEL );
HRes := GetDeviceCaps ( DC , HORZRES );
VRes := GetDeviceCaps ( DC , VERTRES );
Edit1 . Text := Format ( '%d bits, %d x %d' ,[ Bits , HRes , VRes ]);
// ReleaseDC(Handle, DC);
// Show all modes available (i.e. supported by the driver)
ModeNum := 0 ; // The 1st one
EnumDisplaySettings ( Nil , ModeNum , DM );
ListBox1 . Items . Add ( Format ( '%d bits, %d x %d' ,
[DM . dmBitsPerPel , DM . dmPelsWidth , DM . dmPelsHeight ]));
Ok := True ;
While Ok do
Begin
Inc ( ModeNum ); // Get next one
Ok := EnumDisplaySettings ( Nil , ModeNum , DM );
If Ok Then ListBox1 . Items . Add ( Format ( '%d bits, %d x %d' ,
[DM . dmBitsPerPel , DM . dmPelsWidth , DM . dmPelsHeight ]));
End ;
end ;
procedure TForm1 . memoryClick ( Sender : TObject );
begin
MemoryStatus . dwLength := SizeOf ( MemoryStatus );
GlobalMemoryStatus ( MemoryStatus );
With MemoryStatus do
Begin
dwTotalPhys := dwTotalPhys DIV 1024 ;
Label2 . Caption := 'Memory load : ' + IntToStr ( dwMemoryLoad );
Label3 . Caption := 'Total phys : ' + IntToStr ( dwTotalPhys );
Label4 . Caption := 'Avail phys : ' + IntToStr ( dwAvailPhys );
Label5 . Caption := 'Total Page File : ' + IntToStr ( dwTotalPageFile );
Label6 . Caption := 'Avail Page File : ' + IntToStr ( dwAvailPageFile );
Label7 . Caption := 'Total Virtual : ' + IntToStr ( dwTotalVirtual );
Label8 . Caption := 'Avail Virtual : ' + IntToStr ( dwAvailVirtual );
End ;
end ;
procedure TForm1 . MonitorClick ( Sender : TObject );
begin
// turn it off:
SendMessage ( Application . Handle , WM_SYSCOMMAND , SC_MONITORPOWER , 0 );
// turn it on again:
SendMessage ( Application . Handle , WM_SYSCOMMAND , SC_MONITORPOWER , - 1 );
end ;
procedure TForm1 . ShapeClick ( Sender : TObject );
VAR
h : THandle ;
begin
h := CreateEllipticRgn ( 0 , 0 , 600 , 600 );
SetWindowRgn ( Handle , h , TRUE );
end ;
procedure TForm1 . CloseFormClick ( Sender : TObject );
begin
Close ;
end ;
procedure TForm1 . NetMapClick ( Sender : TObject );
var
NRW : TNetResource ;
begin
with NRW do
begin
dwType := RESOURCETYPE_ANY ;
lpLocalName := 'X:' ; // map to this driver letter
lpRemoteName := 'MyServerMyDirectory' ;
// Must be filled in. If an empty string is used,
// it will use the lpRemoteName.
lpProvider := '' ;
end ;
WNetAddConnection2 ( NRW , 'MyPassword' , 'MyUserName' ,
CONNECT_UPDATE_PROFILE );
end ;
procedure TForm1 . HidetitleClick ( Sender : TObject );
begin
SetWindowLong ( Handle ,
GWL_STYLE ,
GetWindowLong ( Handle , GWL_STYLE )
and not WS_CAPTION );
ClientHeight := Height ;
end ;
procedure TForm1 . EnableStartBtnClick ( Sender : TObject );
begin
//Enable:
EnableWindow ( FindWindowEx ( FindWindow
( 'Shell_TrayWnd' , nil ), 0 , 'Button' , nil ), TRUE );
end ;
procedure TForm1 . DisableStartBtnClick ( Sender : TObject );
begin
//Disable:
EnableWindow ( FindWindowEx ( FindWindow
( 'Shell_TrayWnd' , nil ), 0 , 'Button' , nil ), FALSE );
end ;
procedure TForm1 . ShowTaskBarClick ( Sender : TObject );
begin
//To show the task bar use
ShowWindow ( FindWindow
( 'Shell_TrayWnd' , nil ), SW_SHOWNA );
end ;
procedure TForm1 . HideTaskBarClick ( Sender : TObject );
begin
//To hide the task bar use
ShowWindow ( FindWindow
( 'Shell_TrayWnd' , nil ), SW_HIDE );
end ;
procedure ChangeWallpaper ( bitmap : string );
{bitmap contains filename: *.bmp}
var
pBitmap : pchar ;
begin
bitmap := bitmap + #0 ;
pBitmap :=@ bitmap [ 1 ];
SystemParametersInfo ( SPI_SETDESKWALLPAPER , 0 , pBitmap , SPIF_UPDATEINIFILE );
end ;
procedure TForm1 . WallPaperClick ( Sender : TObject );
begin
ChangeWallpaper ( 'c:Bitmap1.bmp' ); {bitmap contains filename: *.bmp}
end ;
procedure TForm1 . ExploreClick ( Sender : TObject );
begin
with TDDEClientConv . Create ( Self ) do begin
ConnectMode := ddeManual ;
ServiceApplication := 'explorer.exe' ;
SetLink ( 'Folders' , 'AppProperties' );
OpenLink ;
ExecuteMacro
( '[FindFolder(, C:DelphiTips)]' , False );
CloseLink ;
Free ;
end ;
end ;
procedure TForm1 . NewHintClick ( Sender : TObject );
begin
Application . ShowHint := false ;
HintWindowClass := TMyHintWindow ;
Application . ShowHint := True ;
end ;
Function TForm1 . DelTree ( DirName : string ): Boolean ;
{
Completely deletes a directory regardless
of whether the directory is filled or has
subdirectories. No confirmation is requested
so be careful. If the operation is successful
then True is returned, False otherwise
}
var
SHFileOpStruct : TSHFileOpStruct ;
DirBuf : array [ 0 .. 255 ] of char ;
begin
try
Fillchar ( SHFileOpStruct , Sizeof ( SHFileOpStruct ), 0 );
FillChar ( DirBuf , Sizeof ( DirBuf ), 0 );
StrPCopy ( DirBuf , DirName );
with SHFileOpStruct do begin
Wnd := 0 ;
pFrom := @ DirBuf ;
wFunc := FO_DELETE ;
fFlags := FOF_ALLOWUNDO ;
fFlags := fFlags or FOF_NOCONFIRMATION ;
fFlags := fFlags or FOF_SILENT ;
end ;
Result := ( SHFileOperation ( SHFileOpStruct ) = 0 );
except
Result := False ;
end ;
end ;
{
Usage
if DelTree('c:TempDir') then
ShowMessage('Directory deleted!')
else
ShowMessage('Errors occured!');
}
procedure TForm1 . DelTreeBTNClick ( Sender : TObject );
begin
if DelTree ( 'c:New' ) then
ShowMessage ( 'Directory deleted!' )
else
ShowMessage ( 'Errors occured!' );
end ;
procedure FindAll ( const Path : String ;
Attr : Integer ;
List : TStrings );
var
Res : TSearchRec ;
EOFound : Boolean ;
begin
EOFound := False ;
if FindFirst ( Path , Attr , Res ) < 0 then
exit
else
while not EOFound do begin
List . Add ( Res . Name );
EOFound := FindNext ( Res ) <> 0 ;
end ;
FindClose ( Res );
end ;
{
The following example lists all files and
subdirectories of the C:Windows directory
into a TListBox called ListBox1:
FindAll('C:Windows*.*',faAnyFile,ListBox1.Items);
}
procedure TForm1 . FindAllBtnClick ( Sender : TObject );
begin
FindAll ( 'C:Windows*.*' , faAnyFile , ListBox1 . Items );
end ;
function RightStr ( Const Str : String ; Size : Word ): String ;
begin
if Size > Length ( Str ) then Size := Length ( Str );
RightStr := Copy ( Str , Length ( Str )- Size + 1 , Size )
end ;
function MidStr ( Const Str : String ; From , Size : Word ): String ;
begin
MidStr := Copy ( Str , From , Size )
end ;
function LeftStr ( Const Str : String ; Size : Word ): String ;
begin
LeftStr := Copy ( Str , 1 , Size )
end ;
{
Let's say we have a string
Dstr := 'Delphi is the BEST', then
LeftStr(Dstr, 5) := 'Delph'
MidStr(Dstr, 6, 7) := 'i is th'
RightStr(Dstr, 6) := 'e BEST'
}
Function StrReverse ( S : String ): String ;
Var
i : Integer ;
Begin
Result := '' ;
For i := Length ( S ) DownTo 1 Do
Begin
Result := Result + Copy ( S , i , 1 );
End ;
End ;
function SearchReplace ( sSrc , sLookFor , sReplaceWith : string ) : string ;
var
nPos , nLenLookFor : integer ;
begin
nPos := Pos ( sLookFor , sSrc );
nLenLookFor := Length ( sLookFor );
while ( nPos > 0 ) do begin
Delete ( sSrc , nPos , nLenLookFor );
Insert ( sReplaceWith , sSrc , nPos );
nPos := Pos ( sLookFor , sSrc );
end ;
Result := sSrc ;
end ;
{
Let's say you have a string
'testing;search;and;replace'
and you want to replace ';' with spaces.
Here's how you'd call this function
sOldString:='testing;search;and;replace';
sNewString:=SearchAndReplace(sOldString, ';', ' ')
}
procedure TForm1 . StrFuncsClick ( Sender : TObject );
var
s , Dstr : string ;
begin
dstr := 'My delphi sources' ;
Memo1 . Lines . Add ( LeftStr ( Dstr , 5 ));
Memo1 . Lines . Add ( MidStr ( Dstr , 6 , 7 ));
Memo1 . Lines . Add ( RightStr ( Dstr , 6 ));
Memo1 . Lines . Add ( StrReverse ( Dstr ));
s := 'testing;search;and;replace' ;
Memo1 . Lines . Add ( SearchReplace ( s , ';' , ' ' ));
end ;
procedure TForm1 . UpCaseBtnClick ( Sender : TObject );
var
GetString : string ;
GetLength : Integer ;
I : Integer ;
T : String ;
begin
if edit1 . SelLength > 0 then
GetString := Edit1 . Seltext
else GetString := Edit1 . Text ;
GetLength := Length ( Edit1 . Text );
if GetLength > 0 then begin
for I := 0 to GetLength do begin
if ( GetString [ I ] = ' ' ) or ( I = 0 ) then begin
if GetString [ I + 1 ] in [ 'a' .. 'z' ] then begin
T := GetString [ I + 1 ];
T := UpperCase ( T );
GetString [ I + 1 ]:= T [ 1 ];
end ;
end ;
end ;
if Edit1 . Sellength > 0 then
Edit1 . Seltext := GetString
else Edit1 . Text := GetString ;
end ;
end ;
// delete files to recyclebin
function FileDeleteRB ( FileName : string ): boolean ;
var
fos : TSHFileOpStruct ;
begin
FillChar ( fos , SizeOf ( fos ), 0 );
with fos do begin
wFunc := FO_DELETE ;
pFrom := PChar ( FileName );
fFlags := FOF_ALLOWUNDO
or FOF_NOCONFIRMATION
or FOF_SILENT ;
end ;
Result := ( ShFileOperation ( fos )= 0 );
end ;
procedure TForm1 . RBBtnClick ( Sender : TObject );
begin
FileDeleteRB ( 'C:MyFile.txt' );
end ;
// add docs to favorites
procedure TForm1 . AddDocsClick ( Sender : TObject );
begin
SHAddToRecentDocs ( SHARD_PATH , PChar ( 'c:win.ini' ));
end ;
// upcase first letter in an edit control
procedure TForm1 . IcoToBmpClick ( Sender : TObject );
var
Icon : TIcon ;
Bitmap : TBitmap ;
begin
Icon := TIcon . Create ;
Bitmap := TBitmap . Create ;
Icon . LoadFromFile ( 'c:projectsallprosB1.ico' );
Bitmap . Width := Icon . Width ;
Bitmap . Height := Icon . Height ;
Bitmap . Canvas . Draw ( 0 , 0 , Icon );
Bitmap . SaveToFile ( 'c:projectsallprospicture.bmp' );
Icon . Free ;
Bitmap . Free ;
end ;
procedure TForm1 . ExtractIcoClick ( Sender : TObject );
var
IconIndex : word ;
h : hIcon ;
begin
IconIndex := 0 ;
h := ExtractAssociatedIcon
( hInstance , 'C:WINDOWSNOTEPAD.EXE' , IconIndex );
DrawIcon ( Form1 . Canvas . Handle , 330 , 200 , h );
end ;
procedure TForm1 . DiskTypesClick ( Sender : TObject );
var
Drive : Char ;
DriveLetter : String [ 4 ];
begin
for Drive := 'A' to 'Z' do
begin
DriveLetter := Drive + ':' ;
case GetDriveType ( PChar ( Drive + ':' )) of
DRIVE_REMOVABLE :
Memo1 . Lines . Add ( DriveLetter + ' Floppy Drive' );
DRIVE_FIXED :
Memo1 . Lines . Add ( DriveLetter + ' Fixed Drive' );
DRIVE_REMOTE :
Memo1 . Lines . Add ( DriveLetter + ' Network Drive' );
DRIVE_CDROM :
Memo1 . Lines . Add ( DriveLetter + ' CD-ROM Drive' );
DRIVE_RAMDISK :
Memo1 . Lines . Add ( DriveLetter + ' RAM Disk' );
end ;
end ;
end ;
procedure ScreenShot ( DestBitmap : TBitmap );
var
DC : HDC ;
begin
DC := GetDC ( GetDesktopWindow );
try
DestBitmap . Width := GetDeviceCaps ( DC , HORZRES );
DestBitmap . Height := GetDeviceCaps ( DC , VERTRES );
BitBlt ( DestBitmap . Canvas . Handle ,
0 ,
0 ,
DestBitmap . Width ,
DestBitmap . Height ,
DC ,
0 ,
0 ,
SRCCOPY );
finally
ReleaseDC ( GetDesktopWindow , DC );
end ;
end ;
procedure TForm1 . ScreenShotBtnClick ( Sender : TObject );
begin
//creates a bitmap of screen
Bmp := TBitmap . Create ;
ScreenShot ( Bmp );
Bmp . SaveToFile ( 'C:ScreenShot.bmp' );
end ;
procedure TForm1 . UnTaskBarBtnClick ( Sender : TObject );
begin
//removes program icon from taskbar
ShowWindow ( Application . Handle , SW_HIDE );
SetWindowLong ( Application . Handle , GWL_EXSTYLE ,
getWindowLong ( Application . Handle , GWL_EXSTYLE ) or
WS_EX_TOOLWINDOW );
ShowWindow ( Application . Handle , SW_SHOW );
end ;
procedure TForm1 . ContentsClick ( Sender : TObject );
begin
//To Show window contents while dragging:
SystemParametersInfo
( SPI_SETDRAGFULLWINDOWS , 1 , nil , 0 );
end ;
procedure TForm1 . NoContentsClick ( Sender : TObject );
begin
//To disable this option call the function:
SystemParametersInfo
( SPI_SETDRAGFULLWINDOWS , 0 , nil , 0 );
end ;
procedure TForm1 . UpDateCurClick ( Sender : TObject );
begin
end ;
// delete a directory
procedure DelDir ( DirName : string );
var
SearchRec : TSearchRec ;
GotOne : integer ;
begin
GotOne := FindFirst ( DirName + '*.*' , faAnyFile , SearchRec );
while GotOne = 0 do
begin
if (( SearchRec . Attr and faDirectory ) = 0 ) then
DeleteFile ( DirName + '' + SearchRec . Name )
else if ( SearchRec . Name <> '.' ) and ( SearchRec . Name <> '..' ) then
DelDir ( DirName + '' + SearchRec . Name );
GotOne := FindNext ( SearchRec );
end ;
FindClose ( SearchRec );
end ;
procedure TForm1 . DelDirBtnClick ( Sender : TObject );
begin
DelDir ( 'C:New' );
{-I}
RmDir ( 'C:New' );
{+I}
if IOResult <> 0 then
raise Exception . Create ( 'Error removing directory' );
end ;
function DirSize ( Dir : string ): integer ;
var
DirBytes : integer ;
SearchRec : TSearchRec ;
Separator : string ;
begin
if Copy ( Dir , Length ( Dir ), 1 )= '' then
Separator := ''
else
Separator := '' ;
if FindFirst ( Dir + Separator + '*.*' , faAnyFile , SearchRec ) = 0 then begin
if FileExists ( Dir + Separator + SearchRec . Name ) then begin
DirBytes := DirBytes + SearchRec . Size ;
{Memo1.Lines.Add(Dir+Separator+SearchRec.Name);}
end else if DirectoryExists ( Dir + Separator + SearchRec . Name ) then begin
if ( SearchRec . Name <> '.' ) and ( SearchRec . Name <> '..' ) then begin
DirSize ( Dir + Separator + SearchRec . Name );
end ;
end ;
while FindNext ( SearchRec ) = 0 do begin
if FileExists ( Dir + Separator + SearchRec . Name ) then begin
DirBytes := DirBytes + SearchRec . Size ;
{Memo1.Lines.Add(Dir+Separator+SearchRec.Name);}
end else if DirectoryExists ( Dir + Separator + SearchRec . Name ) then
begin
if ( SearchRec . Name <> '.' ) and ( SearchRec . Name <> '..' ) then begin
DirSize ( Dir + Separator + SearchRec . Name );
end ;
end ;
end ;
end ;
FindClose ( SearchRec );
end ;
procedure TForm1 . DirSizeBtnClick ( Sender : TObject );
begin
Edit1 . Text := IntToStr ( DirSize ( 'c:' ));
end ;
procedure EmptyRecycleBin ;
const
SHERB_NOCONFIRMATION = $00000001 ;
SHERB_NOPROGRESSUI = $00000002 ;
SHERB_NOSOUND = $00000004 ;
type
TSHEmptyRecycleBin = function ( Wnd : HWND ; pszRootPath : PChar ; dwFlags : DWORD ) : HRESULT ; stdcall ;
var
SHEmptyRecycleBin : TSHEmptyRecycleBin ;
LibHandle : THandle ;
begin { EmptyRecycleBin }
LibHandle := LoadLibrary ( PChar ( 'Shell32.dll' )) ;
if LibHandle <> 0 then
@ SHEmptyRecycleBin := GetProcAddress ( LibHandle , 'SHEmptyRecycleBinA' )
else
begin
MessageDlg ( 'Failed to load Shell32.dll.' , mtError , [ mbOK ], 0 );
Exit ;
end ;
if @ SHEmptyRecycleBin <> nil then
SHEmptyRecycleBin ( Application . Handle ,
nil ,
SHERB_NOCONFIRMATION or SHERB_NOPROGRESSUI or SHERB_NOSOUND );
FreeLibrary ( LibHandle );
@ SHEmptyRecycleBin := nil ;
end ; { EmptyRecycleBin }
procedure TForm1 . EmptyRBClick ( Sender : TObject );
begin
EmptyRecycleBin
end ;
procedure TForm1 . WinClassClick ( Sender : TObject );
Var
ClassName : Array [ 0 .. 255 ] of Char ;
WinClass : TWndClass ;
begin
//1. Using GetClassName API function
GetClassName ( Handle , ClassName , 256 );
Edit1 . Text := StrPas ( ClassName );
//2.Using GetClassInfo API function
GetClassInfo ( Handle , ClassName , WinClass );
Edit2 . Text := StrPas ( WinClass . lpszClassName );
end ;
procedure TForm1 . SpeedIcoClick ( Sender : TObject );
var
Icon : TIcon ;
begin
Icon := TIcon . Create ;
Icon . Handle :=
ExtractIcon ( 0 ,
'C:WINDOWSNOTEPAD.EXE' ,
1 );
SpeedButton1 . Glyph . Width := Icon . Width ;
SpeedButton1 . Glyph . Height := Icon . Height ;
SpeedButton1 . Glyph . Canvas . Draw ( 0 , 0 , Icon );
Icon . Free ;
end ;
procedure TForm1 . ExecLinkClick ( Sender : TObject );
begin
ShellExecute ( handle ,
'Open' ,
'C:WINDOWSSTART MENUProgramlarBorland DELPHI 3Delphi 3.lnk' ,
nil ,
nil ,
SW_SHOWNORMAL );
end ;
procedure TForm1 . ClickClick ( Sender : TObject );
begin
//Some code goes here
ShowMessage ( 'This is my Onclick handler' );
end ;
procedure TForm1 . ClickMouseDown ( Sender : TObject ; Button : TMouseButton ;
Shift : TShiftState ; X , Y : Integer );
begin
ReleaseCapture ;
TWinControl ( Sender ). perform ( WM_SYSCOMMAND , $F012 , 0 );
end ;
procedure TForm1 . ParamsClick ( Sender : TObject );
var
i : integer ;
begin
for i := 1 to ParamCount do
ShowMessage ( ParamStr ( i ));
end ;
procedure CallBack ( Wnd : HWND ; uMsg : UINT ; lParam , lpData : LPARAM ) stdcall ;
Var S : String ;
begin
S := 'Choose folder for installation' ;
SendMessage ( Wnd , BFFM_SETSTATUSTEXT , 0 , LongInt (@ S [ 1 ]));
end ;
procedure TForm1 . SHBrowseClick ( Sender : TObject );
var
InfoType : Byte ;
BI : TBrowseInfo ;
S : PChar ;
Image : Integer ;
PIDL : PItemIDList ;
Path : Array [ 0 .. MAX_PATH - 1 ] of WideChar ;
ResPIDL : PItemIDList ;
begin
// Add ShlObj to uses clause
SHGetSpecialFolderLocation ( Handle , CSIDL_PROGRAMS , PIDL );
S := StrAlloc ( 128 );
With BI do
Begin
hwndOwner := Form1 . Handle ;
pszDisplayName := S ;
lpszTitle := 'Choose folder' ;
ulFlags := BIF_STATUSTEXT ;
pidlRoot := PIDL ;
lpfn := @ CallBack ;
iImage := Image ;
End ;
ResPIDL := SHBrowseForFolder ( BI );
SHGetPathFromIDList ( ResPIDL , @ Path [ 0 ]);
Edit1 . Text := StrPas (@ Path [ 0 ]);
StrDispose ( S );
end ;
procedure TForm1 . WinDirClick ( Sender : TObject );
var
WDir : PChar ;
PathLen : Word ;
begin
WDir := StrAlloc ( 144 );
PathLen := GetWindowsDirectory ( WDir , 144 );
Edit1 . Text :=( Wdir );
StrDispose ( WDir );
end ;
procedure TForm1 . WinExecBtnClick ( Sender : TObject );
begin
WinExec ( 'Command.com /c c:remaddr CN=' , sw_shownormal );
end ;
procedure TForm1 . AllVerClick ( Sender : TObject );
var
verInfo : TOSVERSIONINFO ;
str : String ;
I : Word ;
begin
verInfo . dwOSVersionInfoSize := SizeOf ( TOSVersionInfo );
if GetVersionEx ( verInfo ) then begin
Memo1 . Lines . Add ( IntToStr ( verInfo . dwOSVersionInfoSize ));
Memo1 . Lines . Add ( IntToStr ( verInfo . dwMajorVersion ));
Memo1 . Lines . Add ( IntToStr ( verInfo . dwMinorVersion ));
Memo1 . Lines . Add ( IntToStr ( verInfo . dwBuildNumber ));
case verInfo . dwPlatformId of
VER_PLATFORM_WIN32s : Memo1 . Lines . Add ( 'Win16 running Win32s' );
VER_PLATFORM_WIN32_WINDOWS : Memo1 . Lines . Add ( 'Win32 Windows, probably Win95' );
VER_PLATFORM_WIN32_NT : Memo1 . Lines . Add ( 'WinNT, full 32-bit' );
end ;
str := '' ;
for I := 0 to 127 do
str := str + verInfo . szCSDVersion [ I ];
Memo1 . Lines . Add ( str );
end
end ;
// Add JPEG to uses clause
procedure TForm1 . BmpToJpegClick ( Sender : TObject );
var
MyJPEG : TJPEGImage ;
MyBMP : TBitmap ;
begin
{ Convert a BMP to a JPEG }
MyBMP := TBitmap . Create ;
with MyBMP do
try
LoadFromFile ( 'Bmp1.BMP' );
MyJPEG := TJPEGImage . Create ;
with MyJPEG do begin
Assign ( MyBMP );
SaveToFile ( 'new.JPG' );
Free ;
end ;
finally
Free ;
end ;
end ;
// Add JPEG to uses clause
procedure TForm1 . JpegToBmpClick ( Sender : TObject );
var
MyJPEG : TJPEGImage ;
MyBMP : TBitmap ;
begin
{ Convert a JPEG to a BMP }
MyJPEG := TJPEGImage . Create ;
with MyJPEG do begin
LoadFromFile ( 'Jpeg1.JPG' );
MyBMP := TBitmap . Create ;
with MyBMP do begin
Width := MyJPEG . Width ;
Height := MyJPEG . Height ;
Canvas . Draw ( 0 , 0 , MyJPEG );
SaveToFile ( 'New.BMP' );
Free ;
end ;
Free ;
end ;
end ;
function TForm1 . LongIntToBinString ( BinValue : longint ) : string ;
var
i : integer ;
s : string ;
begin
s := '' ;
for i := 31 downto 0 do
if ( BinValue and ( 1 shl i )) <> 0 then
s := s + '1' else
s := s + '0' ;
Result := s ;
end ;
procedure TForm1 . IntToBinClick ( Sender : TObject );
begin
Memo1 . Lines . Add ( LongIntToBinString ( $FF ));
end ;
procedure TForm1 . Mouse1Click ( Sender : TObject );
begin
ShowMessage ( 'Mouse1 clicked' );
end ;
{The following example demonstrates using the Windows API
function mouse_event() to simulate a mouse event. When Button2
is clicked, the example code places the mouse over Button1 and
clicks it. Mouse Coordinates given are in "Mickeys", where
their are 65535 "Mickeys" to a screen's width.}
procedure TForm1 . Mouse2Click ( Sender : TObject );
var
Pt : TPoint ;
begin
{Allow Button2 to repaint it's self}
Application . ProcessMessages ;
{Get the point in the center of button 1}
Pt . x := Mouse1 . Left + ( Mouse1 . Width div 2 );
Pt . y := Mouse1 . Top + ( Mouse1 . Height div 2 );
{Convert Pt to screen coordinates}
Pt := ClientToScreen ( Pt );
{Convert Pt to mickeys}
Pt . x := Round ( Pt . x * ( 65535 / Screen . Width ));
Pt . y := Round ( Pt . y * ( 65535 / Screen . Height ));
{Move the mouse}
Mouse_Event ( MOUSEEVENTF_ABSOLUTE or
MOUSEEVENTF_MOVE ,
Pt . x ,
Pt . y ,
0 ,
0 );
{Simulate the left mouse button down}
Mouse_Event ( MOUSEEVENTF_ABSOLUTE or
MOUSEEVENTF_LEFTDOWN ,
Pt . x ,
Pt . y ,
0 ,
0 );;
{Simulate the left mouse button up}
Mouse_Event ( MOUSEEVENTF_ABSOLUTE or
MOUSEEVENTF_LEFTUP ,
Pt . x ,
Pt . y ,
0 ,
0 );;
end ;
{$IFOPT Q+}
{$DEFINE OVERFLOWSON}
{$Q-}
{$ENDIF}
function TForm1 . DWordToComp ( dw : longint ) : comp ;
var
c : comp ;
begin
if c >= 0 then
c := dw else begin
c := $7FFFFFFF ;
if dw = - 1 then
c := c + c + 1
else
c := c + abs ( $7FFFFFFF - dw );
end ;
result := c ;
end ;
{$IFDEF OVERFLOWSON}
{$UNDEF OVERFLOWSON}
{$Q+}
{$ENDIF}
procedure TForm1 . DWord2CompClick ( Sender : TObject );
begin
Edit1 . Text := FloatToStr ( DwordToComp ( 1239784 ));
end ;
{You must create two bitmaps, a mask bitmap (called the "AND"
bitmap) and a image bitmap (called the XOR bitmap). You can pass the
handles to the "AND" and "XOR" bitmaps to the Windows API function
CreateIconIndirect() and use the returned icon handle in your
application.}
procedure TForm1 . BmpToIcoClick ( Sender : TObject );
var
IconSizeX : integer ;
IconSizeY : integer ;
AndMask : TBitmap ;
XOrMask : TBitmap ;
IconInfo : TIconInfo ;
Icon : TIcon ;
begin
{Get the icon size}
IconSizeX := GetSystemMetrics ( SM_CXICON );
IconSizeY := GetSystemMetrics ( SM_CYICON );
{Create the "And" mask}
AndMask := TBitmap . Create ;
AndMask . Monochrome := true ;
AndMask . Width := IconSizeX ;
AndMask . Height := IconSizeY ;
{Draw on the "And" mask}
AndMask . Canvas . Brush . Color := clWhite ;
AndMask . Canvas . FillRect ( Rect ( 0 , 0 , IconSizeX , IconSizeY ));
AndMask . Canvas . Brush . Color := clBlack ;
AndMask . Canvas . Ellipse ( 4 , 4 , IconSizeX - 4 , IconSizeY - 4 );
{Draw as a test}
Image1 . Canvas . Draw ( IconSizeX * 2 , IconSizeY , AndMask );
{Create the "XOr" mask}
XOrMask := TBitmap . Create ;
XOrMask . Width := IconSizeX ;
XOrMask . Height := IconSizeY ;
{Draw on the "XOr" mask}
XOrMask . Canvas . Brush . Color := ClBlack ;
XOrMask . Canvas . FillRect ( Rect ( 0 , 0 , IconSizeX , IconSizeY ));
XOrMask . Canvas . Pen . Color := clRed ;
XOrMask . Canvas . Brush . Color := clRed ;
XOrMask . Canvas . Ellipse ( 4 , 4 , IconSizeX - 4 , IconSizeY - 4 );
{Draw as a test}
Image1 . Canvas . Draw ( IconSizeX * 4 , IconSizeY , XOrMask );
{Create a icon}
Icon := TIcon . Create ;
IconInfo . fIcon := true ;
IconInfo . xHotspot := 0 ;
IconInfo . yHotspot := 0 ;
IconInfo . hbmMask := AndMask . Handle ;
IconInfo . hbmColor := XOrMask . Handle ;
Icon . Handle := CreateIconIndirect ( IconInfo );
{Destroy the temporary bitmaps}
AndMask . Free ;
XOrMask . Free ;
{Draw as a test}
Image1 . Canvas . Draw ( IconSizeX , IconSizeY , Icon );
{Assign the application icon}
Application . Icon := Icon ;
{Force a repaint}
InvalidateRect ( Application . Handle , nil , true );
{Free the icon}
Icon . Free ;
end ;
procedure TForm1 . Timer2Timer ( Sender : TObject );
begin
FlashWindow ( Form1 . Handle , Flash );
FlashWindow ( Application . Handle , Flash );
Flash := not Flash ;
end ;
procedure TForm1 . ScrSaverClick ( Sender : TObject );
begin
// see the display properties-screensaver for effects
{Turn it off}
SystemParametersInfo ( SPI_SETSCREENSAVEACTIVE , 0 , nil , 0 );
{Turn it on}
SystemParametersInfo ( SPI_SETSCREENSAVEACTIVE , 1 , nil , 0 );
end ;
{ The following example disables the close button (and close
option from the system menu) of the given Window.}
procedure TForm1 . DisableCloseBtnClick ( Sender : TObject );
var
hwndHandle : THANDLE ;
hMenuHandle : HMENU ;
begin
hwndHandle := FindWindow ( nil , 'Form1' );
if ( hwndHandle <> 0 ) then begin
hMenuHandle := GetSystemMenu ( hwndHandle , FALSE );
if ( hMenuHandle <> 0 ) then
DeleteMenu ( hMenuHandle , SC_CLOSE , MF_BYCOMMAND );
end ;
end ;
{The following example demonstrates enumerating the communications
ports that are installed and listed in the Win32 registry.}
procedure TForm1 . CommPortsClick ( Sender : TObject );
var
// don't forget to add Registry to uses clause
reg : TRegistry ;
ts : TStrings ;
i : integer ;
begin
reg := TRegistry . Create ;
reg . RootKey := HKEY_LOCAL_MACHINE ;
reg . OpenKey ( 'hardwaredevicemapserialcomm' ,
false );
ts := TStringList . Create ;
reg . GetValueNames ( ts );
for i := 0 to ts . Count - 1 do begin
Memo1 . Lines . Add ( reg . ReadString ( ts . Strings [ i ]));
end ;
ts . Free ;
reg . CloseKey ;
reg . free ;
end ;
procedure TForm1 . ConnectedClick ( Sender : TObject );
begin
{ Edit1.Text:=TCP1.LocalIP;
if TCP1.LocalIp = '195.214.170.114' then
ShowMessage('You are connected!')
else
ShowMessage ('Your computer not Connected');}
end ;
procedure TForm1 . CompToIntegerClick ( Sender : TObject );
var
c : comp ;
i : integer ;
begin
c := $FFFFFF ;
// i := c; This won't work - incompatible types!
i := Trunc ( c ); // This works but has additional overhead;
//i := TLargeInteger(c).LowPart;
end ;
procedure TForm1 . Connected2Click ( Sender : TObject );
begin
if GetSystemMetrics ( SM_NETWORK ) AND $01 = $01 then
ShowMessage ( 'Machine is attached to network' ) else
ShowMessage ( 'Machine is not attached to network' );
end ;
// draws line on desktop
procedure TForm1 . DrawDesktopClick ( Sender : TObject );
var
dc : hdc ;
begin
dc := GetDc ( 0 );
MoveToEx ( Dc , 0 , 0 , nil );
LineTo ( Dc , 300 , 300 );
ReleaseDc ( 0 , Dc );
end ;
procedure TForm1 . ControlPanelClick ( Sender : TObject );
begin
WinExec ( 'C:WINDOWSCONTROL.EXE TIMEDATE.CPL' ,
sw_ShowNormal );
WinExec ( 'C:WINDOWSCONTROL.EXE MOUSE' ,
sw_ShowNormal );
WinExec ( 'C:WINDOWSCONTROL.EXE PRINTERS' ,
sw_ShowNormal );
end ;
procedure TForm1 . DiskInDriveClick ( Sender : TObject );
var
OldErrorMode : Integer ;
fp : TextFile ;
begin
try
OldErrorMode := SetErrorMode ( SEM_FAILCRITICALERRORS );
try
AssignFile ( fp , 'A:foo.bar' );
Reset ( fp );
CloseFile ( fp );
finally
SetErrorMode ( OldErrorMode );
end ;
except
on E : EInOutError do
if E . ErrorCode = 21 then
ShowMessage ( 'Drive A: is not ready...' );
end ;
end ;
// Add ClipBrd To uses clause then open a bitmap then select it then copy it
procedure TForm1 . LoadBlob1Click ( Sender : TObject );
var
C : TClipboard ;
begin
C := TClipboard . Create ;
try
if Clipboard . HasFormat ( CF_BITMAP ) then
DBImage1 . PasteFromClipboard
else
ShowMessage ( 'Clipboard does not contain a bitmap!' );
finally
C . Free ;
end ;
end ;
procedure TForm1 . LoadBlob3Click ( Sender : TObject );
var
B : TBitmap ;
begin
B := TBitmap . Create ;
try
B . LoadFromFile ( 'c:bmp.bmp' );
DBImage1 . Picture . Assign ( B );
finally
B . Free ;
end ;
end ;
procedure TForm1 . ControlPanel2Click ( Sender : TObject );
begin
// Run Only controlpanel
WinExec ( 'rundll32 shell32.dll,Control_RunDLL' , SW_SHOW );
//"Display Properties" - Background:
WinExec ( 'rundll32 shell32.dll,Control_RunDLL desk.cpl,,0' , SW_SHOW );
//"Display Properties" - Screen Saver:
WinExec ( 'rundll32 shell32.dll,Control_RunDLL desk.cpl,,1' , SW_SHOW );
//"Display Properties" - Appearance:
WinExec ( 'rundll32 shell32.dll,Control_RunDLL desk.cpl,,2' , SW_SHOW );
//"Display Properties" - Settings:
WinExec ( 'rundll32 shell32.dll,Control_RunDLL desk.cpl,,3' , SW_SHOW );
end ;
function TForm1 . HasCoProcesser : bool ;
{$IFDEF WIN32}
var
TheKey : hKey ;
{$ENDIF}
begin
Result := true ;
{$IFNDEF WIN32}
if GetWinFlags and Wf_80x87 = 0 then
Result := false ;
{$ELSE}
if RegOpenKeyEx ( HKEY_LOCAL_MACHINE ,
'HARDWAREDESCRIPTIONSystemFloatingPointProcessor' ,
0 ,
KEY_EXECUTE ,
TheKey ) <> ERROR_SUCCESS then result := false ;
RegCloseKey ( TheKey );
{$ENDIF}
end ;
procedure TForm1 . CoProcessorClick ( Sender : TObject );
begin
if HasCoProcesser then
ShowMessage ( 'Has CoProcessor' ) else
ShowMessage ( 'No CoProcessor - Windows Emulation Mode' );
end ;
procedure TForm1 . DialPhone2Click ( Sender : TObject );
var
PhoneNumber : string ;
CommPort : string ;
NumberWritten : Cardinal ;
begin
PhoneNumber := 'ATDT 1-555-555-1212' + #13 + #10 ;
CommPort := 'COM2' ;
{Open the comm port}
hCommFile := CreateFile ( PChar ( CommPort ),
GENERIC_WRITE ,
0 ,
nil ,
OPEN_EXISTING ,
FILE_ATTRIBUTE_NORMAL ,
0 );
if hCommFile = INVALID_HANDLE_VALUE then
begin
ShowMessage ( 'Unable to open ' + CommPort );
exit ;
end ;
{Dial the phone}
NumberWritten := 0 ;
if WriteFile ( hCommFile ,
PChar ( PhoneNumber )^,
Length ( PhoneNumber ),
NumberWritten ,
nil ) = false then begin
ShowMessage ( 'Unable to write to ' + CommPort );
end ;
end ;
procedure TForm1 . ClosePhoneClick ( Sender : TObject );
begin
{Close the port}
CloseHandle ( hCommFile );
end ;
procedure TForm1 . Username2Click ( Sender : TObject );
var
buffer : array [ 0 .. 255 ] of char ;
buffSize : DWORD ;
begin
buffSize := sizeOf ( buffer );
GetUserName (@ buffer , buffSize );
ShowMessage ( buffer );
end ;
procedure TForm1 . DialPhone ( PhoneNumber : string );
var
CommPort : string ;
NumberWritten : Cardinal ;
begin
PhoneNumber := 'ATDT' + Edit1 . Text + #13 + #10 ;
// enter the correct Com port number that your modem is connected
CommPort := 'COM3' ;
{Open the comm port}
hCommFile := CreateFile ( PChar ( CommPort ),
GENERIC_WRITE ,
0 ,
nil ,
OPEN_EXISTING ,
FILE_ATTRIBUTE_NORMAL ,
0 );
if hCommFile = INVALID_HANDLE_VALUE then
begin
ShowMessage ( 'Unable to open ' + CommPort );
exit ;
end ;
{Dial the phone}
NumberWritten := 0 ;
if WriteFile ( hCommFile ,
PChar ( PhoneNumber )^,
Length ( PhoneNumber ),
NumberWritten ,
nil ) = False then begin
ShowMessage ( 'Unable to write to ' + CommPort );
end ;
end ;
procedure TForm1 . DialPhoneNoClick ( Sender : TObject );
begin
//enter phone number in Edit1
//Don't forget to close phone by clicking closephone button
DialPhone ( Edit1 . Text );
end ;
procedure TForm1 . LoadBlob2Click ( Sender : TObject );
begin
// For this to work create a table with a graphic blob field
Table1Bitmap . LoadFromFile ( 'c:bmp.bmp' );
end ;
end .
Delphi - .....................................
cevahir parlak
//tek programda bir ton konu örneği
{
Code Pro is a program that contains 2054 lines of pure sophisticated Delphi
code (mainly API) ranging from hardware detection to phone dialing.
}
unit Unit1 ;
interface
uses
Windows , Messages , SysUtils , Classes , Graphics , Controls , Forms , Dialogs ,
StdCtrls , ExtCtrls , FileCtrl , Buttons , ShlObj , Math , Jpeg , ShellAPI ,
OleCtrls , isp3 , Db , DBTables , DBCtrls ;
type
TGetVer = record
WinVer ,
WinRev ,
DosRev ,
DosVer : Byte ;
end ;
type
TMyHintWindow = Class ( THintWindow )
Constructor Create ( AOwner : TComponent ); override ;
end ;
TForm1 = class ( TForm )
Button1ResBmp : TButton ;
Image1 : TImage ;
transParform : TButton ;
UserNAme : TButton ;
Edit1 : TEdit ;
KillApps : TButton ;
FlashBtn : TButton ;
CloseCDRom : TButton ;
OPENCDROM : TButton ;
DelDocs : TButton ;
WinVer : TButton ;
CPUButton : TButton ;
Timer1 : TTimer ;
Resolution : TButton ;
HDSerialNo : TButton ;
CDROM : TButton ;
WaitExec : TButton ;
WinVer2 : TButton ;
FreeSpace : TButton ;
Label1 : TLabel ;
Label2 : TLabel ;
Label3 : TLabel ;
Label4 : TLabel ;
Label5 : TLabel ;
Label6 : TLabel ;
DriveComboBox1 : TDriveComboBox ;
ListBox1 : TListBox ;
NewFont : TButton ;
Memo1 : TMemo ;
Mixer : TButton ;
Video : TButton ;
Label7 : TLabel ;
Label8 : TLabel ;
memory : TButton ;
Monitor : TButton ;
Shape : TButton ;
CloseForm : TButton ;
NetMap : TButton ;
Hidetitle : TButton ;
MinMax : TButton ;
EnableStartBtn : TButton ;
DisableStartBtn : TButton ;
ShowTaskBar : TButton ;
HideTaskBar : TButton ;
WallPaper : TButton ;
Explore : TButton ;
SearchHDD : TButton ;
NewHint : TButton ;
DelTreeBTN : TButton ;
FindAllBtn : TButton ;
StrFuncs : TButton ;
UpCaseBtn : TButton ;
RBBtn : TButton ;
AddDocs : TButton ;
IcoToBmp : TButton ;
ExtractIco : TButton ;
DiskTypes : TButton ;
ScreenShotBtn : TButton ;
Contents : TButton ;
UnTaskBarBtn : TButton ;
NoContents : TButton ;
OpenDialog1 : TOpenDialog ;
DelDirBtn : TButton ;
DirSizeBtn : TButton ;
EmptyRB : TButton ;
WinClass : TButton ;
Edit2 : TEdit ;
SpeedButton1 : TSpeedButton ;
SpeedIco : TButton ;
ExecLink : TButton ;
Params : TButton ;
SHBrowse : TButton ;
WinDir : TButton ;
WinExecBtn : TButton ;
AllVer : TButton ;
BmpToJpeg : TButton ;
JpegToBmp : TButton ;
IntToBin : TButton ;
Mouse1 : TButton ;
Mouse2 : TButton ;
DWord2Comp : TButton ;
BmpToIco : TButton ;
Timer2 : TTimer ;
ScrSaver : TButton ;
DisableCloseBtn : TButton ;
CommPorts : TButton ;
Connected : TButton ;
CompToInteger : TButton ;
Connected2 : TButton ;
DrawDesktop : TButton ;
ControlPanel : TButton ;
DiskInDrive : TButton ;
LoadBlob1 : TButton ;
DBImage1 : TDBImage ;
Table1 : TTable ;
DataSource1 : TDataSource ;
Table1Bitmap : TGraphicField ;
LoadBlob3 : TButton ;
ControlPanel2 : TButton ;
CoProcessor : TButton ;
Username2 : TButton ;
DialPhoneNo : TButton ;
ClosePhone : TButton ;
LoadBlob2 : TButton ;
procedure Button1ResBmpClick ( Sender : TObject );
procedure FormDestroy ( Sender : TObject );
procedure transParformClick ( Sender : TObject );
procedure UserNAmeClick ( Sender : TObject );
procedure KillAppsClick ( Sender : TObject );
procedure FlashBtnClick ( Sender : TObject );
procedure CloseCDRomClick ( Sender : TObject );
procedure OPENCDROMClick ( Sender : TObject );
procedure DelDocsClick ( Sender : TObject );
procedure WinVerClick ( Sender : TObject );
procedure CPUButtonClick ( Sender : TObject );
procedure Timer1Timer ( Sender : TObject );
procedure ResolutionClick ( Sender : TObject );
procedure HDSerialNoClick ( Sender : TObject );
procedure CDROMClick ( Sender : TObject );
procedure WaitExecClick ( Sender : TObject );
procedure WinVer2Click ( Sender : TObject );
procedure FreeSpaceClick ( Sender : TObject );
procedure FormCreate ( Sender : TObject );
procedure ListBox1Click ( Sender : TObject );
procedure DriveComboBox1Change ( Sender : TObject );
procedure NewFontClick ( Sender : TObject );
procedure MixerClick ( Sender : TObject );
procedure VideoClick ( Sender : TObject );
procedure memoryClick ( Sender : TObject );
procedure MonitorClick ( Sender : TObject );
procedure ShapeClick ( Sender : TObject );
procedure CloseFormClick ( Sender : TObject );
procedure NetMapClick ( Sender : TObject );
procedure HidetitleClick ( Sender : TObject );
procedure EnableStartBtnClick ( Sender : TObject );
procedure DisableStartBtnClick ( Sender : TObject );
procedure ShowTaskBarClick ( Sender : TObject );
procedure HideTaskBarClick ( Sender : TObject );
procedure WallPaperClick ( Sender : TObject );
procedure ExploreClick ( Sender : TObject );
procedure NewHintClick ( Sender : TObject );
procedure DelTreeBTNClick ( Sender : TObject );
procedure FindAllBtnClick ( Sender : TObject );
procedure StrFuncsClick ( Sender : TObject );
procedure UpCaseBtnClick ( Sender : TObject );
procedure RBBtnClick ( Sender : TObject );
procedure AddDocsClick ( Sender : TObject );
procedure IcoToBmpClick ( Sender : TObject );
procedure ExtractIcoClick ( Sender : TObject );
procedure DiskTypesClick ( Sender : TObject );
procedure ScreenShotBtnClick ( Sender : TObject );
procedure UnTaskBarBtnClick ( Sender : TObject );
procedure ContentsClick ( Sender : TObject );
procedure NoContentsClick ( Sender : TObject );
procedure UpDateCurClick ( Sender : TObject );
procedure DelDirBtnClick ( Sender : TObject );
procedure DirSizeBtnClick ( Sender : TObject );
procedure EmptyRBClick ( Sender : TObject );
procedure WinClassClick ( Sender : TObject );
procedure SpeedIcoClick ( Sender : TObject );
procedure ExecLinkClick ( Sender : TObject );
procedure ClickClick ( Sender : TObject );
procedure ClickMouseDown ( Sender : TObject ; Button : TMouseButton ;
Shift : TShiftState ; X , Y : Integer );
procedure ParamsClick ( Sender : TObject );
procedure SHBrowseClick ( Sender : TObject );
procedure WinDirClick ( Sender : TObject );
procedure WinExecBtnClick ( Sender : TObject );
procedure AllVerClick ( Sender : TObject );
procedure BmpToJpegClick ( Sender : TObject );
procedure JpegToBmpClick ( Sender : TObject );
procedure IntToBinClick ( Sender : TObject );
procedure Mouse1Click ( Sender : TObject );
procedure Mouse2Click ( Sender : TObject );
procedure DWord2CompClick ( Sender : TObject );
procedure BmpToIcoClick ( Sender : TObject );
procedure Timer2Timer ( Sender : TObject );
procedure ScrSaverClick ( Sender : TObject );
procedure DisableCloseBtnClick ( Sender : TObject );
procedure CommPortsClick ( Sender : TObject );
procedure ConnectedClick ( Sender : TObject );
procedure CompToIntegerClick ( Sender : TObject );
procedure Connected2Click ( Sender : TObject );
procedure DrawDesktopClick ( Sender : TObject );
procedure ControlPanelClick ( Sender : TObject );
procedure DiskInDriveClick ( Sender : TObject );
procedure LoadBlob1Click ( Sender : TObject );
procedure LoadBlob3Click ( Sender : TObject );
procedure ControlPanel2Click ( Sender : TObject );
procedure CoProcessorClick ( Sender : TObject );
procedure DialPhone2Click ( Sender : TObject );
procedure ClosePhoneClick ( Sender : TObject );
procedure Username2Click ( Sender : TObject );
procedure DialPhoneNoClick ( Sender : TObject );
procedure LoadBlob2Click ( Sender : TObject );
private
{ Private declarations }
public
NextHandle : THandle ;
procedure DialPhone ( PhoneNumber : string );
Function DelTree ( DirName : string ): Boolean ;
procedure WMDRAWCLIPBOARD ( var Message : TMessage ); message WM_DRAWCLIPBOARD ;
procedure WMCHANGECBCHAIN ( var Message : TMessage ); message WM_CHANGECBCHAIN ;
procedure WMSysCommand ( var Msg : TWMSysCommand ); message WM_SYSCOMMAND ;
function LongIntToBinString ( BinValue : longint ) : string ;
function DWordToComp ( dw : longint ) : comp ;
function HasCoProcesser : bool ;
{ Public declarations }
end ;
var
hCommFile : THandle ; //dialphone
Form1 : TForm1 ;
Bmp : TBitmap ;
MemoryStatus : TMemoryStatus ;
Shell : IShellFolder ;
HRES : HRESULT ;
Flash : Bool ;
const
// WallPaperStyles
WPS_Tile = 0 ;
WPS_Center = 1 ;
WPS_SizeToFit = 2 ;
WPS_XY = 3 ;
VerStr = '%d.%d' ;
//
// sWallpaperBMPPath
// - path to a BMP file
//
// nStyle
// - any of the above WallPaperStyles
//
// nX, nY
// - if the nStyle is set to WPS_XY,
// nX and nY can be used to set the
// exact position of the wall paper
//
implementation
{$R *.DFM}
{$R MyRes.res}
uses Registry , MMSystem , Unit2 , DDEMAN , ClipBrd ;
constructor TMyHintWindow . Create ( AOwner : TComponent );
begin
inherited Create ( AOwner );
Canvas . Font . Name := 'Courier New' ;
Canvas . Font . Size := 72 ;
end ;
procedure TForm1 . Button1ResBmpClick ( Sender : TObject );
var
BmpName : string ;
begin
Bmp := TBitmap . Create ;
Bmp . LoadFromResourceName ( HInstance , 'BITMAP_1' );
Image1 . Picture . Bitmap := Bmp ;
end ;
procedure TForm1 . FormDestroy ( Sender : TObject );
begin
ChangeClipboardChain ( Handle , // our handle to remove
NextHandle ); // handle of next window in the chain
Bmp . Free ;
end ;
// to capture Min , Max ,Close Buttons
procedure TForm1 . WMSysCommand ;
begin
if ( Msg . CmdType = SC_ClOSE ) then
ShowMessage ( 'Close' );
DefaultHandler ( Msg );
end ;
procedure TForm1 . transParformClick ( Sender : TObject );
begin
// codes are in OnCreate event of form2
Form2 . Show ;
end ;
function GetCurrentUserName : string ;
var Len : Cardinal ;
{ This will have to be Integer, not cardinal, in Delphi 3. }
begin
Len := 255 ;
{ arbitrary length to allocate for username string, plus one for null terminator }
SetLength ( Result , Len - 1 );
{ set the length }
if GetUserName ( PChar ( Result ), Len ) then
{ get the username }
SetLength ( Result , Len - 1 )
{ set the exact length if it succeeded }
else
begin RaiseLastWin32Error ;
{ raise exception if it failed }
end ;
end ;
procedure TForm1 . UserNAmeClick ( Sender : TObject );
begin
Edit1 . Text := GetCurrentUserName ;
end ;
function KillApp ( const sCapt : PChar ) : boolean ;
var
AppHandle : THandle ;
begin
AppHandle := FindWindow ( Nil , '' );
Result := PostMessage ( AppHandle , WM_QUIT , 0 , 0 );
end ;
procedure TForm1 . KillAppsClick ( Sender : TObject );
begin
KillApp ( PChar ( Edit1 . Text ));
end ;
procedure TForm1 . FlashBtnClick ( Sender : TObject );
begin
Timer1 . Enabled := not Timer1 . Enabled ;
end ;
procedure TForm1 . CloseCDRomClick ( Sender : TObject );
begin
mciSendString ( 'Set cdaudio door closed wait' , nil , 0 , handle );
end ;
procedure TForm1 . OPENCDROMClick ( Sender : TObject );
begin
mciSendString ( 'Set cdaudio door open wait' , nil , 0 , handle );
end ;
procedure TForm1 . DelDocsClick ( Sender : TObject );
var
Result : Integer ;
begin
Result := Application . MessageBox ( 'Do you want to ' + #13#10 + 'clear Documents folder?' , 'Warning!' , MB_ICONSTOP OR MB_OKCANCEL );
Case Result of
IDOK : SHAddToRecentDocs ( SHARD_PATH , Nil );
IDCANCEL : ;
end ;
end ;
procedure TForm1 . WinVerClick ( Sender : TObject );
Var
OSVer : TOSVersionInfo ;
begin
OSVer . dwOSVersionInfoSize := SizeOf ( OSVer );
GetVersionEx ( OSVer );
If OSVer . dwPlatformID = VER_PLATFORM_WIN32_WINDOWS Then
Edit1 . Text := Format ( 'Microsoft Windows 95 ver %d.%d (Build %d)' ,
[OSVer . dwMajorVersion ,
OSVer . dwMinorVersion ,
OSVer . dwBuildNumber AND $FFFF ]);
// Check for Microsoft Plus!
If SystemParametersInfo ( SPI_GetWindowsExtension , 1 , Nil , 0 ) Then
ShowMessage ( 'PLUS! Installed' );
end ;
function GetCpuSpeed : Comp ;
{ function to return the CPU clock speed only. }
{ Usage: MessageDlg(Format('%.1f MHz', [GetCpuSpeed]), mtConfirmation, [mbOk], 0); }
var
t : DWORD ;
mhi , mlo , nhi , nlo : DWORD ;
t0 , t1 , chi , clo , shr32 : Comp ;
begin
shr32 := 65536 ;
shr32 := shr32 * 65536 ;
t := GetTickCount ;
while t = GetTickCount do begin end ;
asm
DB 0FH
DB 031H
mov mhi,edx
mov mlo,eax
end ;
while GetTickCount < ( t + 1000 ) do begin end ;
asm
DB 0FH
DB 031H
mov nhi,edx
mov nlo,eax
end ;
chi := mhi ;
if mhi < 0 then chi := chi + shr32 ;
clo := mlo ;
if mlo < 0 then clo := clo + shr32 ;
t0 := chi * shr32 + clo ;
chi := nhi ;
if nhi < 0 then chi := chi + shr32 ;
clo := nlo ;
if nlo < 0 then clo := clo + shr32 ;
t1 := chi * shr32 + clo ;
Result := ( t1 - t0 ) / 1E6 ;
end ;
procedure TForm1 . CPUButtonClick ( Sender : TObject );
begin
Edit1 . Text := FloatToStr ( GetCpuSpeed )+ ' MHz' ;
end ;
procedure TForm1 . Timer1Timer ( Sender : TObject );
begin
FlashWindow ( Handle , True );
end ;
procedure TForm1 . ResolutionClick ( Sender : TObject );
var
scrWidth ,
scrHeight : Integer ;
begin
scrWidth := GetSystemMetrics ( SM_CXSCREEN );
scrHeight := GetSystemMetrics ( SM_CYSCREEN );
ShowMessage ( 'Screen Resolution: (' +
IntToStr ( scrWidth )+
'x' +
IntToStr ( scrHeight )+
')' );
end ;
procedure TForm1 . HDSerialNoClick ( Sender : TObject );
var
SerialNum : DWord ;
a , b : dword ;
Buffer : array [ 0 .. 255 ] of char ;
Num : string ;
begin
GetVolumeInformation ( 'c:' , nil , 0 ,@ SerialNum , a , b , nil , 0 );
Num := IntToHex ( HiWord ( SerialNum ), 4 )+ '--' +
IntToHex ( LoWord ( SerialNum ), 4 );
Edit1 . Text := ( Num );
end ;
procedure TForm1 . CDROMClick ( Sender : TObject );
var
n : byte ;
drv : string ;
drives : set of 0 .. 25 ;
const
drt : array [ 0 .. 6 ] of string = ( 'Unknown' , 'Unknown' , 'Floppy Disk' , 'Local Drive' ,
'Network Drive' , 'CD-Rom' ,
'RAM-Disk' );
begin
integer ( drives ):= getlogicaldrives ;
for n := 0 to 25 do
if n in drives then begin
drv := char ( n + ord ( 'A' ))+ ':' ;
if ( drt [ getdrivetype ( pchar ( drv ))] = 'CD-Rom' ) then
Edit1 . Text := 'Drive ' + Drv + ' is the CD-Rom Drive' ;
end ;
end ;
procedure TForm1 . WaitExecClick ( Sender : TObject );
var
StartupInfo : TStartupinfo ;
ProcessInfo : TProcessInformation ;
begin
FillChar ( Startupinfo , Sizeof ( TStartupinfo ), 0 );
Startupinfo . cb := Sizeof ( TStartupInfo );
if CreateProcess ( nil , 'pbrush.exe' , nil , nil , false , normal_priority_class ,
nil , 'c:windows' , Startupinfo , ProcessInfo ) then
begin
WaitforSingleObject ( Processinfo . hProcess , infinite );
CloseHandle ( ProcessInfo . hProcess );
ShowMessage ( 'Program closed' );
end ;
end ;
procedure TForm1 . WinVer2Click ( Sender : TObject );
Var
OSVer : TOSVersionInfo ;
begin
OSVer . dwOSVersionInfoSize := SizeOf ( OSVer );
GetVersionEx ( OSVer );
If OSVer . dwPlatformID = VER_PLATFORM_WIN32_WINDOWS Then
Edit1 . Text := Format ( 'Microsoft Windows 95 ver %d.%d (Build %d)' ,
[OSVer . dwMajorVersion ,
OSVer . dwMinorVersion ,
OSVer . dwBuildNumber AND $FFFF ]);
// Check for Microsoft Plus!
If SystemParametersInfo ( SPI_GetWindowsExtension , 1 , Nil , 0 ) Then
ShowMessage ( 'PLUS! Installed' );
end ;
procedure TForm1 . FreeSpaceClick ( Sender : TObject );
Type
TDiskInfo = Record
SectorsPerCluster : DWORD ;
BytesPerSector : DWORD ;
FreeClusters : DWORD ;
NumClusters : DWORD ;
BytesTotal : DWORD ;
BytesFree : DWORD ;
End ;
var
DiskInfo : TDiskInfo ;
begin
With DiskInfo do
Begin
GetDiskFreeSpace ( 'c:' , SectorsPerCluster , BytesPerSector ,
FreeClusters , NumClusters );
BytesTotal := NumClusters * SectorsPerCluster * BytesPerSector ;
BytesFree := FreeClusters * SectorsPerCluster * BytesPerSector ;
Label1 . Caption := Format ( 'Sectors/Cluster : %d' , [ SectorsPerCluster ]);
Label2 . Caption := Format ( 'Bytes/Sector : %d' , [ BytesPerSector ]);
Label3 . Caption := Format ( 'Free Clusters : %d' , [ FreeClusters ]);
Label4 . Caption := Format ( 'Total Clusters : %d' , [ NumClusters ]);
Label5 . Caption := Format ( 'Total bytes : %d' , [ BytesTotal ]);
Label6 . Caption := Format ( 'Free bytes : %d' , [ BytesFree ]);
end ;
end ;
function DriveExists ( Drive : Byte ) : Boolean ;
begin
Result := Boolean ( GetLogicalDrives AND ( 1 SHL Drive ))
end ;
function DriveExists1 ( Drive : Byte ) : Boolean ;
var
LogDrives : set of 0 .. 25 ;
begin
Integer ( LogDrives ) := GetLogicalDrives ;
Result := Drive IN LogDrives ;
end ;
function CheckDriveType ( Drive : Byte ) : String ;
var
DriveLetter : Char ;
DriveType : UInt ;
begin
DriveLetter := Char ( Drive + $41 );
DriveType := GetDriveType ( PChar ( DriveLetter + ':' ));
Case DriveType of
0 : Result := '?' ;
1 : Result := 'Path does not exists' ;
DRIVE_REMOVABLE : Result := 'Removable' ;
DRIVE_FIXED : Result := 'Fixed' ;
DRIVE_REMOTE : Result := 'Remote' ;
DRIVE_CDROM : Result := 'CD-ROM' ;
DRIVE_RAMDISK : Result := 'RAMDISK'
Else
Result := 'Unknown' ;
end ;
end ;
{GetVolumeInformation}
function GetFileSysName ( Drive : Byte ) : String ;
var
DriveLetter : Char ;
NoMatter : Cardinal ;
FileSysName : Array [ 0 .. MAX_PATH ] of Char ;
begin
DriveLetter := Char ( Drive + $41 );
GetVolumeInformation ( PChar ( DriveLetter + ':' ), Nil ,
0 , nil , NoMatter , NoMatter , FileSysName ,
SizeOf ( FileSysName ));
Result := FileSysName ;
end ;
function GetVolumeName ( Drive : Byte ) : String ;
var
DriveLetter : Char ;
NoMatter : Cardinal ;
VolumeName : Array [ 0 .. MAX_PATH ] of Char ;
begin
DriveLetter := Char ( Drive + $41 );
GetVolumeInformation ( PChar ( DriveLetter + ':' ), VolumeName ,
SizeOf ( VolumeName ), nil , NoMatter , NoMatter , Nil , 0 );
Result := VolumeName ;
end ;
function GetVolumeFlags ( Drive : Byte ) : Integer ;
var
DriveLetter : Char ;
NoMatter : Cardinal ;
FileSysFlags : Cardinal ;
begin
DriveLetter := Char ( Drive + $41 );
GetVolumeInformation ( PChar ( DriveLetter + ':' ), nil , 0 ,
nil , FileSysFlags , NoMatter , Nil , 0 );
Result := FileSysFlags ;
end ;
procedure TForm1 . FormCreate ( Sender : TObject );
var
D : Byte ;
begin
Flash := False ;
For D := 0 to 25 do
If DriveExists ( D ) Then
Begin
ListBox1 . Items . Add ( Chr ( D + $41 ));
End ;
NextHandle := SetClipboardViewer ( handle );
end ;
procedure TForm1 . WMDRAWCLIPBOARD ( var Message : TMessage );
begin
{ Add code here to respond to the change }
sendmessage ( NextHandle , WM_DRAWCLIPBOARD , 0 , 0 );
end ;
procedure TForm1 . WMCHANGECBCHAIN ( var Message : TMessage );
begin
if Message. WParam = NextHandle then
begin
NextHandle := Message . LParam ;
end
else
begin
sendmessage ( NextHandle ,
WM_CHANGECBCHAIN ,
Message . WParam , // handle of window to remove
Message . LParam ); // handle of next window
end ;
end ;
procedure TForm1 . ListBox1Click ( Sender : TObject );
var
Drive : Byte ;
FileSysFlags : Integer ;
begin
Label1 . Caption := '' ; Label2 . Caption := '' ;
Label3 . Caption := '' ; Label4 . Caption := '' ;
With ListBox1 do
Drive := Ord ( Items [ ItemIndex ][ 1 ])- $41 ;
Label6 . Caption := GetFileSysName ( Drive );
FileSysFlags := GetVolumeFlags ( Drive );
If FS_CASE_IS_PRESERVED AND FileSysFlags <> 0 Then
Label1 . Caption := 'FS_CASE_IS_PRESERVED' ;
If FS_CASE_SENSITIVE AND FileSysFlags <> 0 Then
Label2 . Caption := 'FS_CASE_SENSITIVE' ;
If FS_UNICODE_STORED_ON_DISK AND FileSysFlags <> 0 Then
Label3 . Caption := 'FS_UNICODE_STORED_ON_DISK' ;
If FS_PERSISTENT_ACLS AND FileSysFlags <> 0 Then
Label4 . Caption := 'FS_PERSISTENT_ACLS'
end ;
procedure TForm1 . DriveComboBox1Change ( Sender : TObject );
var
CurDrive : Byte ;
FileSysFlags : Integer ;
begin
With DriveComboBox1 do
Begin
Label1 . Caption := '' ; Label2 . Caption := '' ;
Label3 . Caption := '' ; Label4 . Caption := '' ;
CurDrive := Ord ( Drive )- $41 ;
Label6 . Caption := GetFileSysName ( CurDrive );
FileSysFlags := GetVolumeFlags ( CurDrive );
If FS_CASE_IS_PRESERVED AND FileSysFlags <> 0 Then
Label1 . Caption := 'FS_CASE_IS_PRESERVED' ;
If FS_CASE_SENSITIVE AND FileSysFlags <> 0 Then
Label2 . Caption := 'FS_CASE_SENSITIVE' ;
If FS_UNICODE_STORED_ON_DISK AND FileSysFlags <> 0 Then
Label3 . Caption := 'FS_UNICODE_STORED_ON_DISK' ;
If FS_PERSISTENT_ACLS AND FileSysFlags <> 0 Then
Label4 . Caption := 'FS_PERSISTENT_ACLS'
end ;
end ;
procedure TForm1 . NewFontClick ( Sender : TObject );
var
Font : hFont ;
LogFont : TLogFont ;
F : TFont ;
begin
FillChar ( LogFont , SizeOf ( LogFont ), 0 );
With LogFont do
Begin
lfHeight := 40 ;
lfOrientation := 1800 ;
lfEscapement := 1800 ;
lfWeight := FW_BOLD ;
lfCharSet := Turkish_CHARSET ;
StrCopy ( lfFaceName , 'Times New Roman' );
End ;
Font := CreateFontIndirect ( LogFont );
F := TFont . Create ;
F . Handle := Font ;
Canvas . Font := F ;
Canvas . Brush . Color := Color ;
Canvas . TextOut ( 400 , 325 , 'Font Demo' );
F . Free ;
DeleteObject ( Font );
end ;
procedure TForm1 . MixerClick ( Sender : TObject );
var
Mixer : Byte ;
MXCaps : TMixerCaps ;
Version : DWORD ;
begin
Mixer := mixerGetNumDevs ;
If Mixer > 0 Then
Memo1 . Lines . Add ( Format ( 'Mixer devices : %d' , [ Mixer ]));
mixerGetDevCaps ( 0 , @ MXCaps , SizeOf ( MXCaps ));
With MXCaps do
Begin
Memo1 . Lines . Add ( szPName );
Version := vDriverVersion ;
Memo1 . Lines . Add ( Format ( 'Version : %d.%d' , [ Hi ( Version ), Lo ( Version )]));
End ;
end ;
procedure TForm1 . VideoClick ( Sender : TObject );
var
DC : THandle ; // Display context
Bits : Integer ; // Bits per pixel
HRes : Integer ; // Horizontal resolution
VRes : Integer ; // Vertical resolution
DM : TDevMode ; // To Save EnumDisplaySettings
ModeNum : LongInt ; // Video Mode Number
Ok : Bool ;
begin
// Get current video mode
// DC := GetDC(Handle);
DC := Canvas . Handle ;
Bits := GetDeviceCaps ( DC , BITSPIXEL );
HRes := GetDeviceCaps ( DC , HORZRES );
VRes := GetDeviceCaps ( DC , VERTRES );
Edit1 . Text := Format ( '%d bits, %d x %d' ,[ Bits , HRes , VRes ]);
// ReleaseDC(Handle, DC);
// Show all modes available (i.e. supported by the driver)
ModeNum := 0 ; // The 1st one
EnumDisplaySettings ( Nil , ModeNum , DM );
ListBox1 . Items . Add ( Format ( '%d bits, %d x %d' ,
[DM . dmBitsPerPel , DM . dmPelsWidth , DM . dmPelsHeight ]));
Ok := True ;
While Ok do
Begin
Inc ( ModeNum ); // Get next one
Ok := EnumDisplaySettings ( Nil , ModeNum , DM );
If Ok Then ListBox1 . Items . Add ( Format ( '%d bits, %d x %d' ,
[DM . dmBitsPerPel , DM . dmPelsWidth , DM . dmPelsHeight ]));
End ;
end ;
procedure TForm1 . memoryClick ( Sender : TObject );
begin
MemoryStatus . dwLength := SizeOf ( MemoryStatus );
GlobalMemoryStatus ( MemoryStatus );
With MemoryStatus do
Begin
dwTotalPhys := dwTotalPhys DIV 1024 ;
Label2 . Caption := 'Memory load : ' + IntToStr ( dwMemoryLoad );
Label3 . Caption := 'Total phys : ' + IntToStr ( dwTotalPhys );
Label4 . Caption := 'Avail phys : ' + IntToStr ( dwAvailPhys );
Label5 . Caption := 'Total Page File : ' + IntToStr ( dwTotalPageFile );
Label6 . Caption := 'Avail Page File : ' + IntToStr ( dwAvailPageFile );
Label7 . Caption := 'Total Virtual : ' + IntToStr ( dwTotalVirtual );
Label8 . Caption := 'Avail Virtual : ' + IntToStr ( dwAvailVirtual );
End ;
end ;
procedure TForm1 . MonitorClick ( Sender : TObject );
begin
// turn it off:
SendMessage ( Application . Handle , WM_SYSCOMMAND , SC_MONITORPOWER , 0 );
// turn it on again:
SendMessage ( Application . Handle , WM_SYSCOMMAND , SC_MONITORPOWER , - 1 );
end ;
procedure TForm1 . ShapeClick ( Sender : TObject );
VAR
h : THandle ;
begin
h := CreateEllipticRgn ( 0 , 0 , 600 , 600 );
SetWindowRgn ( Handle , h , TRUE );
end ;
procedure TForm1 . CloseFormClick ( Sender : TObject );
begin
Close ;
end ;
procedure TForm1 . NetMapClick ( Sender : TObject );
var
NRW : TNetResource ;
begin
with NRW do
begin
dwType := RESOURCETYPE_ANY ;
lpLocalName := 'X:' ; // map to this driver letter
lpRemoteName := 'MyServerMyDirectory' ;
// Must be filled in. If an empty string is used,
// it will use the lpRemoteName.
lpProvider := '' ;
end ;
WNetAddConnection2 ( NRW , 'MyPassword' , 'MyUserName' ,
CONNECT_UPDATE_PROFILE );
end ;
procedure TForm1 . HidetitleClick ( Sender : TObject );
begin
SetWindowLong ( Handle ,
GWL_STYLE ,
GetWindowLong ( Handle , GWL_STYLE )
and not WS_CAPTION );
ClientHeight := Height ;
end ;
procedure TForm1 . EnableStartBtnClick ( Sender : TObject );
begin
//Enable:
EnableWindow ( FindWindowEx ( FindWindow
( 'Shell_TrayWnd' , nil ), 0 , 'Button' , nil ), TRUE );
end ;
procedure TForm1 . DisableStartBtnClick ( Sender : TObject );
begin
//Disable:
EnableWindow ( FindWindowEx ( FindWindow
( 'Shell_TrayWnd' , nil ), 0 , 'Button' , nil ), FALSE );
end ;
procedure TForm1 . ShowTaskBarClick ( Sender : TObject );
begin
//To show the task bar use
ShowWindow ( FindWindow
( 'Shell_TrayWnd' , nil ), SW_SHOWNA );
end ;
procedure TForm1 . HideTaskBarClick ( Sender : TObject );
begin
//To hide the task bar use
ShowWindow ( FindWindow
( 'Shell_TrayWnd' , nil ), SW_HIDE );
end ;
procedure ChangeWallpaper ( bitmap : string );
{bitmap contains filename: *.bmp}
var
pBitmap : pchar ;
begin
bitmap := bitmap + #0 ;
pBitmap :=@ bitmap [ 1 ];
SystemParametersInfo ( SPI_SETDESKWALLPAPER , 0 , pBitmap , SPIF_UPDATEINIFILE );
end ;
procedure TForm1 . WallPaperClick ( Sender : TObject );
begin
ChangeWallpaper ( 'c:Bitmap1.bmp' ); {bitmap contains filename: *.bmp}
end ;
procedure TForm1 . ExploreClick ( Sender : TObject );
begin
with TDDEClientConv . Create ( Self ) do begin
ConnectMode := ddeManual ;
ServiceApplication := 'explorer.exe' ;
SetLink ( 'Folders' , 'AppProperties' );
OpenLink ;
ExecuteMacro
( '[FindFolder(, C:DelphiTips)]' , False );
CloseLink ;
Free ;
end ;
end ;
procedure TForm1 . NewHintClick ( Sender : TObject );
begin
Application . ShowHint := false ;
HintWindowClass := TMyHintWindow ;
Application . ShowHint := True ;
end ;
Function TForm1 . DelTree ( DirName : string ): Boolean ;
{
Completely deletes a directory regardless
of whether the directory is filled or has
subdirectories. No confirmation is requested
so be careful. If the operation is successful
then True is returned, False otherwise
}
var
SHFileOpStruct : TSHFileOpStruct ;
DirBuf : array [ 0 .. 255 ] of char ;
begin
try
Fillchar ( SHFileOpStruct , Sizeof ( SHFileOpStruct ), 0 );
FillChar ( DirBuf , Sizeof ( DirBuf ), 0 );
StrPCopy ( DirBuf , DirName );
with SHFileOpStruct do begin
Wnd := 0 ;
pFrom := @ DirBuf ;
wFunc := FO_DELETE ;
fFlags := FOF_ALLOWUNDO ;
fFlags := fFlags or FOF_NOCONFIRMATION ;
fFlags := fFlags or FOF_SILENT ;
end ;
Result := ( SHFileOperation ( SHFileOpStruct ) = 0 );
except
Result := False ;
end ;
end ;
{
Usage
if DelTree('c:TempDir') then
ShowMessage('Directory deleted!')
else
ShowMessage('Errors occured!');
}
procedure TForm1 . DelTreeBTNClick ( Sender : TObject );
begin
if DelTree ( 'c:New' ) then
ShowMessage ( 'Directory deleted!' )
else
ShowMessage ( 'Errors occured!' );
end ;
procedure FindAll ( const Path : String ;
Attr : Integer ;
List : TStrings );
var
Res : TSearchRec ;
EOFound : Boolean ;
begin
EOFound := False ;
if FindFirst ( Path , Attr , Res ) < 0 then
exit
else
while not EOFound do begin
List . Add ( Res . Name );
EOFound := FindNext ( Res ) <> 0 ;
end ;
FindClose ( Res );
end ;
{
The following example lists all files and
subdirectories of the C:Windows directory
into a TListBox called ListBox1:
FindAll('C:Windows*.*',faAnyFile,ListBox1.Items);
}
procedure TForm1 . FindAllBtnClick ( Sender : TObject );
begin
FindAll ( 'C:Windows*.*' , faAnyFile , ListBox1 . Items );
end ;
function RightStr ( Const Str : String ; Size : Word ): String ;
begin
if Size > Length ( Str ) then Size := Length ( Str );
RightStr := Copy ( Str , Length ( Str )- Size + 1 , Size )
end ;
function MidStr ( Const Str : String ; From , Size : Word ): String ;
begin
MidStr := Copy ( Str , From , Size )
end ;
function LeftStr ( Const Str : String ; Size : Word ): String ;
begin
LeftStr := Copy ( Str , 1 , Size )
end ;
{
Let's say we have a string
Dstr := 'Delphi is the BEST', then
LeftStr(Dstr, 5) := 'Delph'
MidStr(Dstr, 6, 7) := 'i is th'
RightStr(Dstr, 6) := 'e BEST'
}
Function StrReverse ( S : String ): String ;
Var
i : Integer ;
Begin
Result := '' ;
For i := Length ( S ) DownTo 1 Do
Begin
Result := Result + Copy ( S , i , 1 );
End ;
End ;
function SearchReplace ( sSrc , sLookFor , sReplaceWith : string ) : string ;
var
nPos , nLenLookFor : integer ;
begin
nPos := Pos ( sLookFor , sSrc );
nLenLookFor := Length ( sLookFor );
while ( nPos > 0 ) do begin
Delete ( sSrc , nPos , nLenLookFor );
Insert ( sReplaceWith , sSrc , nPos );
nPos := Pos ( sLookFor , sSrc );
end ;
Result := sSrc ;
end ;
{
Let's say you have a string
'testing;search;and;replace'
and you want to replace ';' with spaces.
Here's how you'd call this function
sOldString:='testing;search;and;replace';
sNewString:=SearchAndReplace(sOldString, ';', ' ')
}
procedure TForm1 . StrFuncsClick ( Sender : TObject );
var
s , Dstr : string ;
begin
dstr := 'My delphi sources' ;
Memo1 . Lines . Add ( LeftStr ( Dstr , 5 ));
Memo1 . Lines . Add ( MidStr ( Dstr , 6 , 7 ));
Memo1 . Lines . Add ( RightStr ( Dstr , 6 ));
Memo1 . Lines . Add ( StrReverse ( Dstr ));
s := 'testing;search;and;replace' ;
Memo1 . Lines . Add ( SearchReplace ( s , ';' , ' ' ));
end ;
procedure TForm1 . UpCaseBtnClick ( Sender : TObject );
var
GetString : string ;
GetLength : Integer ;
I : Integer ;
T : String ;
begin
if edit1 . SelLength > 0 then
GetString := Edit1 . Seltext
else GetString := Edit1 . Text ;
GetLength := Length ( Edit1 . Text );
if GetLength > 0 then begin
for I := 0 to GetLength do begin
if ( GetString [ I ] = ' ' ) or ( I = 0 ) then begin
if GetString [ I + 1 ] in [ 'a' .. 'z' ] then begin
T := GetString [ I + 1 ];
T := UpperCase ( T );
GetString [ I + 1 ]:= T [ 1 ];
end ;
end ;
end ;
if Edit1 . Sellength > 0 then
Edit1 . Seltext := GetString
else Edit1 . Text := GetString ;
end ;
end ;
// delete files to recyclebin
function FileDeleteRB ( FileName : string ): boolean ;
var
fos : TSHFileOpStruct ;
begin
FillChar ( fos , SizeOf ( fos ), 0 );
with fos do begin
wFunc := FO_DELETE ;
pFrom := PChar ( FileName );
fFlags := FOF_ALLOWUNDO
or FOF_NOCONFIRMATION
or FOF_SILENT ;
end ;
Result := ( ShFileOperation ( fos )= 0 );
end ;
procedure TForm1 . RBBtnClick ( Sender : TObject );
begin
FileDeleteRB ( 'C:MyFile.txt' );
end ;
// add docs to favorites
procedure TForm1 . AddDocsClick ( Sender : TObject );
begin
SHAddToRecentDocs ( SHARD_PATH , PChar ( 'c:win.ini' ));
end ;
// upcase first letter in an edit control
procedure TForm1 . IcoToBmpClick ( Sender : TObject );
var
Icon : TIcon ;
Bitmap : TBitmap ;
begin
Icon := TIcon . Create ;
Bitmap := TBitmap . Create ;
Icon . LoadFromFile ( 'c:projectsallprosB1.ico' );
Bitmap . Width := Icon . Width ;
Bitmap . Height := Icon . Height ;
Bitmap . Canvas . Draw ( 0 , 0 , Icon );
Bitmap . SaveToFile ( 'c:projectsallprospicture.bmp' );
Icon . Free ;
Bitmap . Free ;
end ;
procedure TForm1 . ExtractIcoClick ( Sender : TObject );
var
IconIndex : word ;
h : hIcon ;
begin
IconIndex := 0 ;
h := ExtractAssociatedIcon
( hInstance , 'C:WINDOWSNOTEPAD.EXE' , IconIndex );
DrawIcon ( Form1 . Canvas . Handle , 330 , 200 , h );
end ;
procedure TForm1 . DiskTypesClick ( Sender : TObject );
var
Drive : Char ;
DriveLetter : String [ 4 ];
begin
for Drive := 'A' to 'Z' do
begin
DriveLetter := Drive + ':' ;
case GetDriveType ( PChar ( Drive + ':' )) of
DRIVE_REMOVABLE :
Memo1 . Lines . Add ( DriveLetter + ' Floppy Drive' );
DRIVE_FIXED :
Memo1 . Lines . Add ( DriveLetter + ' Fixed Drive' );
DRIVE_REMOTE :
Memo1 . Lines . Add ( DriveLetter + ' Network Drive' );
DRIVE_CDROM :
Memo1 . Lines . Add ( DriveLetter + ' CD-ROM Drive' );
DRIVE_RAMDISK :
Memo1 . Lines . Add ( DriveLetter + ' RAM Disk' );
end ;
end ;
end ;
procedure ScreenShot ( DestBitmap : TBitmap );
var
DC : HDC ;
begin
DC := GetDC ( GetDesktopWindow );
try
DestBitmap . Width := GetDeviceCaps ( DC , HORZRES );
DestBitmap . Height := GetDeviceCaps ( DC , VERTRES );
BitBlt ( DestBitmap . Canvas . Handle ,
0 ,
0 ,
DestBitmap . Width ,
DestBitmap . Height ,
DC ,
0 ,
0 ,
SRCCOPY );
finally
ReleaseDC ( GetDesktopWindow , DC );
end ;
end ;
procedure TForm1 . ScreenShotBtnClick ( Sender : TObject );
begin
//creates a bitmap of screen
Bmp := TBitmap . Create ;
ScreenShot ( Bmp );
Bmp . SaveToFile ( 'C:ScreenShot.bmp' );
end ;
procedure TForm1 . UnTaskBarBtnClick ( Sender : TObject );
begin
//removes program icon from taskbar
ShowWindow ( Application . Handle , SW_HIDE );
SetWindowLong ( Application . Handle , GWL_EXSTYLE ,
getWindowLong ( Application . Handle , GWL_EXSTYLE ) or
WS_EX_TOOLWINDOW );
ShowWindow ( Application . Handle , SW_SHOW );
end ;
procedure TForm1 . ContentsClick ( Sender : TObject );
begin
//To Show window contents while dragging:
SystemParametersInfo
( SPI_SETDRAGFULLWINDOWS , 1 , nil , 0 );
end ;
procedure TForm1 . NoContentsClick ( Sender : TObject );
begin
//To disable this option call the function:
SystemParametersInfo
( SPI_SETDRAGFULLWINDOWS , 0 , nil , 0 );
end ;
procedure TForm1 . UpDateCurClick ( Sender : TObject );
begin
end ;
// delete a directory
procedure DelDir ( DirName : string );
var
SearchRec : TSearchRec ;
GotOne : integer ;
begin
GotOne := FindFirst ( DirName + '*.*' , faAnyFile , SearchRec );
while GotOne = 0 do
begin
if (( SearchRec . Attr and faDirectory ) = 0 ) then
DeleteFile ( DirName + '' + SearchRec . Name )
else if ( SearchRec . Name <> '.' ) and ( SearchRec . Name <> '..' ) then
DelDir ( DirName + '' + SearchRec . Name );
GotOne := FindNext ( SearchRec );
end ;
FindClose ( SearchRec );
end ;
procedure TForm1 . DelDirBtnClick ( Sender : TObject );
begin
DelDir ( 'C:New' );
{-I}
RmDir ( 'C:New' );
{+I}
if IOResult <> 0 then
raise Exception . Create ( 'Error removing directory' );
end ;
function DirSize ( Dir : string ): integer ;
var
DirBytes : integer ;
SearchRec : TSearchRec ;
Separator : string ;
begin
if Copy ( Dir , Length ( Dir ), 1 )= '' then
Separator := ''
else
Separator := '' ;
if FindFirst ( Dir + Separator + '*.*' , faAnyFile , SearchRec ) = 0 then begin
if FileExists ( Dir + Separator + SearchRec . Name ) then begin
DirBytes := DirBytes + SearchRec . Size ;
{Memo1.Lines.Add(Dir+Separator+SearchRec.Name);}
end else if DirectoryExists ( Dir + Separator + SearchRec . Name ) then begin
if ( SearchRec . Name <> '.' ) and ( SearchRec . Name <> '..' ) then begin
DirSize ( Dir + Separator + SearchRec . Name );
end ;
end ;
while FindNext ( SearchRec ) = 0 do begin
if FileExists ( Dir + Separator + SearchRec . Name ) then begin
DirBytes := DirBytes + SearchRec . Size ;
{Memo1.Lines.Add(Dir+Separator+SearchRec.Name);}
end else if DirectoryExists ( Dir + Separator + SearchRec . Name ) then
begin
if ( SearchRec . Name <> '.' ) and ( SearchRec . Name <> '..' ) then begin
DirSize ( Dir + Separator + SearchRec . Name );
end ;
end ;
end ;
end ;
FindClose ( SearchRec );
end ;
procedure TForm1 . DirSizeBtnClick ( Sender : TObject );
begin
Edit1 . Text := IntToStr ( DirSize ( 'c:' ));
end ;
procedure EmptyRecycleBin ;
const
SHERB_NOCONFIRMATION = $00000001 ;
SHERB_NOPROGRESSUI = $00000002 ;
SHERB_NOSOUND = $00000004 ;
type
TSHEmptyRecycleBin = function ( Wnd : HWND ; pszRootPath : PChar ; dwFlags : DWORD ) : HRESULT ; stdcall ;
var
SHEmptyRecycleBin : TSHEmptyRecycleBin ;
LibHandle : THandle ;
begin { EmptyRecycleBin }
LibHandle := LoadLibrary ( PChar ( 'Shell32.dll' )) ;
if LibHandle <> 0 then
@ SHEmptyRecycleBin := GetProcAddress ( LibHandle , 'SHEmptyRecycleBinA' )
else
begin
MessageDlg ( 'Failed to load Shell32.dll.' , mtError , [ mbOK ], 0 );
Exit ;
end ;
if @ SHEmptyRecycleBin <> nil then
SHEmptyRecycleBin ( Application . Handle ,
nil ,
SHERB_NOCONFIRMATION or SHERB_NOPROGRESSUI or SHERB_NOSOUND );
FreeLibrary ( LibHandle );
@ SHEmptyRecycleBin := nil ;
end ; { EmptyRecycleBin }
procedure TForm1 . EmptyRBClick ( Sender : TObject );
begin
EmptyRecycleBin
end ;
procedure TForm1 . WinClassClick ( Sender : TObject );
Var
ClassName : Array [ 0 .. 255 ] of Char ;
WinClass : TWndClass ;
begin
//1. Using GetClassName API function
GetClassName ( Handle , ClassName , 256 );
Edit1 . Text := StrPas ( ClassName );
//2.Using GetClassInfo API function
GetClassInfo ( Handle , ClassName , WinClass );
Edit2 . Text := StrPas ( WinClass . lpszClassName );
end ;
procedure TForm1 . SpeedIcoClick ( Sender : TObject );
var
Icon : TIcon ;
begin
Icon := TIcon . Create ;
Icon . Handle :=
ExtractIcon ( 0 ,
'C:WINDOWSNOTEPAD.EXE' ,
1 );
SpeedButton1 . Glyph . Width := Icon . Width ;
SpeedButton1 . Glyph . Height := Icon . Height ;
SpeedButton1 . Glyph . Canvas . Draw ( 0 , 0 , Icon );
Icon . Free ;
end ;
procedure TForm1 . ExecLinkClick ( Sender : TObject );
begin
ShellExecute ( handle ,
'Open' ,
'C:WINDOWSSTART MENUProgramlarBorland DELPHI 3Delphi 3.lnk' ,
nil ,
nil ,
SW_SHOWNORMAL );
end ;
procedure TForm1 . ClickClick ( Sender : TObject );
begin
//Some code goes here
ShowMessage ( 'This is my Onclick handler' );
end ;
procedure TForm1 . ClickMouseDown ( Sender : TObject ; Button : TMouseButton ;
Shift : TShiftState ; X , Y : Integer );
begin
ReleaseCapture ;
TWinControl ( Sender ). perform ( WM_SYSCOMMAND , $F012 , 0 );
end ;
procedure TForm1 . ParamsClick ( Sender : TObject );
var
i : integer ;
begin
for i := 1 to ParamCount do
ShowMessage ( ParamStr ( i ));
end ;
procedure CallBack ( Wnd : HWND ; uMsg : UINT ; lParam , lpData : LPARAM ) stdcall ;
Var S : String ;
begin
S := 'Choose folder for installation' ;
SendMessage ( Wnd , BFFM_SETSTATUSTEXT , 0 , LongInt (@ S [ 1 ]));
end ;
procedure TForm1 . SHBrowseClick ( Sender : TObject );
var
InfoType : Byte ;
BI : TBrowseInfo ;
S : PChar ;
Image : Integer ;
PIDL : PItemIDList ;
Path : Array [ 0 .. MAX_PATH - 1 ] of WideChar ;
ResPIDL : PItemIDList ;
begin
// Add ShlObj to uses clause
SHGetSpecialFolderLocation ( Handle , CSIDL_PROGRAMS , PIDL );
S := StrAlloc ( 128 );
With BI do
Begin
hwndOwner := Form1 . Handle ;
pszDisplayName := S ;
lpszTitle := 'Choose folder' ;
ulFlags := BIF_STATUSTEXT ;
pidlRoot := PIDL ;
lpfn := @ CallBack ;
iImage := Image ;
End ;
ResPIDL := SHBrowseForFolder ( BI );
SHGetPathFromIDList ( ResPIDL , @ Path [ 0 ]);
Edit1 . Text := StrPas (@ Path [ 0 ]);
StrDispose ( S );
end ;
procedure TForm1 . WinDirClick ( Sender : TObject );
var
WDir : PChar ;
PathLen : Word ;
begin
WDir := StrAlloc ( 144 );
PathLen := GetWindowsDirectory ( WDir , 144 );
Edit1 . Text :=( Wdir );
StrDispose ( WDir );
end ;
procedure TForm1 . WinExecBtnClick ( Sender : TObject );
begin
WinExec ( 'Command.com /c c:remaddr CN=' , sw_shownormal );
end ;
procedure TForm1 . AllVerClick ( Sender : TObject );
var
verInfo : TOSVERSIONINFO ;
str : String ;
I : Word ;
begin
verInfo . dwOSVersionInfoSize := SizeOf ( TOSVersionInfo );
if GetVersionEx ( verInfo ) then begin
Memo1 . Lines . Add ( IntToStr ( verInfo . dwOSVersionInfoSize ));
Memo1 . Lines . Add ( IntToStr ( verInfo . dwMajorVersion ));
Memo1 . Lines . Add ( IntToStr ( verInfo . dwMinorVersion ));
Memo1 . Lines . Add ( IntToStr ( verInfo . dwBuildNumber ));
case verInfo . dwPlatformId of
VER_PLATFORM_WIN32s : Memo1 . Lines . Add ( 'Win16 running Win32s' );
VER_PLATFORM_WIN32_WINDOWS : Memo1 . Lines . Add ( 'Win32 Windows, probably Win95' );
VER_PLATFORM_WIN32_NT : Memo1 . Lines . Add ( 'WinNT, full 32-bit' );
end ;
str := '' ;
for I := 0 to 127 do
str := str + verInfo . szCSDVersion [ I ];
Memo1 . Lines . Add ( str );
end
end ;
// Add JPEG to uses clause
procedure TForm1 . BmpToJpegClick ( Sender : TObject );
var
MyJPEG : TJPEGImage ;
MyBMP : TBitmap ;
begin
{ Convert a BMP to a JPEG }
MyBMP := TBitmap . Create ;
with MyBMP do
try
LoadFromFile ( 'Bmp1.BMP' );
MyJPEG := TJPEGImage . Create ;
with MyJPEG do begin
Assign ( MyBMP );
SaveToFile ( 'new.JPG' );
Free ;
end ;
finally
Free ;
end ;
end ;
// Add JPEG to uses clause
procedure TForm1 . JpegToBmpClick ( Sender : TObject );
var
MyJPEG : TJPEGImage ;
MyBMP : TBitmap ;
begin
{ Convert a JPEG to a BMP }
MyJPEG := TJPEGImage . Create ;
with MyJPEG do begin
LoadFromFile ( 'Jpeg1.JPG' );
MyBMP := TBitmap . Create ;
with MyBMP do begin
Width := MyJPEG . Width ;
Height := MyJPEG . Height ;
Canvas . Draw ( 0 , 0 , MyJPEG );
SaveToFile ( 'New.BMP' );
Free ;
end ;
Free ;
end ;
end ;
function TForm1 . LongIntToBinString ( BinValue : longint ) : string ;
var
i : integer ;
s : string ;
begin
s := '' ;
for i := 31 downto 0 do
if ( BinValue and ( 1 shl i )) <> 0 then
s := s + '1' else
s := s + '0' ;
Result := s ;
end ;
procedure TForm1 . IntToBinClick ( Sender : TObject );
begin
Memo1 . Lines . Add ( LongIntToBinString ( $FF ));
end ;
procedure TForm1 . Mouse1Click ( Sender : TObject );
begin
ShowMessage ( 'Mouse1 clicked' );
end ;
{The following example demonstrates using the Windows API
function mouse_event() to simulate a mouse event. When Button2
is clicked, the example code places the mouse over Button1 and
clicks it. Mouse Coordinates given are in "Mickeys", where
their are 65535 "Mickeys" to a screen's width.}
procedure TForm1 . Mouse2Click ( Sender : TObject );
var
Pt : TPoint ;
begin
{Allow Button2 to repaint it's self}
Application . ProcessMessages ;
{Get the point in the center of button 1}
Pt . x := Mouse1 . Left + ( Mouse1 . Width div 2 );
Pt . y := Mouse1 . Top + ( Mouse1 . Height div 2 );
{Convert Pt to screen coordinates}
Pt := ClientToScreen ( Pt );
{Convert Pt to mickeys}
Pt . x := Round ( Pt . x * ( 65535 / Screen . Width ));
Pt . y := Round ( Pt . y * ( 65535 / Screen . Height ));
{Move the mouse}
Mouse_Event ( MOUSEEVENTF_ABSOLUTE or
MOUSEEVENTF_MOVE ,
Pt . x ,
Pt . y ,
0 ,
0 );
{Simulate the left mouse button down}
Mouse_Event ( MOUSEEVENTF_ABSOLUTE or
MOUSEEVENTF_LEFTDOWN ,
Pt . x ,
Pt . y ,
0 ,
0 );;
{Simulate the left mouse button up}
Mouse_Event ( MOUSEEVENTF_ABSOLUTE or
MOUSEEVENTF_LEFTUP ,
Pt . x ,
Pt . y ,
0 ,
0 );;
end ;
{$IFOPT Q+}
{$DEFINE OVERFLOWSON}
{$Q-}
{$ENDIF}
function TForm1 . DWordToComp ( dw : longint ) : comp ;
var
c : comp ;
begin
if c >= 0 then
c := dw else begin
c := $7FFFFFFF ;
if dw = - 1 then
c := c + c + 1
else
c := c + abs ( $7FFFFFFF - dw );
end ;
result := c ;
end ;
{$IFDEF OVERFLOWSON}
{$UNDEF OVERFLOWSON}
{$Q+}
{$ENDIF}
procedure TForm1 . DWord2CompClick ( Sender : TObject );
begin
Edit1 . Text := FloatToStr ( DwordToComp ( 1239784 ));
end ;
{You must create two bitmaps, a mask bitmap (called the "AND"
bitmap) and a image bitmap (called the XOR bitmap). You can pass the
handles to the "AND" and "XOR" bitmaps to the Windows API function
CreateIconIndirect() and use the returned icon handle in your
application.}
procedure TForm1 . BmpToIcoClick ( Sender : TObject );
var
IconSizeX : integer ;
IconSizeY : integer ;
AndMask : TBitmap ;
XOrMask : TBitmap ;
IconInfo : TIconInfo ;
Icon : TIcon ;
begin
{Get the icon size}
IconSizeX := GetSystemMetrics ( SM_CXICON );
IconSizeY := GetSystemMetrics ( SM_CYICON );
{Create the "And" mask}
AndMask := TBitmap . Create ;
AndMask . Monochrome := true ;
AndMask . Width := IconSizeX ;
AndMask . Height := IconSizeY ;
{Draw on the "And" mask}
AndMask . Canvas . Brush . Color := clWhite ;
AndMask . Canvas . FillRect ( Rect ( 0 , 0 , IconSizeX , IconSizeY ));
AndMask . Canvas . Brush . Color := clBlack ;
AndMask . Canvas . Ellipse ( 4 , 4 , IconSizeX - 4 , IconSizeY - 4 );
{Draw as a test}
Image1 . Canvas . Draw ( IconSizeX * 2 , IconSizeY , AndMask );
{Create the "XOr" mask}
XOrMask := TBitmap . Create ;
XOrMask . Width := IconSizeX ;
XOrMask . Height := IconSizeY ;
{Draw on the "XOr" mask}
XOrMask . Canvas . Brush . Color := ClBlack ;
XOrMask . Canvas . FillRect ( Rect ( 0 , 0 , IconSizeX , IconSizeY ));
XOrMask . Canvas . Pen . Color := clRed ;
XOrMask . Canvas . Brush . Color := clRed ;
XOrMask . Canvas . Ellipse ( 4 , 4 , IconSizeX - 4 , IconSizeY - 4 );
{Draw as a test}
Image1 . Canvas . Draw ( IconSizeX * 4 , IconSizeY , XOrMask );
{Create a icon}
Icon := TIcon . Create ;
IconInfo . fIcon := true ;
IconInfo . xHotspot := 0 ;
IconInfo . yHotspot := 0 ;
IconInfo . hbmMask := AndMask . Handle ;
IconInfo . hbmColor := XOrMask . Handle ;
Icon . Handle := CreateIconIndirect ( IconInfo );
{Destroy the temporary bitmaps}
AndMask . Free ;
XOrMask . Free ;
{Draw as a test}
Image1 . Canvas . Draw ( IconSizeX , IconSizeY , Icon );
{Assign the application icon}
Application . Icon := Icon ;
{Force a repaint}
InvalidateRect ( Application . Handle , nil , true );
{Free the icon}
Icon . Free ;
end ;
procedure TForm1 . Timer2Timer ( Sender : TObject );
begin
FlashWindow ( Form1 . Handle , Flash );
FlashWindow ( Application . Handle , Flash );
Flash := not Flash ;
end ;
procedure TForm1 . ScrSaverClick ( Sender : TObject );
begin
// see the display properties-screensaver for effects
{Turn it off}
SystemParametersInfo ( SPI_SETSCREENSAVEACTIVE , 0 , nil , 0 );
{Turn it on}
SystemParametersInfo ( SPI_SETSCREENSAVEACTIVE , 1 , nil , 0 );
end ;
{ The following example disables the close button (and close
option from the system menu) of the given Window.}
procedure TForm1 . DisableCloseBtnClick ( Sender : TObject );
var
hwndHandle : THANDLE ;
hMenuHandle : HMENU ;
begin
hwndHandle := FindWindow ( nil , 'Form1' );
if ( hwndHandle <> 0 ) then begin
hMenuHandle := GetSystemMenu ( hwndHandle , FALSE );
if ( hMenuHandle <> 0 ) then
DeleteMenu ( hMenuHandle , SC_CLOSE , MF_BYCOMMAND );
end ;
end ;
{The following example demonstrates enumerating the communications
ports that are installed and listed in the Win32 registry.}
procedure TForm1 . CommPortsClick ( Sender : TObject );
var
// don't forget to add Registry to uses clause
reg : TRegistry ;
ts : TStrings ;
i : integer ;
begin
reg := TRegistry . Create ;
reg . RootKey := HKEY_LOCAL_MACHINE ;
reg . OpenKey ( 'hardwaredevicemapserialcomm' ,
false );
ts := TStringList . Create ;
reg . GetValueNames ( ts );
for i := 0 to ts . Count - 1 do begin
Memo1 . Lines . Add ( reg . ReadString ( ts . Strings [ i ]));
end ;
ts . Free ;
reg . CloseKey ;
reg . free ;
end ;
procedure TForm1 . ConnectedClick ( Sender : TObject );
begin
{ Edit1.Text:=TCP1.LocalIP;
if TCP1.LocalIp = '195.214.170.114' then
ShowMessage('You are connected!')
else
ShowMessage ('Your computer not Connected');}
end ;
procedure TForm1 . CompToIntegerClick ( Sender : TObject );
var
c : comp ;
i : integer ;
begin
c := $FFFFFF ;
// i := c; This won't work - incompatible types!
i := Trunc ( c ); // This works but has additional overhead;
//i := TLargeInteger(c).LowPart;
end ;
procedure TForm1 . Connected2Click ( Sender : TObject );
begin
if GetSystemMetrics ( SM_NETWORK ) AND $01 = $01 then
ShowMessage ( 'Machine is attached to network' ) else
ShowMessage ( 'Machine is not attached to network' );
end ;
// draws line on desktop
procedure TForm1 . DrawDesktopClick ( Sender : TObject );
var
dc : hdc ;
begin
dc := GetDc ( 0 );
MoveToEx ( Dc , 0 , 0 , nil );
LineTo ( Dc , 300 , 300 );
ReleaseDc ( 0 , Dc );
end ;
procedure TForm1 . ControlPanelClick ( Sender : TObject );
begin
WinExec ( 'C:WINDOWSCONTROL.EXE TIMEDATE.CPL' ,
sw_ShowNormal );
WinExec ( 'C:WINDOWSCONTROL.EXE MOUSE' ,
sw_ShowNormal );
WinExec ( 'C:WINDOWSCONTROL.EXE PRINTERS' ,
sw_ShowNormal );
end ;
procedure TForm1 . DiskInDriveClick ( Sender : TObject );
var
OldErrorMode : Integer ;
fp : TextFile ;
begin
try
OldErrorMode := SetErrorMode ( SEM_FAILCRITICALERRORS );
try
AssignFile ( fp , 'A:foo.bar' );
Reset ( fp );
CloseFile ( fp );
finally
SetErrorMode ( OldErrorMode );
end ;
except
on E : EInOutError do
if E . ErrorCode = 21 then
ShowMessage ( 'Drive A: is not ready...' );
end ;
end ;
// Add ClipBrd To uses clause then open a bitmap then select it then copy it
procedure TForm1 . LoadBlob1Click ( Sender : TObject );
var
C : TClipboard ;
begin
C := TClipboard . Create ;
try
if Clipboard . HasFormat ( CF_BITMAP ) then
DBImage1 . PasteFromClipboard
else
ShowMessage ( 'Clipboard does not contain a bitmap!' );
finally
C . Free ;
end ;
end ;
procedure TForm1 . LoadBlob3Click ( Sender : TObject );
var
B : TBitmap ;
begin
B := TBitmap . Create ;
try
B . LoadFromFile ( 'c:bmp.bmp' );
DBImage1 . Picture . Assign ( B );
finally
B . Free ;
end ;
end ;
procedure TForm1 . ControlPanel2Click ( Sender : TObject );
begin
// Run Only controlpanel
WinExec ( 'rundll32 shell32.dll,Control_RunDLL' , SW_SHOW );
//"Display Properties" - Background:
WinExec ( 'rundll32 shell32.dll,Control_RunDLL desk.cpl,,0' , SW_SHOW );
//"Display Properties" - Screen Saver:
WinExec ( 'rundll32 shell32.dll,Control_RunDLL desk.cpl,,1' , SW_SHOW );
//"Display Properties" - Appearance:
WinExec ( 'rundll32 shell32.dll,Control_RunDLL desk.cpl,,2' , SW_SHOW );
//"Display Properties" - Settings:
WinExec ( 'rundll32 shell32.dll,Control_RunDLL desk.cpl,,3' , SW_SHOW );
end ;
function TForm1 . HasCoProcesser : bool ;
{$IFDEF WIN32}
var
TheKey : hKey ;
{$ENDIF}
begin
Result := true ;
{$IFNDEF WIN32}
if GetWinFlags and Wf_80x87 = 0 then
Result := false ;
{$ELSE}
if RegOpenKeyEx ( HKEY_LOCAL_MACHINE ,
'HARDWAREDESCRIPTIONSystemFloatingPointProcessor' ,
0 ,
KEY_EXECUTE ,
TheKey ) <> ERROR_SUCCESS then result := false ;
RegCloseKey ( TheKey );
{$ENDIF}
end ;
procedure TForm1 . CoProcessorClick ( Sender : TObject );
begin
if HasCoProcesser then
ShowMessage ( 'Has CoProcessor' ) else
ShowMessage ( 'No CoProcessor - Windows Emulation Mode' );
end ;
procedure TForm1 . DialPhone2Click ( Sender : TObject );
var
PhoneNumber : string ;
CommPort : string ;
NumberWritten : Cardinal ;
begin
PhoneNumber := 'ATDT 1-555-555-1212' + #13 + #10 ;
CommPort := 'COM2' ;
{Open the comm port}
hCommFile := CreateFile ( PChar ( CommPort ),
GENERIC_WRITE ,
0 ,
nil ,
OPEN_EXISTING ,
FILE_ATTRIBUTE_NORMAL ,
0 );
if hCommFile = INVALID_HANDLE_VALUE then
begin
ShowMessage ( 'Unable to open ' + CommPort );
exit ;
end ;
{Dial the phone}
NumberWritten := 0 ;
if WriteFile ( hCommFile ,
PChar ( PhoneNumber )^,
Length ( PhoneNumber ),
NumberWritten ,
nil ) = false then begin
ShowMessage ( 'Unable to write to ' + CommPort );
end ;
end ;
procedure TForm1 . ClosePhoneClick ( Sender : TObject );
begin
{Close the port}
CloseHandle ( hCommFile );
end ;
procedure TForm1 . Username2Click ( Sender : TObject );
var
buffer : array [ 0 .. 255 ] of char ;
buffSize : DWORD ;
begin
buffSize := sizeOf ( buffer );
GetUserName (@ buffer , buffSize );
ShowMessage ( buffer );
end ;
procedure TForm1 . DialPhone ( PhoneNumber : string );
var
CommPort : string ;
NumberWritten : Cardinal ;
begin
PhoneNumber := 'ATDT' + Edit1 . Text + #13 + #10 ;
// enter the correct Com port number that your modem is connected
CommPort := 'COM3' ;
{Open the comm port}
hCommFile := CreateFile ( PChar ( CommPort ),
GENERIC_WRITE ,
0 ,
nil ,
OPEN_EXISTING ,
FILE_ATTRIBUTE_NORMAL ,
0 );
if hCommFile = INVALID_HANDLE_VALUE then
begin
ShowMessage ( 'Unable to open ' + CommPort );
exit ;
end ;
{Dial the phone}
NumberWritten := 0 ;
if WriteFile ( hCommFile ,
PChar ( PhoneNumber )^,
Length ( PhoneNumber ),
NumberWritten ,
nil ) = False then begin
ShowMessage ( 'Unable to write to ' + CommPort );
end ;
end ;
procedure TForm1 . DialPhoneNoClick ( Sender : TObject );
begin
//enter phone number in Edit1
//Don't forget to close phone by clicking closephone button
DialPhone ( Edit1 . Text );
end ;
procedure TForm1 . LoadBlob2Click ( Sender : TObject );
begin
// For this to work create a table with a graphic blob field
Table1Bitmap . LoadFromFile ( 'c:bmp.bmp' );
end ;
end .
