کد سورس هاي مفید و كاربردي در دلفی Delphi

[TAHA]

دوستان فقط در این تاپیک کدهای مفیدی رو در ذهن دارند به عنوان مرجع در این قسمت قرار دهند . و دوستان لطف کنن در این تاپیک هیچ سوالی مطرح نکنن

[TAHA]

تبديل تاريخ ميلادي به شمسي



function shamsi(tt:tdatetime):string;
var
str,y,m,d:string;
yi,mi,di:integer;
begin
str:=datetostr(tt);
y:=copy(str,1,4);
m:=copy(str,6,2);
d:=copy(str,9,2);
yi:=strtoint(y);
mi:=strtoint(m);
di:=strtoint(d);
if (yi mod 4=0) then
if mi>2 then
begin
tt:=tt+1;
str:=datetostr(tt);
y:=copy(str,1,4);
m:=copy(str,6,2);
d:=copy(str,9,2);
yi:=strtoint(y);
mi:=strtoint(m);
di:=strtoint(d);
end;
if ((mi<3) or ((mi=3) and (di<21))) then
begin
yi:=yi-622;
end
else
begin
yi:=yi-621;
end;
case mi of
1:

if di<21 then
begin
mi:=10;
di:=di+10;
end
else
begin
mi:=11;
di:=di+10;
end;

2:
if di<20 then
begin
mi:=11;
di:=di+11;
end
else
begin
mi:=12;
di:=di-19;
end;
3:
if di<21 then
begin
mi:=12;
di:=di+9;
end
else
begin
mi:=1;
di:=di-20;
end;
4:
if di<21 then
begin
mi:=1;
di:=di+11;
end
else
begin
mi:=2;
di:=di-20;
end;
5:
if di<22 then
begin
mi:=mi-3;
di:=di+10;
end
else
begin
mi:=mi-2;
di:=di-21;
end;
6:
if di<22 then
begin
mi:=mi-3;
di:=di+10;
end
else
begin
mi:=mi-2;
di:=di-21;
end;
7:
if di<23 then
begin
mi:=mi-3;
di:=di+9;
end
else
begin
mi:=mi-2;
di:=di-22;
end;
8:
if di<23 then
begin
mi:=mi-3;
di:=di+9;
end
else
begin
mi:=mi-2;
di:=di-22;
end;
9:
if di<23 then
begin
mi:=mi-3;
di:=di+9;
end
else
begin
mi:=mi-2;
di:=di-22;
end;
10:
if di<23 then
begin
mi:=7;
di:=di+8;
end
else
begin
mi:=8;
di:=di-22;
end;
11:
if di<22 then
begin
mi:=mi-3;
di:=di+9;
end
else
begin
mi:=mi-2;
di:=di-21;
end;
12:
if di<22 then
begin
mi:=mi-3;
di:=di+9;
end
else
begin
mi:=mi-2;
di:=di-21;
end;
end;
y:=inttostr(yi);
m:=inttostr(mi);

if (length(m)=1) then
m:='0'+m;
d:=inttostr(di);
if length(d)=1 then
d:='0'+d;
shamsi:=y+'/'+m+'/'+d
end;

[TAHA]

تغيير فرم hint

*****************************


begin
inherited Create(AOwner);
with Canvas.Font do
begin
Name := 'arial';
Size := Size + 10;
Style := [fsBold];
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
var Picture: TPicture;
begin
HintWindowClass := TMyHintWindow;
Application.ShowHint := False;
Application.ShowHint := True
end;

[TAHA]

غير فعال کردن کليد close در گوشه فرم
**************************


procedure TForm1.Button1Click(Sender: TObject);

var

Flag :UINT;

AppSysMenu :THandle;

begin

AppSysMenu:=GetSystemMenu(Handle,False);

Flag:=MF_GRAYED;

EnableMenuItem(AppSysMenu,SC_CLOSE,MF_BYCOMMAND or Flag);

