X
تبلیغات
سایت تخصصی برنامه نویسی دلفی

سایت تخصصی برنامه نویسی دلفی
 
کدهای مورد نیاز یک برنامه نویس دلفی

محل درج آگهی و تبلیغات
 
نوشته شده در تاريخ پنجشنبه هفدهم آبان 1386 توسط سعید بابایی

function UpTime: string;

const

ticksperday: Integer    = 1000 * 60 * 60 * 24;

ticksperhour: Integer   = 1000 * 60 * 60;

ticksperminute: Integer = 1000 * 60;

tickspersecond: Integer = 1000;

var

t:          Longword;

d, h, m, s: Integer;

begin

t := GetTickCount;

 

d := t div ticksperday;

Dec(t, d * ticksperday);

 

h := t div ticksperhour;

Dec(t, h * ticksperhour);

 

m := t div ticksperminute;

Dec(t, m * ticksperminute);

 

s := t div tickspersecond;

 

Result := 'مدت زمان روشن بودن کامپیوتر شما: ' + IntToStr(d) + ' روز' + IntToStr(h) + ' ساعت ' + IntToStr(m) +

' دقیقه '+ IntToStr(s) + ' ثانیه';

end;

مثال:

روی فرم بذار و در رویداد کلیک مربو ط به کلید بنویس button و یک  l abel یک     

 

 

procedure TForm1.Button1Click(Sender: TObject);

begin

label1.Caption := UpTime;

end;

موفق و  سربلند باشید

 

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


نوشته شده در تاريخ پنجشنبه هفدهم آبان 1386 توسط سعید بابایی

Uses

Shellapi

 

یک Button روی فرم بذار و در رویداد کلیک مربو ط به کلید بنویس:

procedure TForm1.BitBtn1Click(Sender: TObject);

begin

ShellExecute (HWND(nil), 'open', 'taskmgr', '', '', SW_SHOWNORMAL);

end;

 

 

موفق و  سربلند باشید

 

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

 


نوشته شده در تاريخ پنجشنبه هفدهم آبان 1386 توسط سعید بابایی

میخوام تواین قسمت به درخواست دوستان سورس لغت نامه به زبان دلفی رو بذارم.

قبل از هر کاری باید دوستان دقت کنن که مهمترین چیز در یک برنامه فرهنگ لغات بانک اطلاعاتی اونه که حاوی لغات به همراه معنی اون لغات باید باشه.

سورس برنامه :

unit Unit1;

 

interface

 

uses

  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

  Dialogs, DBTables, StdCtrls, Grids, DBGrids, DB, DBCtrls, ExtCtrls,

  OleCtrls;

 

type

  TForm1 = class(TForm)

////کنترلهای مورد استفاده در فرم :

    DataSource1: TDataSource;//// DataSet= Query1

    DBGrid1: TDBGrid; ///DataSource=DataSource1

    Edit1: TEdit;

    Query1: TQuery;

   DBMemo1: TDBMemo;///DataSource=DataSource1 و DataField= نام فیلدی که معنی لغات درون آن است

    Button1: TButton;

    Edit2: TEdit;

    procedure Edit1Change(Sender: TObject);

    procedure FormCreate(Sender: TObject);

    procedure Timer1Timer(Sender: TObject);

    procedure Button1Click(Sender: TObject);

  private

    { Private declarations }

  public

    { Public declarations }

  end;

 

var

  Form1: TForm1;

  s:string;

implementation

 

{$R *.dfm}

 

procedure TForm1.Edit1Change(Sender: TObject);

begin ///// زیر را وارد کنید SQL با دو بار کلیک روی ادیت کد 

getdir(0,s);///گرفتن مسیر پوشه ای که برنامه از درون آن اجرامیشود

Query1.Active:=false;

DBGrid1.DataSource:=DataSource1;

Query1.DatabaseName:=s+'\data'; ///مسیر بانک اطلاعاتی برنامه درون پوشه برنامه

Query1.SQL.Clear;

