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

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

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

کد:

---

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;

---

تغيير فرم 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;

---

غير فعال کردن کليد 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;

---

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

کد:

---

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;

---

ايجاد يك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;

---

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

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

نقل قول:

---

application.bidikeyboard:='00000401';

---

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

کد:

---

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

---

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

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

کد:

---

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;

---

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

کد:

---

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

---