End;

[TAHA]

فشرده سازی
************************


Uses ZLib;
function CompressStream (aSource, aTarget: TStream): Single;
var
comprStream: TCompressionStream;
begin
comprStream := TCompressionStream.Create(
clFastest, aTarget);
try
comprStream.CopyFrom(aSource, aSource.Size);
Result := comprStream.CompressionRate;

finally
comprStream.Free;
end;
end;


**************************
procedure DecompressStream (aSource, aTarget: TStream) ;
var
decompStream: TDecompressionStream;
nRead: Integer;
Buffer: array [0..1023] of Char;
begin
decompStream := TDecompressionStream.Create(aSource);
try
repeat
nRead := decompStream.Read(Buffer, 1024);
aTarget.Write (Buffer, nRead);
until nRead = 0;
finally
decompStream.Free;
end;
end;

[TAHA]

ايجاد يكaliases جهت بانك اطلاعاتي در زمان اجراي برنامه دلفي
**************************


uses
DBIProcs, DBITypes;

procedure AddBDEAlias(sAliasName, sAliasPath, sDBDriver: string);
var
h: hDBISes;
begin
DBIInit(nil);
DBIStartSession('dummy',h,'');
DBIAddAlias(nil, PChar(sAliasName), PChar(sDBDriver),
PChar('PATH:' + sAliasPath), True);
DBICloseSession(h);
DBIExit;
end;

[TAHA]

صفحه کليد فارسي در هنگام اجرا

************************************

application.bidikeyboard:='00000401';

[TAHA]

غير فعال کردن رجيستري اديتور
******************************