Query1.SQL.Add('SELECT * FROM "اسم دیتابیس.db" اسم دیتابیس  WHERE english LIKE '''+edit1.Text+'''+"%"');//// SQL کد لغاتی که مشابه لغت تایپ شده رو میاره //

Query1.ExecSQL;

Query1.Active:=true;

end;

 

در بالا English اسم فیلدی از دیتا بیس است که لغات ما در آن قرار دارد.

اگر میخواین فقط همون لغتی رو که کاربر تایپ کرده بیاره قسمت سبز رنگ رو به این  صورت تو  رویداد کلیک  یه کلید بذارین.

 

Query1.SQL.Add('SELECT * FROM "اسم دیتابیس.db" اسم دیتابیس  WHERE english ='+QuotedStr(Edit1.Text)+'');

 

دوستان عزیز و دانشمند لطفا اگر کاستی هایی در  برنامه میبینن  لطف کنن مطرح کنن تا برنامه رو اصلاح کنم.

 

موفق و  سربلند باشید

 

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

 


نوشته شده در تاريخ شنبه سوم شهریور 1386 توسط سعید بابایی
توسط اين كد  سطل آشغال ويندوز را خالي كنید

                 uses    

,shellapi

 

Procedure EmptyRecycleBin;
Const
SHERB_NCONFIRMATION = $0000001 ;
SHERB_NOPROGRESSUI = $0000002 ;
SHERB_NOSOUND = $0000004 ;
Type
TSHEmptyRecycleBin = function (Wnd : HWND;
pszRootPath : PChar;
dwFlags : DWORD) : HRESULT; stdcall;
Var
SHEmtyRecycleBin : TSHEmptyRecycleBin;
LibHandel : THandle;
Begin { EmptyRecycleBin }
LibHandel := LoadLibrary(PChar('Shell32.dll'));
if LibHandel> 0 then
SHEmtyRecycleBin :=GetProcAddress(LibHandel, 'SHEmptyRecycleBinA')
else
begin
MessageDlg('Failed to load Shell32.dll.',mtError, [mbOK], 0);
Exit;
End;
SHEmtyRecycleBin(Application.Handle, nil,
SHERB_NCONFIRMATION  or SHERB_NOPROGRESSUI or
SHERB_NOSOUND);
FreeLibrary(LibHandel);
End; { EmptyRecycleBin }

مثال بایک Button:

procedure TForm1.Button1Click(Sender: TObject);

 

Var

   MsgText, MsgCaption : String;

   MsgType, UserResp : integer;

begin

   MsgCaption := 'تایید خالی کردن سطل آشغال';

   MsgText :='آیامایل به خالی کردن سطل آشغال هستید؟ ';

   MsgType := MB_YESNO + MB_ICONQUESTION + MB_DEFBUTTON1 + MB_APPLMODAL;

 

 

   UserResp := MessageBox( Handle, PChar(MsgText), PChar(MsgCaption), MsgType);

 

   Case UserResp of

      IDYES :

          begin

                EmptyRecycleBin;  {کد اصلی برای خالی کردن سطل آشغال }

   end;

      IDNO :

          begin

          end;

   end;

   end;

موفق وسربلند باشید .

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


نوشته شده در تاريخ چهارشنبه سی و یکم مرداد 1386 توسط سعید بابایی

جواب:

کافی است در رويداد TitleClick مربوط به شی DBGrid کد زیر را بنويسيد :

procedure TForm1.DBGrid1TitleClick(Column: TColumn);

begin

   ADOTable1.Sort:=Column.FieldName;

end;

موفق وسربلند باشید .  

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


نوشته شده در تاريخ چهارشنبه سی و یکم مرداد 1386 توسط سعید بابایی
 

آيا براي فهميدن Resolation و تغيير دادن آن راه حلی وجود داره ؟

جواب:

1-     ساده ترين راه تشخيص resolution:

procedure TForm1.Button2Click(Sender: TObject);

var resx,resy:Integer;

begin

ResX:=Screen.Width;

ResY:=Screen.Height;

Label1.Caption:=IntToStr(resx);

Label2.Caption:=IntToStr(resy);

end;


2- تغيير
resolution:


procedure SetResolution(ResX, ResY: DWord);

var

lDeviceMode : TDeviceMode;

begin

EnumDisplaySettings(nil, 0, lDeviceMode);

lDeviceMode.dmFields:=DM_PELSWIDTH or DM_PELSHEIGHT;

lDeviceMode.dmPelsWidth :=ResX;

lDeviceMode.dmPelsHeight:=ResY;

ChangeDisplaySettings(lDeviceMode, 0);

end;

 مثال:


procedure TForm1.Button1Click(Sender: TObject);

begin

SetResolution(800,600);

end;

موفق وسربلند باشید . 

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


نوشته شده در تاريخ چهارشنبه سی و یکم مرداد 1386 توسط سعید بابایی
 

جواب : سورس برنامه ای که اینکار را برای شما انجام می دهد را در زیر آورده ام

{در قسمت}

var

loc1,loc2:word;

 Masking:boolean=False;

 Adding_Digit:boolean=True;

implementation

{$R *.dfm}

{ کد زیر رابنویسید Edit1Change  و در رویداد Edit1, eventsدر قسمت}

procedure TForm1.Edit1Change(Sender: TObject);

var

  i,j,n,m: Integer;

  a:array of string;

  My_Final_Text:string;

begin

  if Masking then

     Masking:=false

  else

   begin

     n:=0;

     m:=0;

     My_Final_Text:='';

     for i := 1 to length(edit1.text) do

      if Edit1.Text[i] in ['0'..'9'] then

         n:=n+1

      else

         m:=m+1;

     if (n>3) or ((n<=3) and (Length(edit1.Text)>3))then

      begin

        loc1:=edit1.SelStart;

        setlength(a,n);

        j:=0;

        for i := 1 to length(edit1.text) do

         if Edit1.Text[i] in ['0'..'9'] then

          begin

            a[j]:=Edit1.Text[i];

            j:=j+1;

          end;

        j:=0;

        for i := n downto  1 do

         begin

            if ((n-i) mod 3=0) and ((n-i)<>0) then

             begin

               My_Final_Text:=','+My_Final_Text;

               j:=j+1;

             end;

            My_Final_Text:=a[i-1]+My_Final_Text;

         end;

        if edit1.Text<>My_Final_Text then

         begin

           Masking:=True;

           edit1.Text:=My_Final_Text;

         end;

        if Adding_Digit then

           edit1.SelStart:=loc1+j-m

        else

           Edit1.SelStart:=loc2+j-m

      end;

   end;

end;

{ کد زیر رابنویسید Edit1KeyDown  و در رویداد Edit1, eventsدر قسمت}

procedure TForm1.Edit1KeyDown(Sender: TObject; var Key: Word;

  Shift: TShiftState);

begin

if (key=Vk_Delete) and (edit1.SelLength=0) and ((edit1.SelStart+1)<=length(edit1.text)) and (edit1.Text[edit1.SelStart+1]=',')then

   begin

     loc2:=edit1.SelStart+1;

     edit1.SelStart:=edit1.SelStart+1;

     Adding_Digit:=False;

   end

  else

   if (key=Vk_Back) and (edit1.SelLength=0) and ((edit1.SelStart-1)>=1) and (edit1.Text[edit1.SelStart]=',') then

    begin

      loc2:=edit1.SelStart-2;

      edit1.SelStart:=edit1.SelStart-1;

      Adding_Digit:=False;

    end

  else

    Adding_Digit:=True;

end;

{ کد زیر رابنویسید Edit1KeyDown و در رویداد Edit1, eventsدر قسمت}

{برای جلوگیری از ورود کاراکتر های حروفی}

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);

begin

if not( key in ['0'..'9',#8,#46]) then

     key:=#0;

end;

end.

موفق وسربلند باشید . 

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


نوشته شده در تاريخ چهارشنبه سی و یکم مرداد 1386 توسط سعید بابایی

تابع تبدیل عدد به حروف

جواب :

درقسمت  implementation تابع زیر را بنویسید:

 

const

yekan : array[0..9] of string = ('صفر','يک','دو','سه','چهار','پنج','شش','هفت','هشت','نه');

dahgan : array[0..9] of string = ('','','بيست','سي','چهل','پنجاه','شصت','هفتاد','هشتاد','نود');

dahyek : array[10..19] of string = ('ده','يازده','دوازده','سيزده','چهارده','پانزده','شانزده','هفده','هجده','نوزده');

sadgan : array[0..9] of string = ('','يکصد','دويست','سيصد','چهارصد','پانصد','ششصد','هفتصد','هشتصد','نهصد');

base : array[0..4] of string = ('','هزار','ميليون','ميليارد','تريليون');

 

// تابع تبديل عدد به حروف

function number_to_word(snum : string) : string;

// تابع تبدیل عدد سه رقمی به حروف

function getnum3(num3 : integer) : string;

var

s : string;

d1, d2, d3, d12 : integer;

begin

d12 := num3 mod 100; // دو رقم اول

d3 := num3 div 100; // صدگان

if d3 <> 0 then

s := sadgan[d3] + ' و ';

// نام گذاري اعداد 10 تا 19 در بين

// اعداد دو رقمي استثنا است

if (d12 >= 10) and (d12 <= 19) then

begin

s := s + dahyek[d12];

end

else

begin

d2 := d12 div 10; // دهگان

if d2 <> 0 then

s := s + dahgan[d2] + ' و ';

d1 := d12 mod 10; // يکان

if d1 <> 0 then

s := s + yekan[d1] + ' و ';

// حذف حرف <و> اضافي

s := copy(s, 1, length(s) - 3);

end;

getnum3 := s;

end;

 

var

L, i, b : integer;

stotal : string;

begin

// اگر عدد صفر بود، يکراست نتيجه را برگردان

if snum = '0' then

result := yekan[0]

else

begin

// براي اينکه بتوان عدد را به قسمت هاي سه رقمي تقسيم کرد

// به سمت چپ عدد، به اندازه کافي صفر مي افزاييم

for i := Length(snum) to ((Length(snum) - 1) div 3 + 1) * 3 - 1 do

snum := '0' + snum;

 

L := Length(snum) div 3 - 1; // تعداد قسمت هاي سه رقمي منهاي يک

 

// سه رقم سه رقم حلقه را تکرار کن

// از چپ به راست

for i := 0 to L do

begin

// به دست آوردن سه رقم مورد نظر

b := strtoint(copy(snum ,i * 3 + 1, 3));

// اگر سه رقم به دست آمده صفر باشد، در نام عدد تاثيري ندارد

// نام قسمت سه رقمي را بدست مي آوريمgetnum3 با استفاده از تابع

// پسوند را به آن اضافه مي کنيمbase با استفاده از آرايه

if b <> 0 then

stotal := stotal + getnum3(b) + ' ' + base[L - i] + ' و ';

end;

// حذف حرف <و> اضافي

stotal := copy(stotal, 1, length(stotal) - 3);

result := stotal;

end;

end;

 

مثال با دو عنصر   Edit و یک  Button

procedure TForm1.Button1Click(Sender: TObject);

begin

if Edit2.Text=''then

begin

Edit1.Text:='0';

end;

Edit1.Text:= number_to_word(Edit2.Text);

end;

منبع : http://www.prdev.com

موفق وسربلند باشید .  

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


نوشته شده در تاريخ پنجشنبه هجدهم مرداد 1386 توسط سعید بابایی
اين يک تابع است که تاریخ ویندوز را گرفته و آن را به تاریخ شمسی تبدیل مکیند.


بعد از قسمت  implementation  یونیت مربوطه تابع زیر را قرار دهید:


implementation

{$R *.dfm}
 

{تابع تبدیل تاریخ میلادی به شمسی}


Function MiladyToShamsi(DTime:tdateTime):tdateTime;
var
YearEqual:array[0..2,0..2] of integer;
AddOneDay,AddFarDay:boolean;
AddTodays:byte;
Farday:byte;
ThisDay:word;
ThisMonth:word;
ThisYear:word;
YearDif1:Integer;
YearDif2:Integer;
TestRange1,testRange2,
FarsiRange1,FarsiRange2,P:Integer;
CurM,CurD:string;
sYear,sMonth,sDay:Variant;
Counter:Integer;
CurDay,CurMonth,CurYear:word;
Begin
CurM:='';
CurD:='';
YearEqual[1,1]:=1997;
YearEqual[1,2]:=1998;
YearEqual[2,1]:=1376;
YearEqual[2,2]:=1377;
DecodeDate(DTime,thisyear,thismonth,thisday);
YearDif1:=ThisYear-1997;
YearDif2:=ThisYear-1998;
Testrange1:=1996-(100*4);
Testrange2:=1996+(100*4);
FarsiRange1:=1375-(100*4);
FarsiRange2:=1375+(100*4);
AddOneDay:=false;
//Rem------------------------------
Counter:=TestRange1;
while TestRange2>=Counter do begin /////////////////////////
If thisYear=counter then begin
AddOneDay:=true;
break;
end;
If counter=TestRange2 then break;
counter:=counter+4
end;//while

If AddOneDay then
addtodays:=1
Else
AddTodays:=0;
//Rem---------------------------------/////////////////
If (((ThisMonth = 3) and (thisday<(20+AddtoDays)))
or ( ThisMonth<3)) then
YearDif1:=yearDif1-1;
//Rem------------
If (((thisYear mod 2)<>0) and
(((thismonth=3) and (thisday>(20-addTodays)))
or (thisMonth>4))) then
CurYear:=yearEqual[2,1]+YearDif1
else begin
CurYear:=YearEqual[2,1]+YearDif2;
Counter:=FarsiRange1;
while counter>FarsiRange2 do begin /////////////////////////
If CurYear=Counter then begin
AddFarDay:=true;
break;
end;
end;//while

If AddFarDay then
FarDay:=1 else Farday:=0;

If (((thismonth=3) and (thisday>20-(addToDays)+FarDay)) or (thismonth>3) ) then
CurYear:=CurYear+1;
end; //First If

If AddtoDays=1 then FarDay:=0;
//Rem---------------------------------
Case thismonth of
1:Begin
If thisday<(21-Farday) then begin
CurMonth:=10;
CurDay:=(ThisDay+10)+FarDay;
end else begin
CurMonth:=11;
CurDay:=(ThisDay-20)+FarDay;
end;
end;

2:Begin
If thisday<(20-Farday) then begin
CurMonth:=11;
CurDay:=(ThisDay+11)+FarDay;
end else begin
CurMonth:=12;
CurDay:=(ThisDay-19)+FarDay;
end;
End;

3:Begin
If thisday<(21-AddToDays) then begin
CurMonth:=12;
CurDay:=(ThisDay+9)+AddToDays+FarDay;
end else begin
CurMonth:=1;
CurDay:=(ThisDay-20)+AddToDays;
end;
End;

4:Begin
If thisday<(21-AddToDays) then begin
CurMonth:=1;
CurDay:=(ThisDay+11)+AddToDays;
end else begin
CurMonth:=2;
CurDay:=(ThisDay-20)+AddToDays;
end;
End;

5:Begin
If thisday<(22-AddToDays) then begin
CurMonth:=2;
CurDay:=(ThisDay+10)+AddToDays;
end else begin
CurMonth:=3;
CurDay:=(ThisDay-21)+AddToDays;
end;
End;

6:Begin
If thisday<(22-AddToDays) then begin
CurMonth:=3;
CurDay:=(ThisDay+10)+AddToDays;
end else begin
CurMonth:=4;
CurDay:=(ThisDay-21)+AddToDays;
end;
End;

7:Begin
If thisday<(23-AddToDays) then begin
CurMonth:=4;
CurDay:=(ThisDay+9)+AddToDays;
end else begin
CurMonth:=5;
CurDay:=(ThisDay-22)+AddToDays;
end;
End;

8:Begin
If thisday<(23-AddToDays) then begin
CurMonth:=5;
CurDay:=(ThisDay+9)+AddToDays;
end else begin
CurMonth:=6;
CurDay:=(ThisDay-22)+AddToDays;
end;
End;

9:Begin
If thisday<(23-AddToDays) then begin
CurMonth:=6;
CurDay:=(ThisDay+9)+AddToDays;
end else begin
CurMonth:=7;
CurDay:=(ThisDay-22)+AddToDays;
end;
End;

10:Begin
If thisday<(23-AddToDays) then begin
CurMonth:=7;
CurDay:=(ThisDay+8)+AddToDays;
end else begin
CurMonth:=8;
CurDay:=(ThisDay-22)+AddToDays;
end;
End;

11:Begin
If thisday<(22-AddToDays) then begin
CurMonth:=8;
CurDay:=(ThisDay+9)+AddToDays;
end else begin
CurMonth:=9;
CurDay:=(ThisDay-21)+AddToDays;
end;
End;

12:Begin
If thisday<(22-AddToDays) then begin
CurMonth:=9;
CurDay:=(ThisDay+9)+AddToDays;
end else begin
CurMonth:=10;
CurDay:=(ThisDay-21)+AddToDays;
end;
End;

end;//case
//Rem-----------------
CurM:=Trim(IntTostr(CurMonth));
CurD:=Trim(IntTostr(CurDay));
//Rem-----------------
If CurMonth<10 then
CurM:='0'+Trim(IntToStr(CurMonth));
If CurDay<10 then
CurD:='0'+Trim(IntTostr(CurDay));

Result:=EncodeDate(CurYear,CurMonth,CurDay);

end;

 

مثال: یک label روی فرم بذار و در رویداد FormCreate ، فرم مربوطه بنويس:


procedure TForm1.FormCreate(Sender: TObject);


begin


 label1.caption:=DateTimeToStr(MiladyToShamsi(Date));


end;

دانلود سورس برنامه :

http://www.4shared.com/file/80219396/b558fed4/Tarikh_Shamsi.html

موفق وسربلند باشید . 

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


.: Weblog Themes By Pichak :.


تعداد بازدیدکنندگان
 
تمامی حقوق این وبلاگ محفوظ است :