-
يافتن فايل در تمام شاخه و زير شاخه هايش:
يافتن فايل در تمام شاخه و زير شاخه هايش:
کد:
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;
-
ايجاد سايه در زير فرم ها
ايجاد سايه در زير فرم ها
کد:
type
Tform1 = class(TForm)
private
{ Private declarations }
Procedure CreateParams(Var Params: TCreateParams); override;
end;
implementation
{$R *.DFM}
procedure Tform1.CreateParams(var Params: TCreateParams);
begin
inherited;
if CheckWin32Version(5, 1) then
Params.WindowClass.Style := Params.WindowClass.style or CS_DROPSHADOW;
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;
-
چگونه دکمه Caps Lock را روشن و خاموش کنیم
چگونه دکمه Caps Lock را روشن و خاموش کنیم
ابتدا باید فانکشن را به این صورت تعریف کنید:
کد:
procedure SetCapsLockKey( vcode: Integer; down: Boolean );
begin
if Odd(GetAsyncKeyState( vcode )) <> down then
begin
keybd_event( vcode, MapVirtualkey( vcode, 0 ),
KEYEVENTF_EXTENDEDKEY, 0);
keybd_event( vcode, MapVirtualkey( vcode, 0 ),
KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP, 0);
end;
end;
سپس به این صورت از آن استفاده کنید:
کد:
SetCapsLockKey( VK_CAPITAL, True );
توجه:
فانکشن های 'keybd_event', 'MapVirtualkey' , 'GetAsyncKeyState از فانشکن های API ویندوز هستند ...
-
تشخیص نصب بودن یا نبودن کارت صدا ...
یکی از DLL های ویندوز به نام Winmm.dll دارای فانکشنی به نام waveOutGetNumDevs است که با استفاده از آن می توانید چک کنید کارت صدا در سیستم نصب شده است یا نه ...
ابتدا باید به این صورت تابع را تعریف کنید :
کد:
function IsSoundcardInstalled: longint; stdcall;
external 'winmm.dll'
name 'waveOutGetNumDevs';
و بدین صورت از آن استفاده کنید:
کد:
if IsSoundcardInstalled > 0 then
ShowMessage('Soundcard is there...');
-
چگونه می توان از جابجایی فرم جلوگیری کرد ...
چگونه می توان از جابجایی فرم جلوگیری کرد ...
کد:
type
TyourForm = class(TForm)
private
{ Private declarations }
procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
end;
procedure TyourForm.WMNCHitTest(var Message: TWMNCHitTest);
begin
inherited;
with Message do
if Result = HTCAPTION then
Result := HTNOWHERE;
end;
-
چگونه می توان RecycleBin را خالی کرد ...
چگونه می توان RecycleBin را خالی کرد ...
با استفاده از این کد می توانید سطل زباله ویندوز را خالی کنید ...
کد:
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;
-
فرمت کردن یک دریاو در win32
فرمت کردن یک دریاو در win32
کد:
const SHFMT_DRV_A = 0;
const SHFMT_DRV_B = 1;
const SHFMT_ID_DEFAULT = $FFFF;
const SHFMT_OPT_QUICKFORMAT = 0;
const SHFMT_OPT_FULLFORMAT = 1;
const SHFMT_OPT_SYSONLY = 2;
const SHFMT_ERROR = -1;
const SHFMT_CANCEL = -2;
const SHFMT_NOFORMAT = -3;
function SHFormatDrive(hWnd : HWND;
Drive : Word;
fmtID : Word;
Options : Word) : Longint
stdcall; external 'Shell32.dll' name 'SHFormatDrive';
procedure TForm1.Button1Click(Sender: TObject);
var
FmtRes : longint;
begin
try
FmtRes:= ShFormatDrive(Handle,
SHFMT_DRV_A,
SHFMT_ID_DEFAULT,
SHFMT_OPT_QUICKFORMAT);
case FmtRes of
SHFMT_ERROR : ShowMessage('Error formatting the drive');
SHFMT_CANCEL :
ShowMessage('User canceled formatting the drive');
SHFMT_NOFORMAT : ShowMessage('No Format')
else
ShowMessage('Disk has been formatted');
end;
except
end;
end;
-
ذخیره کردن یک فرم به عنوان یک عکس
کد:
bmp: TBitmap;
begin
bmp := TBitmap.Create;
bmp.Height := Form1.Height;
bmp.Width := Form1.Width;
DCWindow := GetWindowDC(Form1.Handle);
BitBlt(bmp.Canvas.Handle, 0, 0, Form1.Width, Form1.Height,
DCWindow, 0, 0, SRCCOPY);
bmp.SaveToFile('C:\ScreenShot.bmp');
ReleaseDC(DCWindow, DCWindow);
bmp.Free;
end;
-
Drop Dawn کردن آیتم های لیست باکس ...
Drop Dawn کردن آیتم های لیست باکس ...
کد:
var // form level
StartingPoint : TPoint;
implementation
...
procedure TForm1.FormCreate(Sender: TObject) ;
begin
ListBox1.DragMode := dmAutomatic;
end;
procedure TForm1.ListBox1DragDrop(Sender, Source: TObject; X, Y: Integer) ;
var
DropPosition, StartPosition: Integer;
DropPoint: TPoint;
begin
DropPoint.X := X;
DropPoint.Y := Y;
with Source as TListBox do
begin
StartPosition := ItemAtPos(StartingPoint,True) ;
DropPosition := ItemAtPos(DropPoint,True) ;
Items.Move(StartPosition, DropPosition) ;
end;
end;
procedure TForm1.ListBox1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean) ;
begin
Accept := Source = ListBox1;
end;
procedure TForm1.ListBox1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer) ;
begin
StartingPoint.X := X;
StartingPoint.Y := Y;
end;
-
نمایش صفحه مشخصات یک فایل ( Properties ) ...
نمایش صفحه مشخصات یک فایل ( Properties ) ...
یک Open Dialog و یک دکمه بر روی فرم بزارید ...
با کد زیر ، بعد از باز شدن فایل به وسیله Open Dialog و زدن دکمه پنجره خصوصیات فایل نشون داده می شه :
کد:
uses
shellapi;
procedure PropertiesDialog(FileName: string);
var
sei: TShellExecuteInfo;
begin
FillChar(sei, SizeOf(sei), 0);
sei.cbSize := SizeOf(sei);
sei.lpFile := PChar(FileName);
sei.lpVerb := 'properties';
sei.fMask := SEE_MASK_INVOKEIDLIST;
ShellExecuteEx(@sei);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if Opendialog1.Execute then
PropertiesDialog(Opendialog1.FileName);
end;
-
تابع زیر مشخص می کنه که سیستم متصل به انترنت هست یا نه
تابع زیر مشخص می کنه که سیستم متصل به انترنت هست یا نه
کد:
Compilers Delphi
Category Internet
Uses
Windows,
WinInet;
Function ConnectedToInternet:Boolean;
Var Flags : DWORD;
Begin
Flags :=INTERNET_CONNECTION_MODEM or INTERNET_CONNECTION_LAN or INTERNET_CONNECTION_PROXY;
Result:=InternetGetConnectedState(@Flags, 0);
End;
-
به دست آوردن نام کاربری
به دست اوردن نام کاربری
کد:
Uses
Windows,
SysUtils;
function GetUserName : String;
var
Name : PChar;
Size : DWORD;
begin
Size := SizeOf(ShortString);
GetMem(Name, Size);
try
GetUserName(Name, Size);
Result := Trim(StrPas(Name));
finally
FreeMem(Name, Size);
end;
end;
-
استخراج آیکون از فایل هایexe va dll
استخراج آیکون از فایل هایexe va dll
کد:
Uses
Windows,
Graphics,
ShellApi;
Procedure GetIcon(Filename,IconFilename:String;SmallIcon:Boolean);
Var
HIcon32 ,
HIcon16 : HIcon;
Icon : tIcon;
Begin
ExtractIconEx(Pchar(Filename),0,HIcon32,HIcon16,1);
If (HIcon16<>0) and SmallIcon then
Begin
Icon:=tIcon.Create;
Icon.handle:=HIcon16;
Icon.SaveToFile(IconFilename);
Icon.Free;
end else
If (HIcon32<>0) and not SmallIcon then
Begin
Icon:=tIcon.Create;
Icon.handle:=HIcon32;
Icon.SaveToFile(IconFilename);
Icon.Free;
end;
End;
-
این تابع برنامه مورد نظر را اجر میکند و تا زمان خاتمه آن منتظر میماند.
این تابع برنامه مورد نظر را اجر میکند و تا زمان خاتمه آن منتظر میماند.
کد:
Function ExecuteAndWait(sExecutableFile : String) : Boolean;
var
siInfo : TStartUpInfo;
piInfo : TProcessInformation;
begin
FillChar(siInfo, SizeOf(siInfo), #0);
with siInfo do begin
cb := SizeOf(siInfo);
dwFlags := STARTF_USESHOWWINDOW;
wShowWindow := SW_SHOWNORMAL;
end;
Result := CreateProcess(NIL, pChar(sExecutableFile), NIL, NIL, FALSE, CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, NIL, pchar(ExtractFilePath(sExecutableFile)),siInfo, piInfo);
if Result then
WaitForSingleObject(piInfo.hprocess,INFINITE);
end;
-
روشن و خاموش كردن Numlock
روشن و خاموش كردن Numlock
کد:
function SetNumLock(Active: Boolean): Boolean;
begin
// Check to see if the desired state is set
if (Active <> ((GetKeyState(VK_NUMLOCK) and 1) = 1)) then
begin
// Turn on / off
keybd_event(VK_NUMLOCK, 45, KEYEVENTF_EXTENDEDKEY, 0);
keybd_event(VK_NUMLOCK, 45, KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP , 0);
end;
end;
-
نمایش سطرهای یک Grid به صورت یکی در میان
نمایش سطرهای یک Grid به صورت یکی در میان
کد:
procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject;
const Rect: TRect; DataCol: Integer; Column: TColumn;
State: TGridDrawState);
var
test1: Real;
RowNo: Integer;
begin
with (Sender as TDBGrid) do
begin
if (gdSelected in State) then
begin
// Farbe für die Zelle mit dem Focus
// color of the focused row
Canvas.Brush.Color := clblue;
end
else
begin
// Zeile erfahren
// get the actual row number
rowno := Query1.RecNo;
// gerade und ungerade Zeilen ermitteln
// odd or even ?
test1 := (RowNo / 2) - trunc(RowNo / 2);
// Zeile gerade...
// If it's an even one...
if test1 = 0 then
begin
farbe := clWhite
end
// ...Zeile ungerade
// ...else it's an odd one
else
begin
farbe := clYellow;
end;
Canvas.Brush.Color := farbe;
// Font-Farbe immer schwarz
// font color always black
Canvas.Font.Color := clBlack;
end;
Canvas.FillRect(Rect);
// Denn Text in der Zelle ausgeben
// manualy output the text
Canvas.TextOut(Rect.Left + 2, Rect.Top + 1, Column.Field.AsString);
end
end;
-
چگونه سایز Col را در یک DBGrid به صورت اتوماتیک قرار دهیم
چگونه سایز Col را در یک DBGrid به صورت اتوماتیک قرار دهیم
کد:
procedure SetGridColumnWidths(Grid: Tdbgrid);
const
DEFBORDER = 10;
var
temp, n: Integer;
lmax: array [0..30] of Integer;
begin
with Grid do
begin
Canvas.Font := Font;
for n := 0 to Columns.Count - 1 do
//if columns[n].visible then
lmax[n] := Canvas.TextWidth(Fields[n].FieldName) + DEFBORDER;
grid.DataSource.DataSet.First;
while not grid.DataSource.DataSet.EOF do
begin
for n := 0 to Columns.Count - 1 do
begin
//if columns[n].visible then begin
temp := Canvas.TextWidth(trim(Columns[n].Field.DisplayText)) + DEFBORDER;
if temp > lmax[n] then lmax[n] := temp;
//end; { if }
end; {for}
grid.DataSource.DataSet.Next;
end; { while }
grid.DataSource.DataSet.First;
for n := 0 to Columns.Count - 1 do
if lmax[n] > 0 then
Columns[n].Width := lmax[n];
end; { With }
end; {SetGridColumnWidths }
procedure TForm1.Button1Click(Sender: TObject);
begin
SetGridColumnWidths(dbgrid3);
end;
-
اضافه نمودن یک کاربر جدید داخل یک دیتابیس در SQLServer 2000
اضافه نمودن یک کاربر جدید داخل یک دیتابیس در SQLServer 2000
procedure TForm1.Button1Click(Sender: TObject);
begin
ADOCommand1.CommandText := 'Use DataBaseName';
ADOCommand1.Execute;
ADOCommand1.CommandText := 'Exec SP_AddUser ' + QuotedStr('Username');
ADOCommand1.Execute;
end;
{* For Any Infromation Mail Me *
Mail :123123@123 0
...Add a user into a database in Sql Server 2000?
-
کنترل ولوم صدا با استفاده از کد نویسی
کنترل ولوم صدا با استفاده از کد نویسی
کد:
uses MMSystem;
type
TVolumeRec = record
case Integer of
0: (LongVolume: Longint) ;
1: (LeftVolume, RightVolume : Word) ;
end;
const DeviceIndex=5
{0:Wave
1:MIDI
2:CDAudio
3:Line-In
4:Microphone
5:Master
6:PC-loudspeaker}
procedure SetVolume(aVolume:Byte) ;
var Vol: TVolumeRec;
begin
Vol.LeftVolume := aVolume shl 8;
Vol.RightVolume:= Vol.LeftVolume;
auxSetVolume(UINT(DeviceIndex), Vol.LongVolume) ;
end;
function GetVolume:Cardinal;
var Vol: TVolumeRec;
begin
AuxGetVolume(UINT(DeviceIndex),@Vol.LongVolume) ;
Result:=(Vol.LeftVolume + Vol.RightVolume) shr 9;
end;
-
CheckBox در DBGrid
CheckBox در DBGrid
سلام.
با اين كد مي تونيد در كنترل DBGrid براي مقادير منطقي به جاي True يا False از CheckBox استفاده كنيد
اين كد يونيت :
کد:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, DB, DBTables, Grids, DBGrids;
type
TForm1 = class(TForm)
DBGrid1: TDBGrid;
Table1: TTable;
DataSource1: TDataSource;
procedure DBGrid1CellClick(Column: TColumn);
procedure DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn; State: TGridDrawState);
procedure DBGrid1ColEnter(Sender: TObject);
procedure DBGrid1ColExit(Sender: TObject);
private
FOriginalOptions : TDBGridOptions; { Private declarations }
public
procedure SaveBoolean;
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.SaveBoolean;
begin
Self.DBGrid1.SelectedField.Dataset.Edit;
Self.DBGrid1.SelectedField.AsBoolean := not Self.DBGrid1.SelectedField.AsBoolean;
Self.DBGrid1.SelectedField.Dataset.Post;
end;
procedure TForm1.DBGrid1CellClick(Column: TColumn);
begin
if Self.DBGrid1.SelectedField.DataType = ftBoolean then
SaveBoolean();
end;
procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn; State: TGridDrawState);
Const
CtrlState : array[Boolean] of Integer = (DFCS_BUTTONCHECK,
DFCS_BUTTONCHECK or DFCS_CHECKED);
var
CheckBoxRectangle : TRect;
begin
if Column.Field.DataType = ftBoolean then
begin
Self.DBGrid1.Canvas.FillRect(Rect);
CheckBoxRectangle.Left := Rect.Left + 2;
CheckBoxRectangle.Right := Rect.Right - 2;
CheckBoxRectangle.Top := Rect.Top + 2;
CheckBoxRectangle.Bottom := Rect.Bottom - 2;
DrawFrameControl(Self.DBGrid1.Canvas.Handle,
CheckBoxRectangle,
DFC_BUTTON,
CtrlState[Column.Field.AsBoolean]);
end;
end;
procedure TForm1.DBGrid1ColEnter(Sender: TObject);
begin
if Self.DBGrid1.SelectedField.DataType = ftBoolean then
begin
Self.FOriginalOptions := Self.DBGrid1.Options;
Self.DBGrid1.Options := Self.DBGrid1.Options - [dgEditing];
end;
end;
procedure TForm1.DBGrid1ColExit(Sender: TObject);
begin
if Self.DBGrid1.SelectedField.DataType = ftBoolean then
Self.DBGrid1.Options := Self.FOriginalOptions;
end;
end.
اين هم مال فرم
object Form1: TForm1
Left = 192
Top = 114
Width = 953
Height = 778
Caption = 'Form1'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object DBGrid1: TDBGrid
Left = 0
Top = 0
Width = 945
Height = 744
Align = alClient
DataSource = DataSource1
TabOrder = 0
TitleFont.Charset = DEFAULT_CHARSET
TitleFont.Color = clWindowText
TitleFont.Height = -11
TitleFont.Name = 'MS Sans Serif'
TitleFont.Style = []
OnCellClick = DBGrid1CellClick
OnColEnter = DBGrid1ColEnter
OnColExit = DBGrid1ColExit
OnDrawColumnCell = DBGrid1DrawColumnCell
end
object Table1: TTable
Active = True
DatabaseName = 'DBDEMOS'
TableName = 'reservat.db'
Left = 128
Top = 88
end
object DataSource1: TDataSource
DataSet = Table1
Left = 176
Top = 80
end
end
-
ايجاد ميانبر از يك فايل در ويندوز
کد:
procedure CreateShortcut(SourceFileName, Title: string; Location:
ShortcutType; SubDirectory : string);
var
MyObject : IUnknown;
MySLink : IShellLink;
MyPFile : IPersistFile;
Directory,
LinkName : string;
WFileName : WideString;
MyReg,
QuickLaunchReg : TRegIniFile;
begin
MyObject := CreateComObject(CLSID_ShellLink);
MySLink := MyObject as IShellLink;
MyPFile := MyObject as IPersistFile;
MySLink.SetPath(PChar(SourceFileName));
MyReg := TRegIniFile.Create('Software\MicroSoft\Windows\CurrentVersion\Explorer');
try
LinkName := ChangeFileExt(SourceFileName, '.lnk');
LinkName := ExtractFileName(LinkName);
case Location of
_DESKTOP : Directory := MyReg.ReadString('Shell Folders', 'Desktop', '');
_STARTMENU : Directory := MyReg.ReadString('Shell Folders', 'Start Menu', '');
_SENDTO : Directory := MyReg.ReadString('Shell Folders', 'SendTo', '');
_QUICKLAUNCH:
begin
QuickLaunchReg := TRegIniFile.Create('Software\MicroSoft\Windows\CurrentVersion\GrpConv');
try
Directory := QuickLaunchReg.ReadString('MapGroups', 'Quick Launch', '');
finally
QuickLaunchReg.Free;
end; {try..finally}
end; {case _QUICKLAUNCH}
end; {case}
if Directory <> '' then
begin
if SubDirectory <> '' then
WFileName := Directory + '\'+ SubDirectory +'\' + LinkName
else
WFileName := Directory + '\' + LinkName;
MyPFile.Save(PWChar(WFileName), False);
end; {Directory <> ''}
finally
MyReg.Free;
end; {try..finally}
end; {CreateShortcut}
-
minimize كردن كليه پنجره ها
کد:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
function EnumWinProc(Wnd : HWND) : Boolean; Export; StdCall;
var
WinText : Array[0..255] of Char;
begin
GetWindowText(Wnd, WinText, 255);
Result := True;
if (StrPas(WinText) <> '') and
IsWindowVisible(Wnd) and
(Wnd<>Application.Handle) and
(Wnd<>Form1.Handle)
then
CloseWindow(Wnd);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
EnumWindows(@EnumWinProc, LongInt(Self));
end;
end.
-
تغيير تاريخ سيستم
تغيير تاريخ سيستم
کد:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Label1: TLabel;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure FechaDelSistema(Fecha: TDateTime);
var
FecSys: TSystemTime;
nA, nM, nD: Word;
begin
DecodeDate(Fecha, nA,nM,nD);
GetLocalTime(FecSys);
FecSys.wYear := nA;
FecSys.wMonth := nM;
FecSys.wDay := nD;
SetLocalTime(FecSys);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
FechaDelSistema( StrToDate('2006/10/09') );
end;
end.
-
خوب خسته شدیما. دوستان فعلا دیگه تموم شد. تا بعدا فکر کنم حدود 115 تاپیک شده باشه.
ببینم خستگی منو چه جوری جبران می کنین.
-
خيلي حال دادي
نفست طلا داداش
-
تشکر فراوان
با سلام خدمت شما تکنیک برتر عزیز
خیلی خیلی ممنون واسه این کدها خیلی حال دادی ایشاالله همیشه مغزت پر از دلفی!
بازم ممنون خصوصاً واسه اطلاعات cpu.
بابا تو دیگه آخری دلفی هستی. روی همه رو کم کردی.
به امید دیدار.
-
ممنون از زحمات شما در اين بخش.
هميشه خوش و موفق باشي.
-
خواهش می کنم دوستان عزیز و عرجمند .
امیدوارم که بتوانم رضایت تمامی دوستان را جلب کنم
-
-
-
بابا واقعاً عالیه
دست درد نکنه
به امید پیروزی و بهروزی برای شما
خدا نگهدار
-
واقعاً دستتون درد نکنه
به امید پیروزی و بهروزی روزافزون شما
اما خیلی باحاله
خدانگهدار