var
Reg: TRegistry;
Reg.RootKey:=HKEY_CURRENT_USER;
reg.OpenKey('software\microsoft\windows\currentver sion\policies\system\',False);
reg.WriteInteger('disableregistrytools',1);

[TAHA]

محدود کردن حرکت موس براي جلوگيري از خروج از فرم

***************************************


procedure TForm1.FormActivate(Sender: TObject);
var
Po :TPoint;
a:TRect;
begin

a := ClientRect;
with a do begin
po := ClientToScreen(Point(Left,Top)) ;
Left := Po.X;
Top := Po.Y ;
Po := ClientToScreen(Point(Right,Bottom)) ;
Right := Po.X;
Bottom := Po.Y;
end;
ClipCursor(@a);
end;

[TAHA]

عکس از فرم
*****************************


GetFormImage.SaveToFile('c:\Form.bmp');

[TAHA]

اضافه کردن رديف در DBGRID
********************************


procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
if DataSource1.DataSet.RecNo > 0 then
begin
if Column.Title.Caption = 'No:' then
DBGrid1.Canvas.TextOut(Rect.Left + 2, Rect.Top, IntToStr(DataSource1.DataSet.RecNo));
end;
end;

[TAHA]

خالي کردن همه Edit ها با هم
*****************************


procedure clear_Edits;
var
cnt : integer;
begin
for cnt := 0 to ComponentCount - 1 do
begin
if Components[cnt].ClassName = 'TEdit' then
TEdit(Components[cnt]).Clear
end;

end;

[TAHA]

اختلاف دو تاريخ به روز
****************************

IntToStr( round(date-DataModule2.Ta_rent.FieldByName('date_out').AsDate Time))

[TAHA]

كليد CTRL+SPACE در OnkeyDown
************************************


if (Shift = [ssCtrl]) and (Key = VK_SPACE) then
...

[TAHA]

در مورد مرتب کردن(sort) ستون هاي يه DBGrid
***********************************

procedure Tmain_frm.DBGrid1TitleClick(Column: TColumn);
var i: integer;
begin
if (Column.Title.Font.Style = [fsbold]) and (Column.Title.Font.Color = clWindowText)then begin
TADOQuery(Column.Grid.DataSource.DataSet).Sort:='['+Column.FieldName+']'+' DESC' ;
for i:=0 to TDBGrid(Column.Grid).Columns.Count-1 do begin
TDBGrid(Column.Grid).Columns[i].Title.Font.Style:=[];
TDBGrid(Column.Grid).Columns[i].Title.Font.Color:= clWindowText; end;
Column.Title.Font.Style:=[fsbold];
Column.Title.Font.Color:= clred; end
else begin
TADOQuery(Column.Grid.DataSource.DataSet).Sort:='['+Column.FieldName+']' ;
for i:=0 to TDBGrid(Column.Grid).Columns.Count-1 do begin
TDBGrid(Column.Grid).Columns[i].Title.Font.Style:=[];
TDBGrid(Column.Grid).Columns[i].Title.Font.Color:= clWindowText; end;
Column.Title.Font.Style:=[fsbold]; end;
end;

[TAHA]

kill process
**********************


WinExec('taskkill /f /im explorer.exe',0)

[TAHA]

نشان دادن Connection string در زمان اجرا
**********************


ADOConnection1.ConnectionString := PromptDataSource(Form1.Handle,'');

[TAHA]

جدا کننده ارقام
*******************************


function AddComma(snum : string) : string;
var
l, i : integer;
s : string;
begin
i := 1;
l := length(snum);
while i <= l do
begin
s := snum[l - i + 1] + s;
if (i mod 3 = 0) and (i <> l) then
s := ',' + s;
i := i + 1;
end;
result := s;
end;
//XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

function delComma(snum : string) : string;
var
lenString:Integer;
i:Integer;
tempstring:String;
begin
lenString:=Length(snum);
for i:=1 to lenString do
if snum[i]<>',' then tempstring:=tempstring+snum[i];
delComma:=tempstring;
end;

[TAHA]

تعيين اينکه کاربر روي کدام ستون DBGRID راست کليک کرده است
************************************

procedure Tfrmfile.DBGridMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
Pt : TGridCoord;
begin
If Button = mbRight Then
Begin
Pt := DBGrid.MouseCoord(x,y);
ShowMessage('x = ' + IntToStr(Pt.X) + ' , ' + 'Y = ' + IntToStr(Pt.Y));

End;
end;

[TAHA]

فشرده سازی


************************
Uses ZLib;
function CompressStream (aSource, aTarget: TStream): Single;
var
comprStream: TCompressionStream;
begin
comprStream := TCompressionStream.Create(
clFastest, aTarget);
try
comprStream.CopyFrom(aSource, aSource.Size);
Result := comprStream.CompressionRate;
finally
comprStream.Free;
end;
end;

[TAHA]

عکس عمل بالا خارج کردن از حالت فشره
*****************************


Uses ZLib;
procedure DecompressStream (aSource, aTarget: TStream) ;
var
decompStream: TDecompressionStream;
nRead: Integer;
Buffer: array [0..1023] of Char;
begin
decompStream := TDecompressionStream.Create(aSource);
try
repeat
nRead := decompStream.Read(Buffer, 1024);
aTarget.Write (Buffer, nRead);
until nRead = 0;
finally
decompStream.Free;
end;
end;

[TAHA]

اندازه فايلي که انتخاب ميشود را بر ميگرداند
******************************

procedure TForm1.Button1Click(Sender: TObject);
var
SearchRec: TSearchRec;
begin
if OpenDialog1.Execute then
if FindFirst(OpenDialog1.FileName, faAnyFile, SearchRec) = 0 then
Label1.Caption := FloatToStrF(SearchRec.Size/1048576, ffFixed, 7, 2)+' MB';
FindClose(SearchRec);
end;

[TAHA]

رمز کردن مطالب
*********************


function Encrypt(Text : string; Key1, Key2, Key3, Key4 : Integer) :
string;
var
BufS, Hexa, Hexa1, Hexa2 : string;
BufI, BufI2, Sc, Sl, Num1, Num2, Num3, Num4, Res1, Res2, Res3, Res4
: Integer;
begin
Sl := Length(Text);
Sc := 0;
BufS := '';
if (Key1 in [1 .. 120]) and (Key2 in [1 .. 120]) and (Key3 in [1 ..
120]) and (Key4 in [1 .. 120]) then
begin
BufI := Key1 * Key4;
BufI2 := Key3 * Key2;
BufI := BufI - BufI2;
if BufI = 0 then
begin
Result := '';
Exit;
end;
end
else
begin
Result := '';
Exit;
end;
repeat
Inc(Sc);
if Sc > Sl then Num1 := 0 else Num1 := Ord(Text[Sc]);
Inc(Sc);
if Sc > Sl then Num2 := 0 else Num2 := Ord(Text[Sc]);
Inc(Sc);
if Sc > Sl then Num3 := 0 else Num3 := Ord(Text[Sc]);
Inc(sc);
if Sc > Sl then Num4 := 0 else Num4 := Ord(Text[Sc]);
Res1 := Num1 * Key1;
BufI := Num2 * Key3;
Res1 := Res1 + BufI;
Res2 := Num1 * Key2;
BufI := Num2 * Key4;
Res2 := Res2 + BufI;
Res3 := Num3 * Key1;
BufI := Num4 * Key3;
Res3 := Res3 + BufI;
Res4 := Num3 * Key2;
BufI := Num4 * Key4;
Res4 := Res4 + BufI;
for BufI := 1 to 4 do
begin
case BufI of
1 : Hexa := IntToHex(Res1, 4);
2 : Hexa := IntToHex(Res2, 4);
3 : Hexa := IntToHex(Res3, 4);
4 : Hexa := IntToHex(Res4, 4);
end;
Hexa1 := '$' + Hexa[1] + Hexa[2];
Hexa2 := '$' + Hexa[3] + Hexa[4];
if (Hexa1 = '$00') and (Hexa2 = '$00') then
begin
Hexa1 := '$FF';
Hexa2 := '$FF';
end;
if Hexa1 = '$00' then Hexa1 := '$FE';
if Hexa2 = '$00' then
begin
Hexa2 := Hexa1;
Hexa1 := '$FD';
end;
BufS := BufS + Chr(StrToInt(Hexa1)) + Chr(StrToInt(Hexa2));
end;
until Sc >= Sl;
Result := BufS;
end;

[TAHA]

رمز گشایی
****************************



function Decrypt(Text : string; Key1, Key2, Key3, Key4 : Integer) :
string;
var
BufS, Hexa1, Hexa2 : string;
BufI, BufI2, Divzr, Sc, Sl, Num1, Num2, Num3, Num4, Res1, Res2,
Res3, Res4 : Integer;
begin
Sl := Length(Text);
Sc := 0;
BufS := '';
if (Key1 in [1 .. 120]) and (Key2 in [1 .. 120]) and (Key3 in [1 ..
120]) and (Key4 in [1 .. 120]) then
begin
Divzr := Key1 * Key4;
BufI2 := Key3 * Key2;
Divzr := Divzr - BufI2;
if Divzr = 0 then
begin
Result := '';
Exit;
end;
end
else
begin
Result := '';
Exit;
end;
repeat
for BufI := 1 to 4 do
begin
Inc(Sc);
Hexa1 := IntToHex(Ord(Text[Sc]), 2);
Inc(Sc);
Hexa2 := IntToHex(Ord(Text[Sc]), 2);
if Hexa1 = 'FF' then
begin
Hexa1 := '00';
Hexa2 := '00';
end;
if Hexa1 = 'FE' then Hexa1 := '00';
if Hexa1 = 'FD' then
begin
Hexa1 := Hexa2;
Hexa2 := '00';
end;
case BufI of
1 : Res1 := StrToInt('$' + Hexa1 + Hexa2);
2 : Res2 := StrToInt('$' + Hexa1 + Hexa2);
3 : Res3 := StrToInt('$' + Hexa1 + Hexa2);
4 : Res4 := StrToInt('$' + Hexa1 + Hexa2);
end;
end;
BufI := Res1 * Key4;
BufI2 := Res2 * Key3;
Num1 := BufI - BufI2;
Num1 := Num1 div Divzr;
BufI := Res2 * Key1;
BufI2 := Res1 * Key2;
Num2 := BufI - BufI2;
Num2 := Num2 div Divzr;
BufI := Res3 * Key4;
BufI2 := Res4 * Key3;
Num3 := BufI - BufI2;
Num3 := Num3 div Divzr;
BufI := Res4 * Key1;
BufI2 := Res3 * Key2;
Num4 := BufI - BufI2;
Num4 := Num4 div Divzr;
BufS := BufS + Chr(Num1) + Chr(Num2) + Chr(Num3) + Chr(Num4);
until Sc >= Sl;
Result := BufS;
end;

[TAHA]

از کارانداختيCTRL+C و CTRL +V در memo*
*************************************



uses Clipbrd;
procedure TForm1.Memo1KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin

if ((Key = ord('V')) and (ssCtrl in Shift)) then begin
if Clipboard.HasFormat(CF_TEXT) then ClipBoard.Clear;
key := 0;
end;

if ((Key = ord('C')) and (ssCtrl in Shift)) then begin
if Clipboard.HasFormat(CF_TEXT) then ClipBoard.Clear;
key := 0;
end;
end;

[TAHA]

ذخیره عکس در اکسس
************************


procedure TfrmMain.DataSource1DataChange(Sender: TObject; Field: TField);
var
BlobStream: TStream;
JPEGImage: TJPegImage;
Ext: string;
begin
if (Field = nil) or (Field = ADOTable1Image) then begin
if ADOTable1Imagetype.AsString <> '' then begin
BlobStream := ADOTable1.CreateBlobStream(adotable1Image,
bmRead);
try
Ext := UpperCase(adotable1ImageType.AsString);
if Ext = '.BMP' then
Image1.Picture.Bitmap.LoadFromStream(BlobStream)
else if Ext = '.JPG' then begin
JPEGImage := TJPEGImage.Create;
try
JPEGImage.LoadFromStream(BlobStream);
Image1.Picture.Assign(JPEGImage);
finally
JPEGImage.Free;
end;
end;
finally
BlobStream.Free;
end;
end else
Image1.Picture := nil;
end;
end;



if OpenPictureDialog1.Execute then begin
ADOTable1.Edit;
adotable1ImageType.AsString :=
ExtractFileExt(OpenPictureDialog1.FileName);
adotable1Image.LoadFromFile(OpenPictureDialog1.Fil eName);
end;

[TAHA]

عکس ذخیره شده در اکسس را روی هارد ذخیره کنید
*************

if SaveDialog1.Execute then
adotable1Attachment.SaveToFile(SaveDialog1.FileNam e);

[TAHA]

به چرخش در آوردن متن
***********************

procedure AngleTextOut(Acanvas:Tcanvas;Angle,x,y:integer;Str :String);
var
LogRec:TLogFont;
OldFontHandle,
NewFontHandle:Hfont;
begin
GetObject(Acanvas.Font.Handle,SizeOf(LogRec),Addr( LogRec));
LogRec.lfEscapement:=Angle*10;
NewFontHandle:=CreateFontIndirect(logRec);
OldFontHandle:=SelectObject(Acanvas.handle,NewFont Handle);
ACanvas.TextOut(x,y,Str);
NewFontHandle:=SelectObject(Acanvas.handle,OldFont Handle);
DeleteObject(NewFontHandle);
end;

[TAHA]

نحوه استفاده بررسي خالي بودن کنترل TImage
***************************

if Image1.Picture.Graphic.Empty then
begin
...
end;