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 - .....................................
Registry'yi ve Ini Dosyalarını Yönetmek İçin Fonksiyonlar
Aşağıya yazdığım fonksiyon ve prosedürler, sık sık Registry ve Ini kullananların
kod yazmalarını hızlandırmak için tasarlandı. Önce örnek kullanım şekillerini
yazıyorum:
//..............................................................................
uses kısmına "Registry, IniFiles" eklemeyi unutmayın...
//..............................................................................
Örnek-1: Tek bir registry anahtarı okuyacaksanız;
const
SettingsRoot = HKEY_LOCAL_MACHINE;
SettingsKey = 'SoftwareDelphi TurkCodebank';
var
Version: String;
begin
Version := RegRead(nil, SettingsRoot, SettingsKey, 'Version', '3.1.0.0', rwtString);
end;
//..............................................................................
Örnek-2: Birden fazla registry anahtarı okuyacaksanız;
const
SettingsRoot = HKEY_LOCAL_MACHINE;
SettingsKey = 'SOFTWAREMicrosoftWindowsCurrentVersion';
var
Reg: TRegistry;
CommonFilesDir,
DevicePath,
MediaPath,
WallPaperDir: String;
begin
Reg := TRegistry.Create;
try
CommonFilesDir := RegRead(nil, SettingsRoot, SettingsKey, 'CommonFilesDir', '', rwtString);
DevicePath := RegRead(nil, SettingsRoot, SettingsKey, 'DevicePath', '', rwtString);
MediaPath := RegRead(nil, SettingsRoot, SettingsKey, 'MediaPath', '', rwtString);
WallPaperDir := RegRead(nil, SettingsRoot, SettingsKey, 'WallPaperDir', '', rwtString);
finally
Reg.Free;
end;
end;
//..............................................................................
FONKSİYON VE PROSEDÜR BİLDİRİMLERİ
//..............................................................................
type
TReadWriteType = (rwtString, rwtInteger, rwtBoolean);
procedure RegWrite(Reg: TRegistry; Root: DWORD; Key, Value: String;
Entry: Variant; WriteType: TReadWriteType; CreateIfNotExists:
Boolean = True);
function RegRead(Reg: TRegistry; Root: DWORD; Key, Value: String;
DefaultEntry: Variant; ReadType: TReadWriteType; CreateIfNotExists:
Boolean = True): Variant;
procedure IniWrite(Ini: TIniFile; FileName, Section, Ident: String; Value: Variant;
WriteType: TReadWriteType; CreateIfNotExists: Boolean = True);
function IniRead(Ini: TIniFile; FileName, Section, Ident: String; DefaultValue: Variant;
ReadType: TReadWriteType; CreateIfNotExists: Boolean = True): Variant;
//..............................................................................
FONKSİYON VE PROSEDÜR KOD LİSTESİ
//..............................................................................
procedure RegWrite(Reg: TRegistry; Root: DWORD; Key, Value: String;
Entry: Variant; WriteType: TReadWriteType; CreateIfNotExists: Boolean);
var
FreeOnExit: Boolean;
begin
FreeOnExit := Reg = nil;
if FreeOnExit then
Reg := TRegistry.Create;
try
Reg.RootKey := Root;
if Reg.OpenKey(Key, CreateIfNotExists) then
begin
case WriteType of
rwtString : Reg.WriteString(Value, Entry);
rwtInteger : Reg.WriteInteger(Value, Entry);
rwtBoolean : Reg.WriteBool(Value, Entry);
end;
end;
finally
if FreeOnExit then
Reg.Free;
end;
end;
//..............................................................................
function RegRead(Reg: TRegistry; Root: DWORD; Key, Value: String;
DefaultEntry: Variant; ReadType: TReadWriteType; CreateIfNotExists:
Boolean): Variant;
var
FreeOnExit: Boolean;
begin
FreeOnExit := Reg = nil;
if FreeOnExit then
Reg := TRegistry.Create;
try
Reg.RootKey := Root;
if Reg.OpenKey(Key, CreateIfNotExists) then
begin
if not Reg.ValueExists(Value) then
begin
RegWrite(nil, Root, Key, Value, DefaultEntry, ReadType);
Result := DefaultEntry;
end
else case ReadType of
rwtString : Result := Reg.ReadString(Value);
rwtInteger : Result := Reg.ReadInteger(Value);
rwtBoolean : Result := Reg.ReadBool(Value);
end;
end
finally
if FreeOnExit then
Reg.Free;
end;
end;
//..............................................................................
procedure IniWrite(Ini: TIniFile; FileName, Section, Ident: String; Value: Variant;
WriteType: TReadWriteType; CreateIfNotExists: Boolean);
var
FreeOnExit: Boolean;
begin
FreeOnExit := Ini = nil;
if FreeOnExit then
Ini := TIniFile.Create(FileName);
try
case WriteType of
rwtString : Ini.WriteString(Section, Ident, Value);
rwtInteger : Ini.WriteInteger(Section, Ident, Value);
rwtBoolean : Ini.WriteBool(Section, Ident, Value);
end;
finally
if FreeOnExit then
Ini.Free;
end;
end;
//..............................................................................
function IniRead(Ini: TIniFile; FileName, Section, Ident: String; DefaultValue: Variant;
ReadType: TReadWriteType; CreateIfNotExists: Boolean): Variant;
var
FreeOnExit: Boolean;
begin
FreeOnExit := Ini = nil;
if FreeOnExit then
Ini := TIniFile.Create(FileName);
try
if not (ini.SectionExists(Section) and ini.ValueExists(Section, Ident)) then
begin
IniWrite(nil, FileName, Section, Ident, DefaultValue, ReadType);
Result := DefaultValue;
end
else case ReadType of
rwtString : Result := Ini.ReadString(Section, Ident, DefaultValue);
rwtInteger : Result := Ini.ReadInteger(Section, Ident, DefaultValue);
rwtBoolean : Result := Ini.ReadBool(Section, Ident, DefaultValue);
end;
finally
if FreeOnExit then
Ini.Free;
end;
end;
//..............................................................................
Delphi - .....................................
Sn. Tansu Turkoglu'na acik mektup
Merhaba,
Yapmis oldugunuz bu guzel calismayi uzun bir suredir ben ve bircok
kisi kullaniyor. Yapilis amaci, dusuncesi cok guzel, orjinal bir
calisma imis.
Fakat artik bu proje amacindan "sapmis" hakkiyla takip edenlerin de
dedigi gibi artik burasi chat merkezi haline gelmis. Guzin abla nin
bir turevi haline gelmis.
Sizin is yogunlugunuzdan dolayi KodBank`a yeteri kadar vakit ayirmakta
zorlandiginizi tahmin ediyorum. En azindan siz ilgilenemeseniz de vakti
musait olan bir arkadasiniza veya KodBank`in saglam kullanicilarindan
birine (ben haric) yetki verip gereksiz notlarin silinmesini hatta
gerektiginde not sahiplerinin not yazma yetkisinin iptal edilmesi ve
hatta ilerleyen safhalarda site uyeliginin iptal edilmesi, banlanmasi
vs. gibi uygulamalarla buranin duzelecegini dusunuyorum.
Sizin de uzun ugraslar vererek yaptiginiz calismayi yarida birakarak
pejmurde bir halde kalmasina gonlunuzun razi olmayacagini dusunerek
bu acik mektubu yolluyorum...
Selamlar...
Ersin Kecis.
Delphi - .....................................
Sn. Tansu Turkoglu'na acik mektup
Merhaba,
Yapmis oldugunuz bu guzel calismayi uzun bir suredir ben ve bircok
kisi kullaniyor. Yapilis amaci, dusuncesi cok guzel, orjinal bir
calisma imis.
Fakat artik bu proje amacindan "sapmis" hakkiyla takip edenlerin de
dedigi gibi artik burasi chat merkezi haline gelmis. Guzin abla nin
bir turevi haline gelmis.
Sizin is yogunlugunuzdan dolayi KodBank`a yeteri kadar vakit ayirmakta
zorlandiginizi tahmin ediyorum. En azindan siz ilgilenemeseniz de vakti
musait olan bir arkadasiniza veya KodBank`in saglam kullanicilarindan
birine (ben haric) yetki verip gereksiz notlarin silinmesini hatta
gerektiginde not sahiplerinin not yazma yetkisinin iptal edilmesi ve
hatta ilerleyen safhalarda site uyeliginin iptal edilmesi, banlanmasi
vs. gibi uygulamalarla buranin duzelecegini dusunuyorum.
Sizin de uzun ugraslar vererek yaptiginiz calismayi yarida birakarak
pejmurde bir halde kalmasina gonlunuzun razi olmayacagini dusunerek
bu acik mektubu yolluyorum...
Selamlar...
Ersin Kecis.
Delphi - .....................................
İki image'i veya sound'u karşılaştıran DLL projesi ve yni KODBANK
//Herkese iyi çalışmalar. Sizlere iki image yada sound'u karşılaştıran ve analiz yapan bir DLL projesi gönderiyorum.
// Ve yeni bir kodbanksaı projesini bir kaç haftaya sizlere sunacağımı bildiriyorum.
//Muhammed KADEROĞLU (mkaderoglu@turksat.com.tr - maholight@msn.com - mkaderoglu@argecity.com)
//Şimdiden tüm arkadaşlara başarılar. Sorularınız ve önerileriniz için mail atabilirsiniz.
//(Söylemeden geçemeyeceğim NEOTURK dostum sonuna kadar arkandayım. Yapabileceğim bir şey olursa bana yaz.)
library Kontrol;
uses
Graphics,
math,
ExtCtrls,
messages,
dialogs,
Windows,
SysUtils,
Classes,
Controls;
type
TDInt = array of array of integer;
TDDbl = array of array of Double;
TQInt = array of integer;
TQDbl = array of Double;
{$R *.res}
function mov_filt (w_size:integer;input:TQDbl): TQDbl;export;
var
temp_array:TQDbl;
t_sum:double;
i,j:integer;
begin
SetLength(temp_array,Length(input));
for i:=(w_size-1) downto 0 do
begin
t_sum:=0;
j:=i;
while (j>=0) do
begin
t_sum:=t_sum+input[j];
j:=j-1;
end;
temp_array[i]:=t_sum/w_size;
end;
for i:=(w_size) to (Length(input)-1) do
begin
t_sum:=0;
j:=w_size-1;
while (j>=0) do
begin
t_sum:=t_sum+input[i-j];
j:=j-1;
end;
temp_array[i]:=t_sum/w_size;
end;
Result:= temp_array;
end;
function abs_max (input:TQDbl): double;export;
var
max,tmp:double;
i:integer;
begin
max:=0;
for i:=0 to (Length(input)-1) do
begin
tmp := Abs(input[i]);
if(tmp>max) then
max := tmp;
end;
Result:=max;
end;
function find_rms (input:TQDbl): double;export;
var
rms_val:double;
i:integer;
begin
rms_val:=0;
for i:=0 to (Length(input)-1) do
begin
rms_val:=rms_val+Sqr(input[i]);
end;
rms_val:=rms_val/Sqrt(Length(input));
Result:=rms_val;
end;
procedure sort(A : TQDbl);export;
var
tmp : Double;
size,k,i: integer;
begin
size := Length(A);
for i := 0 to size-1 do
begin
if A[i] > A[i-1] then Continue;
tmp := A[i];
k := i-1;
while (k>=0) and (A[k]>tmp) do
begin
A[k+1] := A[k];
k := k-1;
end;
A[k+1] := tmp;
end;
end;
function RgbToGray(RGBColor : TColor) : Double;export;
begin
Result := (0.299 * GetRValue(RGBColor)) +
(0.587 * GetGValue(RGBColor)) +
(0.114 * GetBValue(RGBColor));
end;
function GetGrayImage(Resim:Timage):TDDbl;export;
var
width,height:integer;
i,j:integer;
grayimage:TDDbl;
t1,t2 : double;
begin
width := Resim.Picture.Width;
height:= Resim.Picture.Height;
SetLength(grayimage,width,height);
for i:=0 to width-1 do
begin
for j:=0 to height-1 do
begin
t1 := RgbToGray(Resim.Canvas.Pixels[i,j]);
t2 := Floor(t1) + 0.5;
if (t1 > t2) then
grayimage[i,j] := Floor(t1) + 1
else
grayimage[i,j] := Floor(t1) ;
end;
end;
Result := grayimage;
end;
function image_test_21( im : TDDbl) : Double;export;
var
frame_width,err_threshold,blur_threshold,noise_count,tmp,L,W :integer;
threshold,med,dif,fnc,mu,distortion_ratio,cur_pix :Double;
med_array : TQDbl;
i,j :integer;
str : String;
begin
frame_width := 3;
threshold := 0.9;
err_threshold := 50;
blur_threshold:= 10;
noise_count := 0;
tmp := frame_width*frame_width;
SetLength(med_array,tmp);
L := Length(im[0]);
W := Length(im);
for i := 1 to W-2 do
begin
for j := 1 to L-2 do
begin
cur_pix := im[i,j];
med_array[0] := im[i-1,j-1];
med_array[1] := im[i-1,j];
med_array[2] := im[i-1,j+1];
med_array[3] := im[i+1,j-1];
med_array[4] := im[i+1,j];
med_array[5] := im[i+1,j+1];
med_array[6] := im[i,j-1];
med_array[7] := im[i,j+1];
med_array[8] := cur_pix;
Sort(med_array);
med := med_array[4];
dif := Abs(cur_pix-med);
fnc := (1-Exp(-dif))/(1+Exp(-dif));
if (fnc <= 0.5) then
begin
mu := 2*Sqr(fnc);
end
else
begin
mu := 1-2*Sqr(1-fnc);
end;
if (mu >= threshold) then
noise_count := noise_count+1;
end;
end;
distortion_ratio := (noise_count*100.0)/((W-2)*(L-2));
str := '';
if (distortion_ratio >= err_threshold) then
str := '-------------The image is noisy------------' + #13#10
else if (distortion_ratio <= blur_threshold) then
str := '-------------The image is blurred------------' + #13#10
else
str := '-------------The image is clear------------'+ #13#10;
str := str + #13#10 + 'Distortion ratio: ' + floattostr(distortion_ratio);
//ShowMessage(str);
Result := distortion_ratio;
end;
function sum2(input : TDDbl) : Double;export;
var
t_sum : double;
L,W,i,j : integer;
begin
L := Length(input[0]);
W := Length(input);
t_sum := 0;
for i := 0 to W-1 do
begin
for j := 0 to L-1 do
begin
t_sum := t_sum + input[i,j];
end;
end;
Result := t_sum;
end;
function ewise_product (input1 : TDDbl ; input2 : TDDbl) :TDDbl;export;
var
L,W,i,j : integer;
t_array : TDDbl;
begin
L := Length(input1[0]);
W := Length(input1);
SetLength(t_array,W,L);
for i := 0 to W-1 do
begin
for j := 0 to L-1 do
begin
t_array[i,j] := input1[i,j] * input2[i,j];
end;
end;
Result := t_array;
end;
function blank_screen_check(im1 : TDDbl;im2 : TDDbl) : Double;export;
var
L,W,i,j : integer;
t_res,mean1,mean2 : Double;
begin
L := Length(im1[0]);
W := Length(im1);
mean1 := sum2(im1) / L*W;
mean2 := sum2(im2) / L*W;
for i := 0 to W-1 do
begin
for j := 0 to L-1 do
begin
im1[i,j] := im1[i,j] - mean1;
im2[i,j] := im2[i,j] - mean2;
end;
end;
t_res := sum2(ewise_product(im1,im2)) / Sqrt(sum2(ewise_product(im1,im1))*sum2(ewise_product(im2,im2))) ;
Result := t_res;
end;
procedure sound_test(data : TQDbl);export;
var
window_size,err1_threshold,err2_threshold, sn_count, nos_count,i: integer;
no_sound_threshold,rms_data,nos_rate,sn_rate, threshold, threshold_ratio: double;
sample_filt: TQDbl;
print_string:string;
begin
window_size:=3;
sn_count:=0;
nos_count:=0;
threshold_ratio:=0.1;
SetLength(sample_filt,Length(data));
sample_filt:=mov_filt(window_size, data);
threshold:=abs_max(sample_filt)*threshold_ratio;
no_sound_threshold:=0.01;
err1_threshold:=10;
err2_threshold:=50;
rms_data:=find_rms(data);
for i:=0 to (Length(data)-1) do
begin
if (Abs(data[i]-sample_filt[i]) >= threshold) then
begin
sn_count:=sn_count+1;
end;
end;
for i:=0 to (Length(data)-1) do
begin
if (Abs(Abs(data[i])-rms_data) >= no_sound_threshold) then
begin
nos_count:=nos_count+1;
end;
end;
nos_rate:=(nos_count*100.0)/Length(sample_filt);
sn_rate:=(sn_count*100.0)/Length(sample_filt);
print_string:='*************************************'
+#13#10+ 'Noise rate : '+FormatFloat('0.000',sn_rate)+'%' +#13#10+
'Meaningful sound rate : '+FormatFloat('0.000',nos_rate)+'%';
if (sn_rate>=err1_threshold) then
print_string:=print_string+#13#10+'Error 1 : The sound is noisy!';
if (nos_rate<=err2_threshold) then
print_string:=print_string+#13#10+'Error 2 : No meaningful sound detected!';
ShowMessage(print_string);
end;
end.
Delphi - .....................................
İki image'i veya sound'u karşılaştıran DLL projesi ve yni KODBANK
//Herkese iyi çalışmalar. Sizlere iki image yada sound'u karşılaştıran ve analiz yapan bir DLL projesi gönderiyorum.
// Ve yeni bir kodbanksaı projesini bir kaç haftaya sizlere sunacağımı bildiriyorum.
//Muhammed KADEROĞLU (mkaderoglu@turksat.com.tr - maholight@msn.com - mkaderoglu@argecity.com)
//Şimdiden tüm arkadaşlara başarılar. Sorularınız ve önerileriniz için mail atabilirsiniz.
//(Söylemeden geçemeyeceğim NEOTURK dostum sonuna kadar arkandayım. Yapabileceğim bir şey olursa bana yaz.)
library Kontrol;
uses
Graphics,
math,
ExtCtrls,
messages,
dialogs,
Windows,
SysUtils,
Classes,
Controls;
type
TDInt = array of array of integer;
TDDbl = array of array of Double;
TQInt = array of integer;
TQDbl = array of Double;
{$R *.res}
function mov_filt (w_size:integer;input:TQDbl): TQDbl;export;
var
temp_array:TQDbl;
t_sum:double;
i,j:integer;
begin
SetLength(temp_array,Length(input));
for i:=(w_size-1) downto 0 do
begin
t_sum:=0;
j:=i;
while (j>=0) do
begin
t_sum:=t_sum+input[j];
j:=j-1;
end;
temp_array[i]:=t_sum/w_size;
end;
for i:=(w_size) to (Length(input)-1) do
begin
t_sum:=0;
j:=w_size-1;
while (j>=0) do
begin
t_sum:=t_sum+input[i-j];
j:=j-1;
end;
temp_array[i]:=t_sum/w_size;
end;
Result:= temp_array;
end;
function abs_max (input:TQDbl): double;export;
var
max,tmp:double;
i:integer;
begin
max:=0;
for i:=0 to (Length(input)-1) do
begin
tmp := Abs(input[i]);
if(tmp>max) then
max := tmp;
end;
Result:=max;
end;
function find_rms (input:TQDbl): double;export;
var
rms_val:double;
i:integer;
begin
rms_val:=0;
for i:=0 to (Length(input)-1) do
begin
rms_val:=rms_val+Sqr(input[i]);
end;
rms_val:=rms_val/Sqrt(Length(input));
Result:=rms_val;
end;
procedure sort(A : TQDbl);export;
var
tmp : Double;
size,k,i: integer;
begin
size := Length(A);
for i := 0 to size-1 do
begin
if A[i] > A[i-1] then Continue;
tmp := A[i];
k := i-1;
while (k>=0) and (A[k]>tmp) do
begin
A[k+1] := A[k];
k := k-1;
end;
A[k+1] := tmp;
end;
end;
function RgbToGray(RGBColor : TColor) : Double;export;
begin
Result := (0.299 * GetRValue(RGBColor)) +
(0.587 * GetGValue(RGBColor)) +
(0.114 * GetBValue(RGBColor));
end;
function GetGrayImage(Resim:Timage):TDDbl;export;
var
width,height:integer;
i,j:integer;
grayimage:TDDbl;
t1,t2 : double;
begin
width := Resim.Picture.Width;
height:= Resim.Picture.Height;
SetLength(grayimage,width,height);
for i:=0 to width-1 do
begin
for j:=0 to height-1 do
begin
t1 := RgbToGray(Resim.Canvas.Pixels[i,j]);
t2 := Floor(t1) + 0.5;
if (t1 > t2) then
grayimage[i,j] := Floor(t1) + 1
else
grayimage[i,j] := Floor(t1) ;
end;
end;
Result := grayimage;
end;
function image_test_21( im : TDDbl) : Double;export;
var
frame_width,err_threshold,blur_threshold,noise_count,tmp,L,W :integer;
threshold,med,dif,fnc,mu,distortion_ratio,cur_pix :Double;
med_array : TQDbl;
i,j :integer;
str : String;
begin
frame_width := 3;
threshold := 0.9;
err_threshold := 50;
blur_threshold:= 10;
noise_count := 0;
tmp := frame_width*frame_width;
SetLength(med_array,tmp);
L := Length(im[0]);
W := Length(im);
for i := 1 to W-2 do
begin
for j := 1 to L-2 do
begin
cur_pix := im[i,j];
med_array[0] := im[i-1,j-1];
med_array[1] := im[i-1,j];
med_array[2] := im[i-1,j+1];
med_array[3] := im[i+1,j-1];
med_array[4] := im[i+1,j];
med_array[5] := im[i+1,j+1];
med_array[6] := im[i,j-1];
med_array[7] := im[i,j+1];
med_array[8] := cur_pix;
Sort(med_array);
med := med_array[4];
dif := Abs(cur_pix-med);
fnc := (1-Exp(-dif))/(1+Exp(-dif));
if (fnc <= 0.5) then
begin
mu := 2*Sqr(fnc);
end
else
begin
mu := 1-2*Sqr(1-fnc);
end;
if (mu >= threshold) then
noise_count := noise_count+1;
end;
end;
distortion_ratio := (noise_count*100.0)/((W-2)*(L-2));
str := '';
if (distortion_ratio >= err_threshold) then
str := '-------------The image is noisy------------' + #13#10
else if (distortion_ratio <= blur_threshold) then
str := '-------------The image is blurred------------' + #13#10
else
str := '-------------The image is clear------------'+ #13#10;
str := str + #13#10 + 'Distortion ratio: ' + floattostr(distortion_ratio);
//ShowMessage(str);
Result := distortion_ratio;
end;
function sum2(input : TDDbl) : Double;export;
var
t_sum : double;
L,W,i,j : integer;
begin
L := Length(input[0]);
W := Length(input);
t_sum := 0;
for i := 0 to W-1 do
begin
for j := 0 to L-1 do
begin
t_sum := t_sum + input[i,j];
end;
end;
Result := t_sum;
end;
function ewise_product (input1 : TDDbl ; input2 : TDDbl) :TDDbl;export;
var
L,W,i,j : integer;
t_array : TDDbl;
begin
L := Length(input1[0]);
W := Length(input1);
SetLength(t_array,W,L);
for i := 0 to W-1 do
begin
for j := 0 to L-1 do
begin
t_array[i,j] := input1[i,j] * input2[i,j];
end;
end;
Result := t_array;
end;
function blank_screen_check(im1 : TDDbl;im2 : TDDbl) : Double;export;
var
L,W,i,j : integer;
t_res,mean1,mean2 : Double;
begin
L := Length(im1[0]);
W := Length(im1);
mean1 := sum2(im1) / L*W;
mean2 := sum2(im2) / L*W;
for i := 0 to W-1 do
begin
for j := 0 to L-1 do
begin
im1[i,j] := im1[i,j] - mean1;
im2[i,j] := im2[i,j] - mean2;
end;
end;
t_res := sum2(ewise_product(im1,im2)) / Sqrt(sum2(ewise_product(im1,im1))*sum2(ewise_product(im2,im2))) ;
Result := t_res;
end;
procedure sound_test(data : TQDbl);export;
var
window_size,err1_threshold,err2_threshold, sn_count, nos_count,i: integer;
no_sound_threshold,rms_data,nos_rate,sn_rate, threshold, threshold_ratio: double;
sample_filt: TQDbl;
print_string:string;
begin
window_size:=3;
sn_count:=0;
nos_count:=0;
threshold_ratio:=0.1;
SetLength(sample_filt,Length(data));
sample_filt:=mov_filt(window_size, data);
threshold:=abs_max(sample_filt)*threshold_ratio;
no_sound_threshold:=0.01;
err1_threshold:=10;
err2_threshold:=50;
rms_data:=find_rms(data);
for i:=0 to (Length(data)-1) do
begin
if (Abs(data[i]-sample_filt[i]) >= threshold) then
begin
sn_count:=sn_count+1;
end;
end;
for i:=0 to (Length(data)-1) do
begin
if (Abs(Abs(data[i])-rms_data) >= no_sound_threshold) then
begin
nos_count:=nos_count+1;
end;
end;
nos_rate:=(nos_count*100.0)/Length(sample_filt);
sn_rate:=(sn_count*100.0)/Length(sample_filt);
print_string:='*************************************'
+#13#10+ 'Noise rate : '+FormatFloat('0.000',sn_rate)+'%' +#13#10+
'Meaningful sound rate : '+FormatFloat('0.000',nos_rate)+'%';
if (sn_rate>=err1_threshold) then
print_string:=print_string+#13#10+'Error 1 : The sound is noisy!';
if (nos_rate<=err2_threshold) then
print_string:=print_string+#13#10+'Error 2 : No meaningful sound detected!';
ShowMessage(print_string);
end;
end.
Delphi - .....................................
