Tüm Dizi Kodları
Dizi Fonksiyonları
Diziler ile ilgili i ş leminizi kolay ve h ı zl ı yapabilmeniz i ç in , Delphi ' ye bir çok dizi fonksiyonu eklenmiştir. Aşagida bu fonksiyonlar sirasi ile incelenmekte olup, ardindan da örneklendirilmeleri yapilmiştir. Fonksiyonlarin kullanilabilmesi için uses satirina math kütüphanesini eklemeyi unutmayiniz.
Mean ( Dizi );
Parametre olarak girilen dizi elemanlarinin aritmetik ortalamasini hesaplayan bir fonksiyondur . Dizi degi ş keninin tipi ondalikli sayi tipinde olmalidir .
Procedure TForm1 . Button1Click ( Sender ; Object );
const
Dizi : Array [ 0 .. 3 ] of Double =( 10 , 20 , 30 , 40 ); // Tip ondalikli olmali
var
Sonuc : Extended ;
begin
Sonuc := Mean ( Dizi );
Caption := FloatToStr ( Sonuc ); // Elemanlarin aritmetik ortalamasini verir
end ;
Sum ( Dizi );
Parametre olarak diziye g ö nderilen elemanlarin toplamini hesaplayan bir fonksiyondur .
Procedure TForm1 . Button1Click ( Sender ; Object );
const
Dizi : Array [ 0 .. 3 ] of Double =( 10 , 20 , 30 , 40 ); // Tip ondalikli olmali
var
Sonuc : Extended ;
begin
Sonuc := Sum ( Dizi );
Caption := FloatToStr ( Sonuc ); // Elemanlarin toplamini verir
end ;
SumInt ( Dizi );
Parametre olarak girilen dizi elemanlarinin toplamini hesaplayan bir fonksiyondur . Burada dikkat edeceginiz husus , dizi elemanlarinin tam sayi tipli tanimlanmalari gerektigidir .
Procedure TForm1 . Button1Click ( Sender ; Object );
const
Dizi : Array [ 0 .. 3 ] of Integer =( 10 , 20 , 30 , 40 ); // Tip tam sayi olmali
var
Sonuc : Extended ;
begin
Sonuc := SumInt ( Dizi );
Caption := FloatToStr ( Sonuc ); // Elemanlarin toplamini verir
end ;
Bir ö nceki fonksiyon zaten bu i ş lemi kolayca yapar demeyin . Çü nk ü tam sayili i ş lemler ç ok daha hizli bir ş ekilde sonuca ula ş tirilirlar .
SumOfSquares ( Dizi );
Parametre olarak girilen dizi elemanlarinin karelerinin toplamini hesaplayan bir fonksiyondur .
Procedure TForm1 . Button1Click ( Sender ; Object );
const
Dizi : Array [ 0 .. 3 ] of Double =( 10 , 20 , 30 , 40 );
var
Sonuc : Extended ;
begin
Sonuc := SumOfSquares ( Dizi );
Caption := FloatToStr ( Sonuc ); // Elemanlarin karelerinin toplamini verir
end ;
Fonksiyondan geriye d ö nen deger ondalikli sayi olacagi i ç in , reel tip bir degi ş kene aktarilmalidir .
SumsAndSquares ( Dizi , Toplam , Kare_Toplam );
Birinci parametre ile girilen dizi degi ş keninin elemanlarinin toplamini ikinci parametreye , elemanlarinin karelerinin toplamini da üçü nc ü parametreye aktaran bir prosed ü rd ü r .
Procedure TForm1 . Button1Click ( Sender ; Object );
const
Dizi : Array [ 0 .. 3 ] of Double =( 10 , 20 , 30 , 40 );
var
Toplam , Kare_Toplam : Extended ;
begin
SumOfSquares ( Dizi , Toplam , Kare_Toplam );
Caption := 'Elemanların Toplamı : ' + FloatToStr ( Toplam )+ ' Elemanların Karelerinin Toplamı : ' + FloatToStr ( Kare_Toplam );
end ;
TotalVariance ( Dizi );
Dizi elemanlar ı na ait toplam varyans ı hesaplayan bir fonksiyondur .
Procedure TForm1 . Button1Click ( Sender ; Object );
const
Dizi : Array [ 0 .. 3 ] of Double =( 10 , 20 , 30 , 40 );
var
Sonuc : Extended ;
begin
Sonuc := TotalVariance ( Dizi );
Caption := FloatToStr ( Sonuc );
end ;
Variance ( Dizi );
Dizi elemanlar ı na ait varyans de ğ erini hesaplayan bir fonksiyondur .
Procedure TForm1 . Button1Click ( Sender ; Object );
const
Dizi : Array [ 0 .. 3 ] of Double =( 10 , 20 , 30 , 40 );
var
Sonuc : Extended ;
begin
Sonuc := Variance ( Dizi );
Caption := FloatToStr ( Sonuc );
end ;
EnsureRange ( K üçü k , Orta , B ü y ü k );
Parametre olarak girilen elemanlar aras ı nda ortanca de ğ ere sahip olan ı d ö nd ü ren bir fonksiyondur .
Procedure TForm1 . Button1Click ( Sender ; Object );
var
Sonuc : Extended ;
begin
Sonuc := EnsureRange ( 40 , 100 , 70 ); // Orta eleman
Caption := FloatToStr ( Sonuc ); // 70 yazar
end ;
High ( Dizi );
Parametre ile girilen dizinin en son eleman ı n ı n index numaras ı n ı d ö nd ü ren bir fonksiyondur .
Procedure TForm1 . Button1Click ( Sender ; Object );
const
Dizi : Array [ 0 .. 3 ] of Double =( 10 , 20 , 30 , 40 );
var
Sonuc : Integer ;
begin
Sonuc := High ( Dizi );
Caption := IntToStr ( Sonuc ); // 3 yazar
end ;
Ö rne ğ e dikkat edecek olursan ı z tan ı mlam ış oldu ğ unuz dizi de ğ i ş kenin en son eleman ı n ı n index numaras ı 3 t ü r . Bu de ğ eri öğ renmek i ç in kullanabilece ğ iniz ö nemli bir fonksiyondur . ( Bilhassa dinamik dizilerde kullan ı m ı zorunlu gibidir )
Low ( Dizi );
Parametre ile girilen dizinin ilk eleman ı n ı n index numaras ı n ı d ö nd ü ren bir fonksiyondur .
Procedure TForm1 . Button1Click ( Sender ; Object );
const
Dizi : Array [ 0 .. 3 ] of Double =( 10 , 20 , 30 , 40 );
var
Sonuc : Integer ;
begin
Sonuc := Low ( Dizi );
Caption := IntToStr ( Sonuc ); // 0 yazar
end ;
Dizinin ilk eleman ı ( dizi [ 0 ] ) 0 oldu ğ u i ç in , ö rne ğ imizde geriye d ö necek olan de ğ er 0 olacakt ı r .
A ş a ğı daki gibi bir ( veya benzeri bir durumda ) durumda bu iki fonksiyon sizin i ç in yararl ı olacakt ı r . S ı n ı f mevcudunun bilinmedi ğ i ( veya her s ı n ı f i ç in farkl ı oldu ğ u durumlarda ) dizinin ka ç eleman olaca ğı bilinmeyecek , ayn ı zamanda alt ve ü st s ı n ı rlar ı devaml ı olarak farkl ı olacakt ı r . Sabit de ğ erler yerine bu fonksiyonlar ı kullan ı rsan ı z her zaman do ğ ru sonu ç lara ula ş man ı z m ü mk ü n olacakt ı r .
Procedure TForm1 . Button1Click ( Sender ; Object );
var
Ogrenci : Array Of Integer ;
Mevcut , I : Integer ;
begin
Mevcut := StrToInt ( Inputbox ( 'Sınıf Mevcudunu Giriniz' , 'Mevcut' , '' ));
SetLength ( Ogrenci , Mevcut );
For I := Low ( Ogrenci ) To High ( Ogrenci ) Do // İlk ten son elemana kadar
Ogrenci [ i ] := StrToInt ( InputBox ( 'Notu Giriniz' , 'Not' , '' ));
end ;
Low ( Dizi );
Parametre ile girilen dizinin ilk eleman ı n ı n index numaras ı n ı d ö nd ü ren bir fonksiyondur .
Procedure TForm1 . Button1Click ( Sender ; Object );
const
Dizi : Array [ 0 .. 3 ] of Double =( 10 , 20 , 30 , 40 );
var
Sonuc : Integer ;
begin
Sonuc := Low ( Dizi );
Caption := IntToStr ( Sonuc ); // 0 yazar
end ;
Dizinin ilk eleman ı ( dizi [ 0 ] ) 0 oldu ğ u i ç in , ö rne ğ imizde geriye d ö necek olan de ğ er 0 olacakt ı r .
A ş a ğı daki gibi bir ( veya benzeri bir durumda ) durumda bu iki fonksiyon sizin i ç in yararl ı olacakt ı r . S ı n ı f mevcudunun bilinmedi ğ i ( veya her s ı n ı f i ç in farkl ı oldu ğ u durumlarda ) dizinin ka ç eleman olaca ğı bilinmeyecek , ayn ı zamanda alt ve ü st s ı n ı rlar ı devaml ı olarak farkl ı olacakt ı r . Sabit de ğ erler yerine bu fonksiyonlar ı kullan ı rsan ı z her zaman do ğ ru sonu ç lara ula ş man ı z m ü mk ü n olacakt ı r .
Procedure TForm1 . Button1Click ( Sender ; Object );
var
Ogrenci : Array Of Integer ;
Mevcut , I : Integer ;
begin
Mevcut := StrToInt ( Inputbox ( 'Sınıf Mevcudunu Giriniz' , 'Mevcut' , '' ));
SetLength ( Ogrenci , Mevcut );
For I := Low ( Ogrenci ) To High ( Ogrenci ) Do // İlk ten son elemana kadar
Ogrenci [ i ] := StrToInt ( InputBox ( 'Notu Giriniz' , 'Not' , '' ));
end ;
MaxIntValue ( Dizi );
Parametre olarak girilen dizi elemanlar ı i ç erisinde maximum de ğ eri bulabilen bir fonksiyondur . Dikkat edece ğ iniz husus dizi de ğ i ş kenin tam say ı tipli olmas ı gerekti ğ idir .
Procedure TForm1 . Button1Click ( Sender ; Object );
const
Dizi : Array [ 0 .. 3 ] of Integer =( 10 , 70 , 30 , 40 );
var
Sonuc : Integer ;
begin
Sonuc := MaxIntValue ( Dizi ); // En büyük değeri bul
Caption := IntToStr ( Sonuc ); // 70 yazar
end ;
MaxValue ( Dizi );
Yine parametre olarak girilen dizi elemanlar ı ndan en b ü y üğü n ü n de ğ erini d ö nd ü r ü r . Ü st ü nl üğü tam veya ondal ı kl ı say ı lar ı n ikisi i ç inde kullan ı labilmesidir .
Fonksiyondan geriye d ö necek olan de ğ er ondal ı kl ı say ı i ç erece ğ i i ç in FloatToStr tip d ö n üş t ü rme fonksiyonu sayesinde yazd ı r ı labilir .
Procedure TForm1 . Button1Click ( Sender ; Object );
const
Dizi : Array [ 0 .. 3 ] of Integer =( 10 , 20 , 30 , 40 );
var
Sonuc : Extended ;
begin
Sonuc := MaxValue ( Dizi );
Caption := FloatToStr ( Sonuc ); // 40 yazar
end ;
MinIntValue ( Dizi );
Parametre olarak girilen dizi elemanlar ı i ç erisinde minimum de ğ eri bulabilen bir fonksiyondur . Dikkat edece ğ iniz husus dizi de ğ i ş kenin tam say ı tipli olmas ı gerekti ğ idir .
Procedure TForm1 . Button1Click ( Sender ; Object );
const
Dizi : Array [ 0 .. 3 ] of Integer =( 10 , 70 , 30 , 40 );
var
Sonuc : Integer ;
begin
Sonuc := MinIntValue ( Dizi ); // En büyük değeri bul
Caption := IntToStr ( Sonuc ); // 10 yazar
end ;
MinValue ( Dizi );
Yine parametre olarak girilen dizi elemanlar ı ndan en k üçüğü n ü n de ğ erini d ö nd ü r ü r . Ü st ü nl üğü tam veya ondal ı kl ı say ı lar ı n ikisi i ç inde kullan ı labilmesidir .
Fonksiyondan geriye d ö necek olan de ğ er ondal ı kl ı say ı i ç erece ğ i i ç in FloatToStr tip d ö n üş t ü rme fonksiyonu sayesinde yazd ı r ı labilir .
Procedure TForm1 . Button1Click ( Sender ; Object );
const
Dizi : Array [ 0 .. 3 ] of Integer =( 10 , 20 , 30 , 40 );
var
Sonuc : Extended ;
begin
Sonuc := MinValue ( Dizi );
Caption := FloatToStr ( Sonuc ); // 10 yazar
end ;
Delphi - .....................................
Dosyayı programla ilişkilendirmek
Yaklaşı k 15 ayd ı r Neuron simulasyonu ile ilgili bir programla u ğ ra şı yorum . Bu programda yaz ı lan parametreleri
uzant ı s ı nmp olan bir dosyaya kaydedebiliyor ve daha ö nce kaydedilmi ş leri a ç abiliyorsunuz .
Program ı a ç madan windows da dosyan ı n ü zerine ç ift t ı klay ı nca programla beraber nas ı l a ç t ı rabilirim ?
Yani dpr dosyas ı n ı ç ift t ı klad ığı mda delphinin proje ile beraber a çı lmas ı gibi .
Bir de Teechart ile grafikler olu ş turuyorum . İ terasyon artt ı k ç a program ı n sistem Ram inde kaplad ığı
alan gittik ç e art ı yor . Bu bazen 200 MByte a kadar çı kabiliyor . Bunu nas ı l ö nleyebilirim .
Sayg ı lar ı mla ,
Kenan Zengin
Delphi - .....................................
Dosyayı programla ilişkilendirmek
Yaklaşı k 15 ayd ı r Neuron simulasyonu ile ilgili bir programla u ğ ra şı yorum . Bu programda yaz ı lan parametreleri
uzant ı s ı nmp olan bir dosyaya kaydedebiliyor ve daha ö nce kaydedilmi ş leri a ç abiliyorsunuz .
Program ı a ç madan windows da dosyan ı n ü zerine ç ift t ı klay ı nca programla beraber nas ı l a ç t ı rabilirim ?
Yani dpr dosyas ı n ı ç ift t ı klad ığı mda delphinin proje ile beraber a çı lmas ı gibi .
Bir de Teechart ile grafikler olu ş turuyorum . İ terasyon artt ı k ç a program ı n sistem Ram inde kaplad ığı
alan gittik ç e art ı yor . Bu bazen 200 MByte a kadar çı kabiliyor . Bunu nas ı l ö nleyebilirim .
Sayg ı lar ı mla ,
Kenan Zengin
Delphi - .....................................
Treeviewde Itemları Kalın Gosterme
uses
CommCtrl ;
procedure SetNodeBoldState ( Node : TTreeNode ; Value : Boolean );
var
TVItem : TTVItem ;
begin
if not Assigned ( Node ) then Exit ;
with TVItem do
begin
mask := TVIF_STATE or TVIF_HANDLE ;
hItem := Node . ItemId ;
stateMask := TVIS_BOLD ;
if Value then state := TVIS_BOLD
else
state := 0 ;
TreeView_SetItem ( Node . Handle , TVItem );
end ;
end ;
// Örnek olarak ilk satırı kalın yapalım
procedure TForm1 . Button1Click ( Sender : TObject );
begin
SetNodeBoldState ( TreeView1 . Items [ 0 ], True );
end ;
Delphi - .....................................
Treeviewde Itemları Kalın Gosterme
uses
CommCtrl ;
procedure SetNodeBoldState ( Node : TTreeNode ; Value : Boolean );
var
TVItem : TTVItem ;
begin
if not Assigned ( Node ) then Exit ;
with TVItem do
begin
mask := TVIF_STATE or TVIF_HANDLE ;
hItem := Node . ItemId ;
stateMask := TVIS_BOLD ;
if Value then state := TVIS_BOLD
else
state := 0 ;
TreeView_SetItem ( Node . Handle , TVItem );
end ;
end ;
// Örnek olarak ilk satırı kalın yapalım
procedure TForm1 . Button1Click ( Sender : TObject );
begin
SetNodeBoldState ( TreeView1 . Items [ 0 ], True );
end ;
Delphi - .....................................
yeter kardeşim (Dr. Kill haklısın)
'Kardeşim valla ben böyle işin ANASINI S.... bu nedir böyle
bende ilk geldi ğ imde bir kere yapt ı m ö z ü r dilerim ( ki diledim )
bu kadar da olmaz be karde ş im .
Delphi - .....................................
yeter kardeşim (Dr. Kill haklısın)
'Kardeşim valla ben böyle işin ANASINI S.... bu nedir böyle
bende ilk geldi ğ imde bir kere yapt ı m ö z ü r dilerim ( ki diledim )
bu kadar da olmaz be karde ş im .
Delphi - .....................................
DelphiForm Senin ............ KOYAYIM YETER LAN !!!!!!!!!
Lan kodbank ı kirlettin durdun sen ş erefsizmisin he utanm ı yormusun
haysiyetsiz kö pek ş erefsiz insan ...
Sen ne san ı yon kendini senin gibilerden
HAYVAN OLMAZ be!!! İ nsan de ğ ilsin sen
BÖ CEK S İ N anl ı yormusun .... İ nsanlar burda bir ş eyler
öğ reniyor sense hit kazanma ç abas ı nda iyiye kullan ı lan
bir program ı k ö t ü y ö nler i ç in kullan ı yorsun ..
Sana A çı k A çı k s ö yl ü yorum senin ANANIN .......... KOYAYIM anl ı yormusun .
Delphi - .....................................
DelphiForm Senin ............ KOYAYIM YETER LAN !!!!!!!!!
Lan kodbank ı kirlettin durdun sen ş erefsizmisin he utanm ı yormusun
haysiyetsiz kö pek ş erefsiz insan ...
Sen ne san ı yon kendini senin gibilerden
HAYVAN OLMAZ be!!! İ nsan de ğ ilsin sen
BÖ CEK S İ N anl ı yormusun .... İ nsanlar burda bir ş eyler
öğ reniyor sense hit kazanma ç abas ı nda iyiye kullan ı lan
bir program ı k ö t ü y ö nler i ç in kullan ı yorsun ..
Sana A çı k A çı k s ö yl ü yorum senin ANANIN .......... KOYAYIM anl ı yormusun .
Delphi - .....................................
Edit1 de yazdıgım metinleri listbox ta gösterebilme imkanım war mı?
Edit1 de yazdı g ı m metinleri listbox ta g ö sterebilme imkan ı m war m ı?
yani hatadan anlad ı g ı m kadar ı yla bir d ö n üş t ü r ü c ü las ı m
'inttostr' gibi bu konuda yard ı mc ı olursan ı z sevinirim . ve bu t ü r kodlar ı nerden bulabilirm ?
bende delphi ye yeni ba ş lad ı m . pascal da ba ş lam ı st ı m . Okul m ü fredat ı nda delphi olmad ı g ı i ç in ba ş lamam ı s ö ylediler .
eger yard ı mlar ı n ı z ı esirgemezseniz . te şş ek ü rler :)
Delphi - .....................................
Edit1 de yazdıgım metinleri listbox ta gösterebilme imkanım war mı?
Edit1 de yazdı g ı m metinleri listbox ta g ö sterebilme imkan ı m war m ı?
yani hatadan anlad ı g ı m kadar ı yla bir d ö n üş t ü r ü c ü las ı m
'inttostr' gibi bu konuda yard ı mc ı olursan ı z sevinirim . ve bu t ü r kodlar ı nerden bulabilirm ?
bende delphi ye yeni ba ş lad ı m . pascal da ba ş lam ı st ı m . Okul m ü fredat ı nda delphi olmad ı g ı i ç in ba ş lamam ı s ö ylediler .
eger yard ı mlar ı n ı z ı esirgemezseniz . te şş ek ü rler :)
Delphi - .....................................
yeter artık
(*
sende sıktın ama artık
bir şeyi 22 defa göndermenin ne anlamı var!!
kodbankı her güncellediğimde senin gönderilerini silmek zorundamıyım!!
anladık sitenin ismini buraya ekledikçe hit in artıyor ama
peşpeşe 9 kere göndermekte artık.....
*)
Delphi - .....................................
yeter artık
(*
sende sıktın ama artık
bir şeyi 22 defa göndermenin ne anlamı var!!
kodbankı her güncellediğimde senin gönderilerini silmek zorundamıyım!!
anladık sitenin ismini buraya ekledikçe hit in artıyor ama
peşpeşe 9 kere göndermekte artık.....
*)
Delphi - .....................................
SQL tırnak problemi
query1. sql . add ( '''' ); // komutu tek tırnak girecektir. (')
query1 . sql . add ( '''''' ); // bu komut ise 2 tırnak işareti girecektir. ('')
query1 . sql . add ( #39 ); //komutu tek tırnak girer
ö rnek : query1 . sql . add ( 'Where Adi = ''Ali'' ' );
yada
query1. sql . add ( 'Where Adi =' + #39 + 'Ali' + #39 );
yaz ı lan String i t ı rnak i ç ine alan bi komut vard ı onu hat ı rlam ı yorum .
yani tek t ı rnak yazd ı rmak i ç in iki tane t ı rnak i ş areti koyman ı z gerekiyor .
Delphi - .....................................
SQL tırnak problemi
query1. sql . add ( '''' ); // komutu tek tırnak girecektir. (')
query1 . sql . add ( '''''' ); // bu komut ise 2 tırnak işareti girecektir. ('')
query1 . sql . add ( #39 ); //komutu tek tırnak girer
ö rnek : query1 . sql . add ( 'Where Adi = ''Ali'' ' );
yada
query1. sql . add ( 'Where Adi =' + #39 + 'Ali' + #39 );
yaz ı lan String i t ı rnak i ç ine alan bi komut vard ı onu hat ı rlam ı yorum .
yani tek t ı rnak yazd ı rmak i ç in iki tane t ı rnak i ş areti koyman ı z gerekiyor .
Delphi - .....................................
tospaha reklamcı
ulan gezici git baska yerde yap suu reklamı n ı bir tane neyiyine yetmiyor
7 - 8 tane ayn ı seyi reklam atmak neyi çö z ü yor ....
git google kay ı t yap ibi şş
sizin yazd ı klar ı n ı z hep ay ı kl ı yorum yaa yeter at ı k yaa
kodlar
Delphi - .....................................
tospaha reklamcı
ulan gezici git baska yerde yap suu reklamı n ı bir tane neyiyine yetmiyor
7 - 8 tane ayn ı seyi reklam atmak neyi çö z ü yor ....
git google kay ı t yap ibi şş
sizin yazd ı klar ı n ı z hep ay ı kl ı yorum yaa yeter at ı k yaa
kodlar
Delphi - .....................................
HİZMETİNİZDEYİZ....www.delphiform.com
Delphi ile ilgili aradı klar ı n ı z bulamad ı klar ı n ı z .....
Advantage veri taban ı kesintisiz destek yard ı m merkezi ...
Advantage hakk ı nda öğ renmek istedikleriniz ...
advanatege veri taban ı kaynaklar ı ve dosyalar ı
www . delphiform . com adresinde bulacaks ı n ı z
e- mail : info @ delphiform . com
Delphi - .....................................
HİZMETİNİZDEYİZ....www.delphiform.com
Delphi ile ilgili aradı klar ı n ı z bulamad ı klar ı n ı z .....
Advantage veri taban ı kesintisiz destek yard ı m merkezi ...
Advantage hakk ı nda öğ renmek istedikleriniz ...
advanatege veri taban ı kaynaklar ı ve dosyalar ı
www . delphiform . com adresinde bulacaks ı n ı z
e- mail : info @ delphiform . com
Delphi - .....................................
HİZMETİNİZDEYİZ....www.delphiform.com
Delphi ile ilgili aradı klar ı n ı z bulamad ı klar ı n ı z .....
Advantage veri taban ı kesintisiz destek yard ı m merkezi ...
Advantage hakk ı nda öğ renmek istedikleriniz ...
advanatege veri taban ı kaynaklar ı ve dosyalar ı
www . delphiform . com adresinde bulacaks ı n ı z
e- mail : info @ delphiform . com
Delphi - .....................................
HİZMETİNİZDEYİZ....www.delphiform.com
Delphi ile ilgili aradı klar ı n ı z bulamad ı klar ı n ı z .....
Advantage veri taban ı kesintisiz destek yard ı m merkezi ...
Advantage hakk ı nda öğ renmek istedikleriniz ...
advanatege veri taban ı kaynaklar ı ve dosyalar ı
www . delphiform . com adresinde bulacaks ı n ı z
e- mail : info @ delphiform . com
Delphi - .....................................
SQL - Tekrarlanan Kayıtları Listeleme
Aynı kayd ı n birden fazla girildi ğ i durumlarda ,
bu kay ı tlar ı n listelenmesini ama ç layan SQL kodudur ...
____________________________________________________________
SELECT min ( mukod ), muad FROM musteri
WHERE ( muad IN ( SELECT muad
FROM musteri
GROUP BY muad
HAVING COUNT( muad ) > 1 )) GROUP BY muad
____________________________________________________________
Delphi - .....................................
SQL - Tekrarlanan Kayıtları Listeleme
Aynı kayd ı n birden fazla girildi ğ i durumlarda ,
bu kay ı tlar ı n listelenmesini ama ç layan SQL kodudur ...
____________________________________________________________
SELECT min ( mukod ), muad FROM musteri
WHERE ( muad IN ( SELECT muad
FROM musteri
GROUP BY muad
HAVING COUNT( muad ) > 1 )) GROUP BY muad
____________________________________________________________
Delphi - .....................................
Treeview in Combobox içinde gösterilmesi component
{
bu dosyayı dktreebox.pas olarak kaydedip component olarak ekleyebilirsiniz
}
unit dkTreeBox ;
interface
uses Classes , Graphics , {Types,} ComCtrls ,
Controls , Windows , SysUtils , Messages , Forms , ImgList ;
type
TdkTreeBox = class ;
TdkListView = class ( TCustomTreeView )
private
FEdit : TdkTreeBox ;
procedure WMKillFocus ( var Message : TMessage ); message WM_KILLFOCUS ;
protected
procedure MouseDown ( Button : TMouseButton ; Shift : TShiftState ;
X , Y : Integer ); override ;
procedure MouseMove ( Shift : TShiftState ; X , Y : Integer ); override ;
procedure KeyPress ( var Key : Char ); override ;
procedure CreateParams ( var Params : TCreateParams ); override ;
public
constructor Create ( AOwner : TComponent ); override ;
end ;
TdkTreeBox = class ( TCustomControl )
private
FPopupList : TdkListView ;
FListVisible : Boolean ;
FText : string ;
FButtonWidth : Integer ;
FPressed : Boolean ;
FHasFocus : Boolean ;
FAlignment : TAlignment ;
FOnDropDown : TNotifyEvent ;
FOnCloseUp : TNotifyEvent ;
procedure SetAlignment ( const Value : TAlignment );
procedure WMSetFocus ( var Message : TMessage ); message WM_SETFOCUS ;
procedure WMKillFocus ( var Message : TMessage ); message WM_KILLFOCUS ;
procedure SetOnCloseUp ( const Value : TNotifyEvent );
procedure SetOnDropDown ( const Value : TNotifyEvent );
function GetItems : TTreeNodes ;
procedure SetItems ( const Value : TTreeNodes );
function GetImages : TCustomImageList ;
function GetStateImages : TCustomImageList ;
procedure SetImages ( const Value : TCustomImageList );
procedure SetStateImages ( const Value : TCustomImageList );
function GetListHeight : Integer ;
procedure SetListHeight ( const Value : Integer );
protected
procedure KeyDown ( var Key : Word ; Shift : TShiftState ); override ;
procedure KeyUP ( var Key : Word ; Shift : TShiftState ); override ;
procedure KeyPress ( var Key : Char ); override ;
procedure MouseDown ( Button : TMouseButton ; Shift : TShiftState ;
X , Y : Integer ); override ;
procedure MouseMove ( Shift : TShiftState ; X , Y : Integer ); override ;
procedure MouseUp ( Button : TMouseButton ; Shift : TShiftState ;
X , Y : Integer ); override ;
procedure Paint ; override ;
procedure CreateParams ( var Params : TCreateParams ); override ;
procedure DropDown ; virtual ;
procedure CloseUp ( Accept : Boolean ); virtual ;
public
constructor Create ( AOwner : TComponent ); override ;
property Text : string read FText ;
published
property Alignment : TAlignment read FAlignment write SetAlignment ;
property OnDropDown : TNotifyEvent read FOnDropDown write SetOnDropDown ;
property OnCloseUp : TNotifyEvent read FOnCloseUp write SetOnCloseUp ;
property Items : TTreeNodes read GetItems write SetItems ;
property Images : TCustomImageList read GetImages write SetImages ;
property StateImages : TCustomImageList read GetStateImages write SetStateImages ;
property ListHeight : Integer read GetListHeight write SetListHeight ;
property Anchors ;
property BiDiMode ;
property Color ;
property Constraints ;
property Ctl3D ;
property DragCursor ;
property DragKind ;
property DragMode ;
property Enabled ;
property Font ;
property ImeMode ;
property ImeName ;
property ParentBiDiMode ;
property ParentColor ;
property ParentCtl3D ;
property ParentFont ;
property ParentShowHint ;
property PopupMenu ;
property ShowHint ;
property Visible ;
property OnClick ;
property OnContextPopup ;
property OnDragDrop ;
property OnDragOver ;
property OnEndDock ;
property OnEndDrag ;
property OnEnter ;
property OnExit ;
property OnKeyDown ;
property OnKeyPress ;
property OnKeyUp ;
property OnMouseDown ;
property OnMouseMove ;
property OnMouseUp ;
property OnStartDock ;
property OnStartDrag ;
end ;
procedure Register ;
implementation
{ TdkTreeBox }
procedure Register ;
begin
RegisterComponents ( 'Samples' ,[ TdkTreeBox ]);
end ;
procedure TdkTreeBox . CloseUp ( Accept : Boolean );
begin
SetFocus ;
if Accept and Assigned ( FPopupList . Selected ) then
FText := FPopupList . Selected . Text ;
SetWindowPos ( FPopupList . Handle , 0 , 0 , 0 , 0 , 0 , SWP_NOZORDER or
SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_HIDEWINDOW );
FListVisible := False ;
if Assigned ( FOnCloseUp ) then FOnCloseUp ( Self );
Repaint ;
end ;
constructor TdkTreeBox . Create ( AOwner : TComponent );
begin
inherited;
FButtonWidth := GetSystemMetrics ( SM_CXVSCROLL );
ControlStyle := ControlStyle + [ csReplicatable ];
if NewStyleControls then
ControlStyle := [ csOpaque ]
else
ControlStyle := [ csOpaque , csFramed ];
ParentColor := False ;
TabStop := True ;
FPopupList := TdkListView . Create ( Self );
FListVisible := False ;
FPopupList . HideSelection := True ;
Height := 24 ;
end ;
procedure TdkTreeBox . CreateParams ( var Params : TCreateParams );
begin
inherited CreateParams ( Params );
with Params do
if NewStyleControls and Ctl3D then
ExStyle := ExStyle or WS_EX_CLIENTEDGE
else
Style := Style or WS_BORDER ;
end ;
procedure TdkTreeBox . DropDown ;
var
P : TPoint ;
Y : Integer ;
begin
if Assigned ( FOnDropDown ) then FOnDropDown ( Self );
FPopupList . Color := Color ;
FPopupList . Font := Font ;
FPopupList . Width := Width ;
FListVisible := True ;
P := Parent . ClientToScreen ( Point ( Left , Top ));
Y := P . Y + Height ;
if Y + FPopupList . Height > Screen . Height then Y := P . Y - FPopupList . Height ;
SetWindowPos ( FPopupList . Handle , HWND_TOP , P . X , Y , 0 , 0 ,
SWP_NOSIZE or SWP_SHOWWINDOW );
FPopupList . Repaint ;
end ;
function TdkTreeBox . GetImages : TCustomImageList ;
begin
Result := FPopupList . Images ;
end ;
function TdkTreeBox . GetItems : TTreeNodes ;
begin
Result := FPopupList . Items ;
end ;
function TdkTreeBox . GetListHeight : Integer ;
begin
Result := FPopupList . Height ;
end ;
function TdkTreeBox . GetStateImages : TCustomImageList ;
begin
Result := FPopupList . StateImages ;
end ;
procedure TdkTreeBox . KeyDown ( var Key : Word ; Shift : TShiftState );
begin
inherited;
FPressed := True ;
Invalidate ;
if not FlistVisible then
DropDown
else
CloseUp ( False );
end ;
procedure TdkTreeBox . KeyPress ( var Key : Char );
begin
inherited;
end ;
procedure TdkTreeBox . KeyUP ( var Key : Word ; Shift : TShiftState );
begin
inherited;
Invalidate ;
end ;
procedure TdkTreeBox . MouseDown ( Button : TMouseButton ; Shift : TShiftState ; X ,
Y : Integer );
begin
inherited;
FPressed := True ;
Invalidate ;
if not FlistVisible then
DropDown
else
CloseUp ( False );
end ;
procedure TdkTreeBox . MouseMove ( Shift : TShiftState ; X , Y : Integer );
begin
inherited;
end ;
procedure TdkTreeBox . MouseUp ( Button : TMouseButton ; Shift : TShiftState ; X ,
Y : Integer );
begin
inherited;
Invalidate ;
end ;
procedure TdkTreeBox . Paint ;
var
W , X , Flags : Integer ;
Selected : Boolean ;
R : TRect ;
begin
Canvas . Font := Font ;
Canvas . Brush . Color := Color ;
if Enabled then
Canvas . Font . Color := Font . Color
else
Canvas . Font . Color := clGrayText ;
Selected := FHasFocus ;
if Selected then
begin
Canvas . Font . Color := clHighlightText ;
Canvas . Brush . Color := clHighlight ;
end ;
if ( csDesigning in ComponentState ) then
FText := Name ;
if UseRightToLeftAlignment then ChangeBiDiModeAlignment ( FAlignment );
W := ClientWidth - FButtonWidth ;
X := 2 ;
case Alignment of
taRightJustify : X := W - Canvas . TextWidth ( Text ) - 3 ;
taCenter : X := ( W - Canvas . TextWidth ( Text )) div 2 ;
end ;
SetRect ( R , 1 , 1 , W - 1 , ClientHeight - 1 );
if ( SysLocale . MiddleEast ) and ( BiDiMode = bdRightToLeft ) then
begin
Inc ( X , FButtonWidth );
Inc ( R . Left , FButtonWidth );
R . Right := ClientWidth ;
end ;
if SysLocale . MiddleEast then TControlCanvas ( Canvas ). UpdateTextFlags ;
Canvas . TextRect ( R , X , 2 , Text );
if Selected then Canvas . DrawFocusRect ( R );
SetRect ( R , W , 0 , ClientWidth , ClientHeight );
if ( SysLocale . MiddleEast ) and ( BiDiMode = bdRightToLeft ) then
begin
R . Left := 0 ;
R . Right := FButtonWidth ;
end ;
if not Enabled then
Flags := DFCS_SCROLLCOMBOBOX or DFCS_INACTIVE
else if FPressed then
Flags := DFCS_SCROLLCOMBOBOX or DFCS_FLAT or DFCS_PUSHED
else
Flags := DFCS_SCROLLCOMBOBOX ;
DrawFrameControl ( Canvas . Handle , R , DFC_SCROLL , Flags );
FPressed := False ;
end ;
procedure TdkTreeBox . SetAlignment ( const Value : TAlignment );
begin
FAlignment := Value ;
end ;
procedure TdkTreeBox . SetImages ( const Value : TCustomImageList );
begin
FPopupList . Images := Value ;
end ;
procedure TdkTreeBox . SetItems ( const Value : TTreeNodes );
begin
FPopupList . Items . Assign ( Value );
end ;
procedure TdkTreeBox . SetListHeight ( const Value : Integer );
begin
FPopupList . Height := Value ;
end ;
procedure TdkTreeBox . SetOnCloseUp ( const Value : TNotifyEvent );
begin
FOnCloseUp := Value ;
end ;
procedure TdkTreeBox . SetOnDropDown ( const Value : TNotifyEvent );
begin
FOnDropDown := Value ;
end ;
procedure TdkTreeBox . SetStateImages ( const Value : TCustomImageList );
begin
FPopupList . StateImages := Value ;
end ;
procedure TdkTreeBox . WMKillFocus ( var Message : TMessage );
begin
FHasFocus := False ;
inherited ;
if not FPopupList . Focused then CloseUp ( True );
end ;
procedure TdkTreeBox . WMSetFocus ( var Message : TMessage );
begin
FHasFocus := True ;
inherited ;
Invalidate ;
end ;
{ TdkListView }
constructor TdkListView . Create ( AOwner : TComponent );
begin
inherited Create ( AOwner );
FEdit := TdkTreeBox ( AOwner );
Parent := FEdit ;
Visible := False ;
ControlStyle := ControlStyle + [ csNoDesignVisible , csReplicatable ];
end ;
procedure TdkListView . CreateParams ( var Params : TCreateParams );
begin
inherited CreateParams ( Params );
with Params do
begin
Style := Style or WS_POPUP or WS_VSCROLL or WS_BORDER ;
ExStyle := WS_EX_TOOLWINDOW ;
AddBiDiModeExStyle ( ExStyle );
WindowClass . Style := CS_SAVEBITS ;
end ;
end ;
procedure TdkListView . KeyPress ( var Key : Char );
begin
inherited;
if ( Key = #13 ) or ( Key = #32 ) then FEdit . CloseUp ( True );
if Key = #27 then FEdit . CloseUp ( False );
end ;
procedure TdkListView . MouseDown ( Button : TMouseButton ; Shift : TShiftState ;
X , Y : Integer );
var
VNode : TTreeNode ;
VCanClose : Boolean ;
R : Trect ;
begin
inherited;
VNode := GetNodeAt ( x , y );
if Assigned ( VNode ) then
begin
R := VNode . DisplayRect ( True );
VCanClose := ( R . TopLeft . X < X ) and
( R . TopLeft . y < y );
if VCanClose then
FEdit . CloseUp ( True );
end ;
end ;
procedure TdkListView . MouseMove ( Shift : TShiftState ; X , Y : Integer );
begin
inherited;
Selected := GetNodeAt ( x , y );
end ;
procedure TdkListView . WMKillFocus ( var Message : TMessage );
begin
inherited;
try
FEdit . SetFocus ;
except
end;
end ;
end .
Delphi - .....................................
Outlook Klasörlerinin Listelenmesi
procedure TfrmMain . RetrieveOutlookFolders ( tvFolders : TTreeView );
procedure LoadFolder ( ParentNode : TTreeNode ; Folder : OleVariant );
var
i : Integer ;
node : TTreeNode ;
begin
for i := 1 to Folder . Count do
begin
node := tvFolders . Items . AddChild ( ParentNode , Folder . Item [ i ]. Name ;
LoadFolder ( node , Folder . Item [ i ]. Folders );
end ;
end ;
var
outlook , NameSpace : OLEVariant ;
begin
outlook := CreateOleObject ( 'Outlook.Application' );
NameSpace := outlook . GetNameSpace ( 'MAPI' );
LoadFolder ( nil , NameSpace . Folders );
outlook := UnAssigned ;
end ;
Delphi - .....................................
Outlook Klasörlerinin Listelenmesi
procedure TfrmMain . RetrieveOutlookFolders ( tvFolders : TTreeView );
procedure LoadFolder ( ParentNode : TTreeNode ; Folder : OleVariant );
var
i : Integer ;
node : TTreeNode ;
begin
for i := 1 to Folder . Count do
begin
node := tvFolders . Items . AddChild ( ParentNode , Folder . Item [ i ]. Name ;
LoadFolder ( node , Folder . Item [ i ]. Folders );
end ;
end ;
var
outlook , NameSpace : OLEVariant ;
begin
outlook := CreateOleObject ( 'Outlook.Application' );
NameSpace := outlook . GetNameSpace ( 'MAPI' );
LoadFolder ( nil , NameSpace . Folders );
outlook := UnAssigned ;
end ;
Delphi - .....................................
get the local DNS servers list?
unit iphlp ;
interface
uses Windows , System ;
const
MAX_HOSTNAME_LEN = 128 ;
MAX_DOMAIN_NAME_LEN = 128 ;
MAX_SCOPE_ID_LEN = 256 ;
type
//
// TIPAddressString - store an IP address or mask as dotted decimal string
//
PIPAddressString = ^ TIPAddressString ;
PIPMaskString = ^ TIPAddressString ;
TIPAddressString = record
_String : array [ 0 ..( 4 * 4 ) - 1 ] of Char ;
end ;
TIPMaskString = TIPAddressString ;
//
// TIPAddrString - store an IP address with its corresponding subnet mask,
// both as dotted decimal strings
//
PIPAddrString = ^ TIPAddrString ;
TIPAddrString = packed record
Next : PIPAddrString ;
IpAddress : TIPAddressString ;
IpMask : TIPMaskString ;
Context : DWORD ;
end ;
//
// FIXED_INFO - the set of IP-related information which does not depend on DHCP
//
PFixedInfo = ^ TFixedInfo ;
TFixedInfo = packed record
HostName : array [ 0 .. MAX_HOSTNAME_LEN + 4 - 1 ] of Char ;
DomainName : array [ 0 .. MAX_DOMAIN_NAME_LEN + 4 - 1 ] of Char ;
CurrentDnsServer : PIPAddrString ;
DnsServerList : TIPAddrString ;
NodeType : UINT ;
ScopeId : array [ 0 .. MAX_SCOPE_ID_LEN + 4 - 1 ] of Char ;
EnableRouting ,
EnableProxy ,
EnableDns : UINT ;
end ;
function GetNetworkParams ( pFixedInfo : PFixedInfo ; pOutBufLen : PULONG ): DWORD ; stdcall ;
// Get machine DNS Servers and return them in the provided StringList. This list should have been
// already created by the calling program before performing this call
procedure GetDNSServers ( AList : TStringList );
implementation
const
{$IFDEF MSWINDOWS}
iphlpapidll = 'iphlpapi.dll' ;
{$ENDIF}
function GetNetworkParams ; external iphlpapidll Name 'GetNetworkParams' ;
procedure GetDNSServers ( AList : TStringList );
var
pFI : PFixedInfo ;
pIPAddr : PIPAddrString ;
OutLen : Cardinal ;
begin
AList . Clear ;
OutLen := SizeOf ( TFixedInfo );
GetMem ( pFI , SizeOf ( TFixedInfo ));
try
if GetNetworkParams ( pFI , @ OutLen ) = ERROR_BUFFER_OVERFLOW then
begin
ReallocMem ( pFI , OutLen );
if GetNetworkParams ( pFI , @ OutLen ) <> NO_ERROR then Exit ;
end ;
// If there is no network available there may be no DNS servers defined
if pFI ^. DnsServerList . IpAddress . _String [ 0 ] = #0 then Exit ;
// Add first server
AList . Add ( pFI ^. DnsServerList . IpAddress . _String );
// Add rest of servers
pIPAddr := pFI ^. DnsServerList . Next ;
while Assigned ( pIPAddr ) do
begin
AList . Add ( pIPAddr ^. IpAddress . _String );
pIPAddr := pIPAddr ^. Next ;
end ;
finally
FreeMem ( pFI );
end ;
end ;
end .
Delphi - .....................................
get the local DNS servers list?
unit iphlp ;
interface
uses Windows , System ;
const
MAX_HOSTNAME_LEN = 128 ;
MAX_DOMAIN_NAME_LEN = 128 ;
MAX_SCOPE_ID_LEN = 256 ;
type
//
// TIPAddressString - store an IP address or mask as dotted decimal string
//
PIPAddressString = ^ TIPAddressString ;
PIPMaskString = ^ TIPAddressString ;
TIPAddressString = record
_String : array [ 0 ..( 4 * 4 ) - 1 ] of Char ;
end ;
TIPMaskString = TIPAddressString ;
//
// TIPAddrString - store an IP address with its corresponding subnet mask,
// both as dotted decimal strings
//
PIPAddrString = ^ TIPAddrString ;
TIPAddrString = packed record
Next : PIPAddrString ;
IpAddress : TIPAddressString ;
IpMask : TIPMaskString ;
Context : DWORD ;
end ;
//
// FIXED_INFO - the set of IP-related information which does not depend on DHCP
//
PFixedInfo = ^ TFixedInfo ;
TFixedInfo = packed record
HostName : array [ 0 .. MAX_HOSTNAME_LEN + 4 - 1 ] of Char ;
DomainName : array [ 0 .. MAX_DOMAIN_NAME_LEN + 4 - 1 ] of Char ;
CurrentDnsServer : PIPAddrString ;
DnsServerList : TIPAddrString ;
NodeType : UINT ;
ScopeId : array [ 0 .. MAX_SCOPE_ID_LEN + 4 - 1 ] of Char ;
EnableRouting ,
EnableProxy ,
EnableDns : UINT ;
end ;
function GetNetworkParams ( pFixedInfo : PFixedInfo ; pOutBufLen : PULONG ): DWORD ; stdcall ;
// Get machine DNS Servers and return them in the provided StringList. This list should have been
// already created by the calling program before performing this call
procedure GetDNSServers ( AList : TStringList );
implementation
const
{$IFDEF MSWINDOWS}
iphlpapidll = 'iphlpapi.dll' ;
{$ENDIF}
function GetNetworkParams ; external iphlpapidll Name 'GetNetworkParams' ;
procedure GetDNSServers ( AList : TStringList );
var
pFI : PFixedInfo ;
pIPAddr : PIPAddrString ;
OutLen : Cardinal ;
begin
AList . Clear ;
OutLen := SizeOf ( TFixedInfo );
GetMem ( pFI , SizeOf ( TFixedInfo ));
try
if GetNetworkParams ( pFI , @ OutLen ) = ERROR_BUFFER_OVERFLOW then
begin
ReallocMem ( pFI , OutLen );
if GetNetworkParams ( pFI , @ OutLen ) <> NO_ERROR then Exit ;
end ;
// If there is no network available there may be no DNS servers defined
if pFI ^. DnsServerList . IpAddress . _String [ 0 ] = #0 then Exit ;
// Add first server
AList . Add ( pFI ^. DnsServerList . IpAddress . _String );
// Add rest of servers
pIPAddr := pFI ^. DnsServerList . Next ;
while Assigned ( pIPAddr ) do
begin
AList . Add ( pIPAddr ^. IpAddress . _String );
pIPAddr := pIPAddr ^. Next ;
end ;
finally
FreeMem ( pFI );
end ;
end ;
end .
Delphi - .....................................
Programın/Dosyanın windows Default ikonunu bulup göstermek
{
orijinal kod
http://www.swissdelphicenter.ch/en/showcode.php?id=218
adresinden alınmıştır.
Fakat kod tam çalışmıyordu. Biraz değişiklik yaptım şuanda bütün dosyaların
ilişkili ikonlarını gösteriyor
}
unit Unit1 ;
interface
uses
Windows , Messages , SysUtils , Classes , Graphics , Controls , Forms , Dialogs ,
ExtCtrls , StdCtrls , FileCtrl , variants ;
type
TForm1 = class ( TForm )
Button1 : TButton ;
Image1 : TImage ;
Image2 : TImage ;
OpenDialog1 : TOpenDialog ;
procedure Button1Click ( Sender : TObject );
private
{ Private declarations }
public
{ Public declarations }
end ;
type
PHICON = ^ HICON ;
var
Form1 : TForm1 ;
PLargeIcon , PSmallIcon : phicon ;
implementation
uses shellapi , registry ;
{$R *.dfm}
procedure GetAssociatedIcon ( FileName : TFilename ; PLargeIcon , PSmallIcon : PHICON );
var
IconIndex : SmallInt ;
Icono : PHICON ;
FileExt , FileType : string ;
Reg : TRegistry ;
p : Integer ;
p1 , p2 : PChar ;
buffer : array [ 0 .. 255 ] of Char ;
Label
noassoc , NoSHELL ;
IconIndex := 0 ;
Icono := nil ;
// ;Get the extension of the file
FileExt := UpperCase ( ExtractFileExt ( FileName ));
//Eğer uzantı EXE veya ICO ise dosyadan alabiliriz
// aksi takdirde registry den almamız gerekiyor
if (( FileExt <> '.EXE' ) and ( FileExt <> '.ICO' )) and FileExists ( FileName ) then
begin
Reg := nil ;
try
Reg := TRegistry . Create ;
Reg . RootKey := HKEY_CLASSES_ROOT ;
if FileExt = '.EXE' then FileExt := '.COM' ;
if Reg . OpenKeyReadOnly ( FileExt ) then
try
FileType := Reg . ReadString ( '' );
finally
Reg . CloseKey ;
end ;
if ( FileType <> '' ) and Reg . OpenKeyReadOnly ( FileType + 'DefaultIcon' ) then
try
FileName := Reg . ReadString ( '' );
finally
Reg . CloseKey ;
end
else
if ( FileType <> '' ) and Reg . OpenKeyReadOnly ( FileType + 'ShellOpencommand' ) then
try
// bu kısım benim tarafımdan eklendir
// eğer default icon yok ise o dosyayı açan programın iconunu gösteriyor
FileName := Reg . ReadString ( '' );
delete ( filename , pos ( '"' , filename ), 1 );
if pos ( '"' , filename )> 0 then filename := copy ( filename , 1 , pos ( '"' , filename )- 1 );
if pos ( '%1' , filename )> 0 then filename := copy ( filename , 1 , pos ( '%1' , filename )- 1 );
finally
Reg . CloseKey ;
end ;
finally
Reg . Free ;
end ;
if FileName = '' then goto noassoc ;
p1 := PChar ( FileName );
p2 := StrRScan ( p1 , ',' );
if p2 <> nil then
begin
p := p2 - p1 + 1 ; // Position de la coma
IconIndex := StrToInt ( Copy ( FileName , p + 1 , Length ( FileName ) - p ));
SetLength ( FileName , p - 1 );
end ;
end ;
if ExtractIconEx ( PChar ( FileName ), IconIndex , Icono ^, PSmallIcon ^, 1 ) <> 1 then
begin
noassoc :
FileName := 'C:WindowsSystemSHELL32.DLL' ;
if not FileExists ( FileName ) then
begin
GetWindowsDirectory ( buffer , SizeOf ( buffer ));
FileName := FileSearch ( 'SHELL32.DLL' , GetCurrentDir + ';' + buffer );
if FileName = '' then
goto NoSHELL ;
end ;
if ( FileExt = '.DOC' ) then IconIndex := 1
else if ( FileExt = '.EXE' ) or ( FileExt = '.COM' ) then IconIndex := 2
else if ( FileExt = '.HLP' ) then IconIndex := 23
else if ( FileExt = '.INI' ) or ( FileExt = '.INF' ) then IconIndex := 63
else if ( FileExt = '.TXT' ) then IconIndex := 64
else if ( FileExt = '.BAT' ) then IconIndex := 65
else if ( FileExt = '.DLL' ) or ( FileExt = '.SYS' ) or ( FileExt = '.VBX' ) or
( FileExt = '.OCX' ) or ( FileExt = '.VXD' ) then IconIndex := 66
else if ( FileExt = '.FON' ) then IconIndex := 67
else if ( FileExt = '.TTF' ) then IconIndex := 68
else if ( FileExt = '.FOT' ) then IconIndex := 69
else
IconIndex := 0 ;
if ExtractIconEx ( PChar ( FileName ), IconIndex , Icono ^, PSmallIcon ^, 1 ) <> 1 then
begin
NoSHELL :
if PLargeIcon = nil then PLargeIcon ^ := 0 ;
if PSmallIcon = nil then PSmallIcon ^ := 0 ;
end ;
end ;
if PSmallIcon ^<> 0 then
begin
PLargeIcon ^ := ExtractIcon ( Application . Handle , PChar ( FileName ), IconIndex );
if PLargeIcon ^= Null then
PLargeIcon ^ := 0 ;
end ;
end ;
procedure TForm1 . Button1Click ( Sender : TObject );
var
SmallIcon , LargeIcon : HIcon ;
Icon : TIcon ;
begin
if not ( OpenDialog1 . Execute ) then
Exit ;
Icon := TIcon . Create ;
try
GetAssociatedIcon ( OpenDialog1 . FileName , @ LargeIcon , @ SmallIcon );
if LargeIcon <> 0 then
begin
Icon . Handle := LargeIcon ;
Image2 . Picture . icon := Icon ;
end ;
if SmallIcon <> 0 then
begin
Icon . Handle := SmallIcon ;
Image1 . Picture . icon := Icon ;
end ;
finally
Icon . Destroy ;
end ;
end ;
end .
Delphi - .....................................
