موضوع: نکات برنامه نویسی در دلفی ‏

چگونه می توان 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;

نکته مهم:

البته سعی کنید این کار را قبل از ساعت 9 شب انجام دهید

فرمت کردن یک دریاو در 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;

عوض کردن wallpaper
preocedure wallpaper;
begin
systemparametersinfo(spi_setdeskwallpaper,0,pchar( 'faniz.bmp'),0);
end;

این یه کد برای نوشتن یک عدد به حروف
کد:
Function TMB.Get1nd(i:integer):String;
Begin
case i of
0: Get1nd:=' &Otilde;&Yacute;&Ntilde; '; {zero}
1: Get1nd:=' &iacute;&szlig;&thorn; '; {one}
2: Get1nd:=' &Iuml;&aelig; '; {two}
3: Get1nd:=' &Oacute;&aring; '; {three}
4: Get1nd:=' �&aring;&Ccedil;&Ntilde;� '; {four}
5: Get1nd:=' �&auml;&Igrave; '; {five}
6: Get1nd:=' &Ocirc;&Ocirc; '; {}
7: Get1nd:=' &aring;&Yacute;&Ecirc; '; {}
8: Get1nd:=' &aring;&Ocirc;&Ecirc; '; {}
9: Get1nd:=' &auml;&aring; '; {}
10: Get1nd:=' &Iuml;&aring; '; {}
11: Get1nd:=' &iacute;&Ccedil;&Ograve;&Iuml;&aring;&thorn; '; {}
12: Get1nd:=' &Iuml;&aelig;&Ccedil;&Ograve;&Iuml;&aring; '; {}
13: Get1nd:=' &Oacute;&iacute;&Ograve;&Iuml;&aring; '; {}
14: Get1nd:=' �&aring;&Ccedil;&Ntilde;&Iuml;&aring;� '; {}
15: Get1nd:=' �&Ccedil;&auml;&Ograve;&Iuml;&aring; '; {}
16: Get1nd:=' &Ocirc;&Ccedil;&auml;&Ograve;&Iuml;&aring; '; {}
17: Get1nd:=' &aring;&Yacute;&Iuml;&aring; '; {}
18: Get1nd:=' &aring;&Igrave;&Iuml;&aring; '; {}
19: Get1nd:=' &auml;&aelig;&Ograve;&Iuml;&aring; '; {}
End;
End;
Function TMB.Get2nd(i:Integer):String;
Begin
case i of
2: Get2nd:=' &Egrave;&iacute;&Oacute;&Ecirc; '; {}
3: Get2nd:=' &Oacute;&iacute; '; {}
4: Get2nd:=' �&aring;&aacute;� '; {}
5: Get2nd:=' �&auml;&Igrave;&Ccedil;&aring; '; {}
6: Get2nd:=' &Ocirc;&Otilde;&Ecirc; '; {}
7: Get2nd:=' &aring;&Yacute;&Ecirc;&Ccedil;&Iuml; '; {}
8: Get2nd:=' &aring;&Ocirc;&Ecirc;&Ccedil;&Iuml; '; {}
9: Get2nd:=' &auml;&aelig;&Iuml; '; {}
End;
End;
Function TMB.Get3nd(i:Integer):String;
Begin
case i of
1: Get3nd:=' &iacute;&szlig;&Otilde;&Iuml;&thorn; '; {}
2: Get3nd:=' &Iuml;&aelig;&iacute;&Oacute;&Ecirc; '; {}
3: Get3nd:=' &Oacute;&iacute;&Otilde;&Iuml; '; {}
4: Get3nd:=' �&aring;&Ccedil;&Ntilde;&Otilde;&Iuml;� '; {}
5: Get3nd:=' �&Ccedil;&auml;&Otilde;&Iuml; '; {}
6: Get3nd:=' &Ocirc;&Ocirc;&Otilde;&Iuml; '; {}
7: Get3nd:=' &aring;&Yacute;&Ecirc;&Otilde;&Iuml; '; {}
8: Get3nd:=' &aring;&Ocirc;&Ecirc;&Otilde;&Iuml; '; {}
9: Get3nd:=' &auml;&aring;&Otilde;&Iuml; '; {}
End;
End;
Function TMB.GetTree(i:Integer):String;
var
a:String;
Begin
a:='';
if (i mod 100)>=20 then
Begin
if (i mod 10)>0 then
a:=Get1nd(i Mod 10)+a;
if (i mod 100 Div 10)>0 then
if length(a)>0 then
a:=Get2nd(i mod 100 Div 10)+'&aelig;'+a
Else
a:=Get2nd(i mod 100 Div 10)+a;
End
Else if (i mod 100) >0 then
a:=Get1nd(i Mod 100)+a;
if (i div 100)>0 then
if length(a)>0 then
a:=Get3nd(i Div 100)+'&aelig;'+a
Else
a:=Get3nd(i Div 100)+a;
if i=0 then
a:=Get1nd(0);
GetTree:=a;

End;
Function TMB.GetNum(Num:LongInt):String;
var
a:String;
i,mod1:Integer;
Begin
{ GetNum:=GetTree(Num);}
a:='';
i:=0;
repeat
mod1:=num mod 1000;
num:=num div 1000;
if (mod1>0) and (Length(a)>0) then
a:=' &aelig; '+a;
if (i=0)And(mod1>0) then
a:=GetTree(Mod1)+a
Else if (i=1) and (mod1>0) then
a:=GetTree(Mod1)+ '&aring;&Ograve;&Ccedil;&Ntilde;'+a {Towsand}
Else if (i=2) and (mod1>0) then
a:=GetTree(Mod1)+ '&atilde;&iacute;&aacute;&iacute;&aelig;&auml;'+a {Milion}
Else if (i=3) and (mod1>0) then
a:=GetTree(Mod1)+ '&atilde;&iacute;&aacute;&iacute;&Ccedil;&Ntilde;&Iuml;'+a; {Miliard}
i:=i+1;
Until Num=0;
GetNum:=a+' '+Vahed;
End;

ذخیره کردن یک فرم به عنوان یک عکس
کد:
procedure TForm1.Button1Click(Sender: TObject);
var DCWindow: HDC;
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;

گذاشتن هرگونه عکس بر روی BitBtn ...
اینم کدش
کد:
var
bmp: TBitmap;
begin
bmp:=TBitmap.Create;
try
bmp.Width := Image.Picture.Graphic.Width;
bmp.Height := Image.Picture.Graphic.Height;
bmp.Canvas.Draw(0, 0, Image.Picture.Graphic) ;
BitBtn.Glyph:=bmp;
finally
bmp.Free;
end;
end;

نمایش صفحه مشخصات یک فایل ( 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;

Get User Name

بدت آوردن نام کاربر
کد:
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;

Extract an Icon from EXE or DLL file

کد:
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
کد:
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 به صورت یکی در میان
کد:
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 به صورت اتوماتیک قرار دهیم

کد:
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;

کد:
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;