يافتن فايل در تمام شاخه و زير شاخه هايش:
يافتن فايل در تمام شاخه و زير شاخه هايش:
کد:
function FindFile(Path,Files:String):TStrings;
Var
Dirs,Fill:String;
IO,len,i:Integer;
Search:TsearchRec;
Begin
Result:=TStringList.Create;
If Path='' then exit;
//While Pos(';',files)>0 do
// Files[Pos(';',Files)]:=' '; //****
Dirs:='';
If Path[Length(Path)]='\' then
Delete(path,length(path),1);
Repeat
I:=Length(Files);
Repeat
Fill:='';
While (I>0) and (files[I]<>';') do //' ') do //******
Begin
Fill:=files[I]+Fill;
I:=i-1;
end;
I:=i-1;
IO:=findFirst(path+'\'+fill,faAnyFile-faDirectory,Search);
While Io=0 do
Begin
If (search.Name<>'.') and (search.name<>'..') then
Result.Add(path+'\'+Search.name);
IO:=FindNext(Search);
end;
FindClose(search);
until I<1;
IO:=FindFirst(Path+'\*.*',faAnyFile,Search);
While IO=0 do
Begin
If (search.Name<>'.') and (search.name<>'..') and (search.Attr and FaDirectory>0) then
Dirs:=Dirs+Path+'\'+Search.Name+#13;
Io:=FindNext(search);
end;
FindClose(search);
Len:=length(Dirs)-1;
Io:=len;
If Len>0 then
Begin
While (IO>0) and (Dirs[IO]<>#13) do Io:=IO-1;
Path:=Copy(Dirs,IO+1,Len-IO);
SetLength(Dirs,IO);
end;
Until(len<0);
end;
فرم شفاف شده و فقط کنترل ها نشان داده شود!:
فرم شفاف شده و فقط کنترل ها نشان داده شود!:
کد:
procedure TranparentForm(Form:Tform;HaveCaption,HaveMenu:Boolean);
var
frmRegion,
tempRegion:HRGN;
i:Integer;
Arect:Trect;
begin
frmRegion:=0;
For i:=0 to Form.controlcount -1 do
begin
Arect:=Form.controls[i].BoundsRect;
Offsetrect(Arect,Form.ClientOrigin.x-Form.left,Form.ClientOrigin.y-Form.top);
tempRegion:=CreateRectRgnIndirect(Arect);
if frmRegion=0 then
begin
frmRegion:=tempRegion;
end
else
Begin
CombineRgn(frmRegion,frmRegion,TempRegion,RGN_OR);
DeleteObject(tempRegion);
end;
end;
tempRegion:=0;
If HaveCaption and HaveMenu then
tempRegion:= CreateRectRgn(0,0,Form.Width,
GetSystemMetrics(SM_CYCAPTION)+
GetSystemMetrics(SM_CYSIZEFRAME)+
GetSystemMetrics(SM_CYMENU)*ORD(Form.Menu<>nil));
If (HaveCaption=false) and HaveMenu then
tempRegion:= CreateRectRgn(0,GetSystemMetrics(SM_CYCAPTION)+GetSystemMetrics(SM_CYSIZEFRAmE),Form.Width,
(GetSystemMetrics(SM_CYSIZEFRAmE)+GetSystemMetrics(SM_CYMENU)*ORD(Form.Menu<>nil))+GetSystemMetrics(SM_CYCAPTION));
If HaveCaption and (HaveMenu=false) then
tempRegion:= CreateRectRgn(0,0,Form.Width,
GetSystemMetrics(SM_CYCAPTION)+
GetSystemMetrics(SM_CYSIZEFRAmE));
If (HaveCaption=false) and (HaveMenu=false) then
tempRegion:= CreateRectRgn(0,0,Form.Width,0);
CombineRgn(frmregion,frmregion,tempregion,rgn_or);
Deleteobject(tempregion);
setwindowrgn(Form.handle,frmregion,true);
end;
مخفي و ظاهر ساختن عنوان فرم:
مخفي و ظاهر ساختن عنوان فرم:
کد:
Procedure Hide_ShowCaption(fForm:Tform;fHide:Boolean);
var
Save:LongInt;
Begin
If fform.BorderStyle=bsnone then exit;
Save:=GetWindowLong(fform.Handle,gwl_Style);
If Fhide then begin
If (Save and Ws_Caption )=ws_Caption then begin
Case fform.BorderStyle of
bsSizeable,
bsSingle:
SetWindowLong(fform.Handle,gwl_style,
save and (not (ws_Caption)) or ws_Border);
bsDialog:
SetWindowLong(fform.Handle,gwl_style,
save and (not (ws_Caption)) or DS_MODALFRAME or ws_DlgFrame);
end;
fform.Height:= fform.Height-GetSystemMetrics(sm_CyCaption);
fform.Refresh;
end;
end else begin
If (Save and Ws_Caption )=ws_Caption then begin
Case fform.BorderStyle of
bsSizeable,
bsSingle:
SetWindowLong(fform.Handle,gwl_style,
save or ws_Caption or ws_Border);
bsDialog:
SetWindowLong(fform.Handle,gwl_style,
save or ws_Caption or DS_MODALFRAME or ws_DlgFrame);
end;
fform.Height:= fform.Height+GetSystemMetrics(sm_CyCaption);
fform.Refresh;
end;
end;
end;
خذف يا انتقال فايل در حال اجرا توسط برنامه ديگر ( فقط در ويندوز نوع Nt):
خذف يا انتقال فايل در حال اجرا توسط برنامه ديگر ( فقط در ويندوز نوع NT):
کد:
function MoveDelFileReboot(Fileanme,New:String;fMove:Boolean=true):Boolean;
begin
If fMove then
result:=movefileEx(Pchar(Fileanme),Pchar(new),MoveFile_Replace_Existing or MoveFile_Delay_Until_Reboot)
else
Result:=movefileEx(Pchar(Fileanme),nil,MoveFile_Replace_Existing or MoveFile_Delay_Until_Reboot);
end;
فهميدن اينکه آيا يک ايميل از نظر املايي درست است يا نه!
فهميدن اينکه آيا يک ايميل از نظر املايي درست است يا نه!
کد:
Function IsValidMail(mail:string):Boolean;
var
i,Dot,AtSine:longInt;
tmpMail:string;
ch:char;
begin
result:=false;
If mail='' then exit;
tmpMail:=lowercase(mail);
AtSine:=pos('@',tmpMail);
Dot:=PosEx('.',tmpMail,atsine);
If Dot>AtSine then begin
for i:=1 to length(tmpMail) do begin
ch:=(tmpMail[i]);
If not( (ch in ['a'..'z']) or (ch in ['0'..'9']) or (ch in ['-','_','.']) ) then
begin
Result:=false;
Exit;
end;
end;
Result:=True;
end;
end;
حذف داده هاي تکراري از ليست:
حذف داده هاي تکراري از ليست:
کد:
Procedure RemoveDuplicateItem(SrcList,DestList:TStringList);
var
i:cardinal;
index:longint;
str:string;
begin
If not assigned(SrcList) then
SrcList := TStringList.Create;
If not assigned(DestList) then
DestList := TStringList.Create;
SrcList.Sort;
for i:=0 to SrcList.Count-1 do begin
str:=SrcList.Strings[i];
DestList.Sort;
index:=0;
If not DestList.Find(str,index) then begin
DestList.Insert(index,str);
end;
end;
end;
تقریبا کلیه فانکشن هایی که برای کار با فلاپی نیاز میشه ...
تقریبا کلیه فانکشن هایی که برای کار با فلاپی نیاز میشه ...
کد:
unit lDrives;
interface
uses Forms, Messages, Classes, WinProcs, WinTypes, SysUtils,
Dialogs, Controls;
const
MsgAskDefault = 'Please insert a disk on drive %s:';
MsgWProtected = 'Error: The disk %s is write-protected.';
type
TDriveType = (dtAll,dtFixed,dtRemovable,dtRemote{$IFDEF WIN32},dtCDRom,dtRamDisk{$ENDIF});
function ComposeFileName (Dir,Name:string):string;
function HasDiskSpace({$IFDEF WIN32}Drive: string{$ELSE}Drive: char{$ENDIF}; MinRequired: LongInt): boolean;
function GetDirectorySize(const Path: string): LongInt;
function GetFileSizeByName(const Filename: string): longInt;
function IsDiskRemovable(Drive: char): boolean;
function IsDiskInDrive(Drive: char): boolean;
function IsDiskWriteProtected(Drive: char): boolean;
function AskForDisk(Drive: char; Msg: string; CheckWriteProtected: boolean): boolean;
procedure GetAvailableDrives(DriveType: TDriveType; Items: TStrings);
implementation function ComposeFileName (Dir,Name:string):string;
var
Separator: string[1];
begin
if (length(Dir) > 0) and (Dir[length(Dir)]='\') then
delete(Dir, length(Dir), 1);
if (length(Name) > 0) and (Name[1]='\') then
delete(Name, 1, 1);
if Name='' then Separator:='' else Separator:='\';
result:=format('%s%s%s',[Dir,Separator,Name]);
end;
function HasDiskSpace(Drive: {$IFDEF WIN32}string{$ELSE}char{$ENDIF}; MinRequired: LongInt): boolean;
begin
if Drive='' then Drive:='C';
{$IFDEF WIN32}
result:=((GetDriveType(PChar(Drive))<>0) and
(SysUtils.DiskFree(Ord(UpCase(Drive[1]))-$40)=-1) or
(SysUtils.DiskFree(Ord(UpCase(Drive[1]))-$40)>=MinRequired));
{$ELSE}
result:=((GetDriveType(Ord(UpCase(Drive))-$40)<>0) and
(DiskFree(Ord(UpCase(Drive))-$40)=-1) or
(DiskFree(Ord(UpCase(Drive))-$40)>=MinRequired));
{$ENDIF}
end;
function GetDirectorySize(const Path: string): LongInt;
var
S: TSearchRec;
TotalSize: LongInt;
begin
TotalSize:=0;
if FindFirst(ComposeFileName(Path,'*.*'), faAnyFile, S)=0 then
repeat
Inc(TotalSize, S.Size);
until FindNext(S)<>0;
result:=TotalSize;
end;
function GetFileSizeByName(const Filename: string): longInt;
var
F: File;
begin
AssignFile(F, Filename);
Reset(F,1);
result:=FileSize(F);
CloseFile(F);
end;
function IsDiskRemovable(Drive: char): boolean;
begin
{$IFDEF WIN32}
result:=GetDriveType(PChar(Drive+':\'))=DRIVE_REMOVABLE;
{$ELSE}
result:=GetDriveType(ord(UpCase(Drive))-65)=DRIVE_REMOVABLE;
{$ENDIF}
end;
function IsDiskInDrive(Drive: char): Boolean;
var
ErrorMode: word;
begin
Drive:=Upcase(Drive);
if not (Drive in ['A'..'Z']) then
begin
Result:=False;
Exit;
end;
ErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
try
if DiskSize(Ord(Drive) - 64) = -1 then
Result := False
else
Result := True;
finally
SetErrorMode(ErrorMode);
end;
end;
function IsDiskWriteProtected(Drive: char): Boolean;
var
F: File;
ErrorMode: Word;
begin
ErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
AssignFile(F,Drive+':\_$.$ );
try
try
Rewrite(F);
CloseFile(F);
Erase(F);
Result:=False;
except
Result:=True;
end;
finally
SetErrorMode(ErrorMode);
end;
end;
{$IFDEF WIN32}
procedure GetAvailableDrives(DriveType: TDriveType; Items: TStrings);
var
Drive: Integer;
DriveLetter: string;
begin
Items.Clear;
for Drive := 0 to 25 do
begin
DriveLetter := Chr(Drive + ord('A'))+':\';
case DriveType of
dtAll : if GetDriveType(PChar(DriveLetter)) in [DRIVE_REMOVABLE,DRIVE_FIXED,DRIVE_REMOTE,
DRIVE_CDROM,DRIVE_RAMDISK] then
Items.Add(DriveLetter);
dtRemovable: if GetDriveType(PChar(DriveLetter))=DRIVE_REMOVABLE then
Items.Add(DriveLetter);
dtFixed : if GetDriveType(PChar(DriveLetter))=DRIVE_FIXED then
Items.Add(DriveLetter);
dtRemote : if GetDriveType(PChar(DriveLetter))=DRIVE_REMOTE then
Items.Add(DriveLetter);
dtCDRom : if GetDriveType(PChar(DriveLetter))=DRIVE_CDROM then
Items.Add(DriveLetter);
dtRamDisk : if GetDriveType(PChar(DriveLetter))=DRIVE_RAMDISK then
Items.Add(DriveLetter);
end;
end;
end;
{$ELSE}
procedure GetAvailableDrives(DriveType: TDriveType; Items: TStrings);
var
Drive: Integer;
DriveLetter: char;
begin
Items.Clear;
for Drive := 0 to 25 do
begin
DriveLetter := Chr(Drive + ord('A'));
case DriveType of
dtAll : if GetDriveType(Drive) in [DRIVE_REMOVABLE,DRIVE_FIXED,DRIVE_REMOTE] then
Items.Add(DriveLetter+':\');
dtRemovable: if GetDriveType(Drive)=DRIVE_REMOVABLE then
Items.Add(DriveLetter+':\');
dtFixed : if GetDriveType(Drive)=DRIVE_FIXED then
Items.Add(DriveLetter+':\');
dtRemote : if GetDriveType(Drive)=DRIVE_REMOTE then
Items.Add(DriveLetter+':\');
end;
end;
end;
{$ENDIF}
function AskForDisk(Drive: char; Msg: string; CheckWriteProtected: boolean): boolean;
var
Ready : boolean;
begin
Ready:=false; Result:=false;
if Msg='' then Msg:=Format(MsgAskDefault,[Drive]);
while not(Ready) do
try
if IsDiskRemovable(Drive) then
case MessageDlg(Msg, mtConfirmation, [mbOk,mbCancel],0) of
mrOk : ready:=IsDiskInDrive(Drive);
mrCancel: exit;
end
else
Ready:=true;
except
result:=false;
exit;
end;
ready:=false;
while not(Ready) do
try
if CheckWriteProtected and IsDiskWriteProtected(Drive) then
begin
ready:=false;
if MessageDlg(Format(MsgWProtected,[Upcase(Drive)+':']),mtError,[mbRetry,mbCancel],0)=mrCancel then
exit;
end
else
ready:=true;
except
result:=false;
exit;
end;
result:=Ready;
end;
end.
بدست آوردن پسورد فایلهای اکسس 97
کد:
Procedure GetMDB97PassWord;
Const
XorArr : Array[0..12] of Byte =
($86,$FB,$EC,$37,$5D,$44,$9C,$FA,$C6,$5E,$28,$E6,$13);
Var
I : Integer;
S1 : String;
FI : File of Byte;
By : Byte;
Access97 : Boolean;
FileError : Boolean;
Begin
// Init
FileError := False;
Access97 := True;
// Open *.mbd file
AssignFile(FI,Filename);
Reset(FI);
// Read file
I := 0;
Repeat
If not Eof(FI) then
Begin
Read(FI,By);
Inc(I);
End;
Until (I = $42) or Eof(FI);
If Eof(FI) then
FileError := True;
// Read password string
S1 := '';
For I := 0 to 12 do
If not Eof(FI) then
Begin
Read(f,By);
S1 := S1 + Chr(By);
End;
If Eof(FI) then
FileError := True;
//Close file
CloseFile(FI);
// Is nul string?
If S1 = #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 then
Access97 := False;
// Decode string
For I := 0 to 12 do
S1[I + 1] := Chr(Ord(S[I + 1]) xor XORArr[i]);
// Find end of string
I := Pos(#0,S1);
If I = 1 then
S1 := '';
If I > 1 then
S1 := Copy(S1,1,I);
If Access97 then
Begin
If Length(S1) > 0 then
ShowMessage := ('The password is: "' + S1 + '".')
else
ShowMessage ('The file is NOT password protected.');
End
else
ShowMessage('The file is not an Access 97 file.');
If FileError then
ShowMessage('File error');
End;
بدست آوردن و تنظیم کردن صدا در سیستم
بدست آوردن و تنظیم کردن صدا در سیستم
کد:
procedure GetVolume(var volL, volR: Word);
var
hWO: HWAVEOUT;
waveF: TWAVEFORMATEX;
vol: DWORD;
begin
volL:= 0;
volR:= 0;
// init TWAVEFORMATEX
FillChar(waveF, SizeOf(waveF), 0);
// open WaveMapper = std output of playsound
waveOutOpen(@hWO, WAVE_MAPPER, @waveF, 0, 0, 0);
// get volume
waveOutGetVolume(hWO, @vol);
volL:= vol and $FFFF;
volR:= vol shr 16;
waveOutClose(hWO);
end;
procedure SetVolume(const volL, volR: Word);
var
hWO: HWAVEOUT;
waveF: TWAVEFORMATEX;
vol: DWORD;
begin
// init TWAVEFORMATEX
FillChar(waveF, SizeOf(waveF), 0);
// open WaveMapper = std output of playsound
waveOutOpen(@hWO, WAVE_MAPPER, @waveF, 0, 0, 0);
vol:= volL + volR shl 16;
// set volume
waveOutSetVolume(hWO, vol);
waveOutClose(hWO);
end;