چگوگل Google از شروع تا امروز

گوگل Google از شروع تا امروز (page rank)

نام گوگل از تغییر googol که به معنای (عدد 10 به توان 100) می باشد گرفته شده است. گوگل تاثیر زیادی در دنیای وب داشته و می توان از آن به عنوان انقلاب بزرگ نوآوری در اینترنت یاد نمود. فعل “Google” نیز اخیرا در جولای سال 2006 به فرهنگ لغت Oxford English و Merriam Websterاضافه شده است. این فعل به معنای موتور جستجوی گوگل برای دریافت اطلاعات از اینترنت می باشد.

در حالی که 10 سال پیش هیچ نامی از گوگل در دنیای وب وجود نداشت، ولی اکنون ابرقدرت بی چون و چرای موتورهای جستجو می باشد. گوگل اولین موتور جستجو در وب می باشد که 54% سهام بازار را در اختیار داشته و یاهو با 23% و MSN با 13% در رتبه بعد می باشند. گوگل بیش از یک میلیارد جستجو کننده در روز دارد.

o گوگل چگونه آغاز به کار کرد؟

ژانویه سال 1996 دو دانشجوی ph.D به نام Larry Puge و Sergey Brin در دانشگاه Stand ford گوگل را به عنوان پروژه دانشجویی آغاز کردند. پروژه موتور جستجویی بود که بتواند روابط بین سایت ها را آنالیز کند و این روابط باعث بهینه شدن نتایج جستجو گردد. در آن زمان موتورهای جستجو بر مبنای تعداد دفعات مورد جستجو رتبه بندی می کردند. به این سیستم رتبه بندی “Back Rub” گفته شد، چرا که این سیستم Back links یا لینک های بازگشتی به سایت را برای تخمین اهمیت سایت بررسی می کند. البته یک موتور جستجوی کوچک به نام Rank Dex نیزقبلا از این استراتژی بهره برده بود. پیج و برین بعد از اطمینان از اینکه صفحاتی که بیشترین لینک مرتبط با موضوع را به خود دارند، دارای مرتبط ترین هستند، موضوع تز خود را آغاز کرده و موتور جستجوی خود را بنا نهادند.

در ابتدا موتور جستجو از وب سایت دانشگاه استند فورد استفاده می کرد و نام دامنه آن google.standford.edu بود. سپس دامنه google.com در در 14 سپتامبر 1997 ثبت شده و شرکت Google Inc, نیزدر 7 سپتامبر 1998 در گاراژ یک دوست درMenlo Park کالیفرنیا شروع به کار نمود.(لازم به ذکر است که این گاراژ اخیرا توسط گوگل خریداری شده و از جازبه های توریستی به شمار می رود). سرمایه شرکت نیز یک میلیارد دلار بود.

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

در سال 2000 گوگل آغاز به فروش تبلیغات نمود که این نوع تبلیغات مطابق با کلمات کلیدی جستجو شده بود. این قابلیت برای افزایش بازدهی تبلیغات بسیار مناسب بوده و به خصوص که برمبنای hit توسط کابران بوده است. تبلیغات نیز به صورت متن بوده (بدون گرافیک) و دلیل آن نیز بالا نگه داشتن سرعت بالا آمدن صفحه بود چرا که گوگل پرسرعت ترین موتور جستجو در این زمینه به شمار می رود. کلمات کلیدی نیز از ترکیب تعداد کلیک ها و مقدار قیمتی که سفارش دهنده آگهی توانایی پرداخت را برای آن کلمه کلیدی اعلام کرده، قیمت گذاری و فروخته می شود. البته این مدل تبلیغات و پرداخت آن از سایت Goto.com که بعدها به Yahoo Search Marketing تغییر یافت سرچشمه گرفته بود.

موضوع :

اين دستور رنگ فرم را خيلي جاب ميكند به طوري كه هر پيكسل يك رنگ

 

procedure fillGradientRect(canvas: tcanvas; Recty: trect; fbcolor, fecolor: tcolor; fcolors: integer);

 var

    i, j, h, w, fcolor: Integer;

    R, G, B: Longword;

    beginRGBvalue, RGBdifference: array[0..2] of Longword;

begin

    beginRGBvalue[0] := GetRvalue(colortoRGB(FBcolor));

    beginRGBvalue[1] := GetGvalue(colortoRGB(FBcolor));

    beginRGBvalue[2] := GetBvalue(colortoRGB(FBcolor));

 

    RGBdifference[0] := GetRvalue(colortoRGB(FEcolor)) - beginRGBvalue[0];

    RGBdifference[1] := GetGvalue(colortoRGB(FEcolor)) - beginRGBvalue[1];

    RGBdifference[2] := GetBvalue(colortoRGB(FEcolor)) - beginRGBvalue[2];

 

    canvas.pen.style := pssolid;

    canvas.pen.mode := pmcopy;

    j := 0;

    h := recty.bottom - recty.top;

    w := recty.right - recty.left;

 

    for  i := fcolors downto 0 do

    begin

        recty.left := muldiv(i - 1, w, fcolors);

        recty.right := muldiv(i, w, fcolors);

        if fcolors>1 then

        begin

           R := beginRGBvalue[0] + muldiv(j, RGBDifference[0], fcolors);

          G := beginRGBvalue[1] + muldiv(j, RGBDifference[1], fcolors);

          B := beginRGBvalue[2] + muldiv(j, RGBDifference[2], fcolors);

       end;

      canvas.brush.color := RGB(R, G, B);

      patBlt(canvas.handle, recty.left, recty.top, Recty.right - recty.left, h, patcopy);

      inc(j);

  end;

end;

 

procedure TForm1.FormPaint(Sender: TObject);

var

   Row, Ht: Word;

   IX: Integer;

begin

   fillGradientRect(form1.canvas, rect(0, 0, Width, Height), $FF0000, $00000, $00FF);

 

 

 

   iX :=200 ;

   Ht:=(ClientHeight + 512) div 256;

   for Row := 0 to 512 do

   begin

      with Canvas do begin

      Brush.Color := RGB(Ix,0,row);

      FillRect(Rect(0, Row * Ht, ClientWidth, (Row + 1) * Ht));

      IX :=(IX-1);

   end;

end;

 

 

 

{Note, that the OnResize event should also call the FormPaint

method if this form is allowed to be resizable.

This is because if it is not called then when the

window is resized the gradient will not match the rest of the form. }

 

موضوع :

Titel فرم وكپشن فرم حركت ميكند

 

 

var

  a:string;

 

procedure TForm1.FormCreate(Sender: TObject);

begin

  a:='Look at here !...';

end;

 

procedure TForm1.Timer1Timer(Sender: TObject);

var i:integer;

begin

  application.title:=a;

  form1.Caption:=a;

  for i:=1 to (length(a)-1) do

    a[i] := application.title[i+1];

  a[length(a)] := application.title[1];

end;

 

 

موضوع :

اين كد موقع بستن فرم كارهاي جالبي با فرم مي كند

 

 

var

  tutup : Boolean;

  i : integer;

 

 

procedure TForm1.Timer1Timer(Sender: TObject);

var

  reg1,reg2 : hrgn;

begin

   if tutup = true then

   begin

      i:=i + 10;

      reg1 := createroundrectrgn(0+i,0+i,width-i,height-i,20,20);

      setwindowrgn(handle,reg1,true);

   end;

 

   if i >= width then

   begin

      tutup := false;

      i := 1;

   end;

 

   if tutup = false then

   begin

      i := i + 10;

      reg1 := createrectrgn(0,0,(width div 2)-i ,height);

      reg2 := createrectrgn((width div 2)+i  ,0,width,height);

      combinergn(reg1,reg1,reg2,rgn_or);

      setwindowrgn(handle,reg1,true);

      if i >= width div 2 then

      begin

        tutup := true;

        i := 1;

     end;

   end;

end;

 

procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);

var

  reg1 : hrgn;

begin

  i := 1;

  timer1.Enabled := true;

  if MessageDlg('Do U wanna really exit now ?',

    mtConfirmation, [mbYes, mbNo], 0) = mrYes then

    canclose := true

  else

  begin

    canclose := false;

    timer1.Enabled := false;

    reg1 := createroundrectrgn(0,0,width,height,0,0);

    setwindowrgn(handle,reg1,true);

  end;

end;

 

procedure TForm1.FormCreate(Sender: TObject);

begin

 tutup := True;

 timer1.Enabled := false;

end;

موضوع :

قرار دادن یك كليد ميانبر در كليكراست منو form

private

  procedure wmSysCommand(var msg:TMessage); message WM_SYSCOMMAND;

 

{...}

 

const

  ID_ABOUT     =  WM_USER+1;

  ID_HELP      =  WM_USER+2;

  ID_NEWLINE   =  WM_USER+4;

 

 

{...}

 

implementation

 

{...}

 

procedure TForm1.FormCreate(Sender: TObject);

var

  SysMenu:THandle;

begin

  SysMenu := GetSystemMenu(Handle,False);

  InsertMenu(SysMenu,Word(-1),MF_SEPARATOR,ID_NEWLINE,'');

  InsertMenu(SysMenu,Word(-1),MF_BYPOSITION,ID_HELP, 'Help');

  InsertMenu(SysMenu,Word(-1),MF_BYPOSITION,ID_ABOUT, 'About');

end;

 

procedure TForm1.wmSysCommand;

begin

  case Msg.wParam of

    ID_ABOUT : ShowMessage('About-Menu Item Pressed!');

    ID_HELP  : ShowMessage('Help-Menu Item Pressed!');

  end;

  inherited;

end;

موضوع :

تغيير Volume ويندوز

 

يك  TrackBar در فرم خود قرار دهيد و  Max value را به  15  تغيير دهيد و در رويداد  OnChange آن كد زير را قرار دهيد:

كد:

 

procedure TForm1.TrackBar1Change(Sender: TObject);
var
Count, i: integer;
begin
  Count := waveOutGetNumDevs;
  for i := 0 to Count do
  begin
   waveOutSetVolume(i,longint(TrackBar1.Position*4369)*65536+longint(TrackBar1.Position*4369));
end;
end;

موضوع :

شرمندم که این چند روز نتونستم مطلبی بدم از دو  سه هفته دگه شروع میکنم
موضوع :

اين بار چند تا فايل سورس  pas گذاسشتم كه...

كه حتم دارم خيلي بدردتون ميخوره همشونم درباره ي شبكه هستن دو سه تا شونم مي تونن تبديل به  component بشن، هرچند  4  تا بيشتر نيستن

لینک دانلود

 

   

موضوع :

عكس از دسكتاپ

 

 

      لینک دانلود

 
موضوع :

Shut downکامپیوتر از طریق دلفی

 

اگه میخواید بدونید از طریق دلفی چطور میتونید کامپیوتر یک نفر رو Shut down  کنید بیاید برنامه رو دانلود کنید ...

در ضمن نظر یادتون نره !!!

 

من این برنامه رو هم رو ویندوز 98  امتحان کردم و هم رو 2000  ... تو هر دو به درستی کار میکنه ...

 

فقط لطفا اگه کسی رو ویندوز xp  هم تست کرد نتیجش رو به من هم بگه !!! آخه من xp  رو سیستمم نبود

 

 

                          لینک دانلود

موضوع :

برنامه سرچ فايل تو هارد

 

بابا این که دیگه احتیاج به توضیح نداره

لینک دانلود

موضوع :

دوستي فلش پلير و دلفي

آقا جون اين برنامه رو من ننوشتم و از سايت دلفي فلش  گرفتم اما توسط اين برنامه شما قادر خواهيد بود كه حتي بدون نصب نرم افزار فلش دقيقا يه فايل فلش بسازيد!!!!!!!!!!!!!! شما از طريق اين برنامه و كامپونت هايش مي توانيد يك نرم افزار ختي قدرت مند تر از سوييش بسازيد .

خلاصه اين برنامه شما را با قدرت بي نظير دلفي در  كار با فلش و  كلا كامپونت ها اضافي  آشنا مي كند .

 

لینک دانلود

موضوع :

فرستادن ايميل

 

يك برنامه براي فرستادن ايميل

        لینک دانلود

موضوع :

كرسر ماوس خود را تغيير دهيد

 

با اين اي پي اي ميتوانيد در فرمها از كرسر هاي متحرك  ani استفاده نمایید.

       screen.Cursors[100]:=loadcursorfromfile('curser1.ani');
       form1.Cursor:=100;

موضوع :

بارگزاري يك فونت در زمان اجرا برنامه شما

 

بوسيله اين كد ميتوانيد در زمان اجرا برنامه فونت مورد نظر خود را بازيابي نماييد.

البته توصيه ميشود اين كار را در فرم ابتدايي انجام دهيد و از فونت لود شده در فرمهاي بعدي استفاده نماييد.

     addfontresource('path font and name font');

     addfontresource('c:\font\homa.ttf');

موضوع :

بدست آوردن نام كاربري ويندوز user name

شما بوسيله اين كد ميتوانيد نام كاربري ويندوز را بدست بياوريد

   var

  len:integer;

usern:pchar;

begin

   len:=20;

   getmem(usern,len);

   getusername(usern,len);

freemem(usern);

end;

موضوع :

تغيير نوع يك فايل image

 

شما اگر بخواهيد نوع يك فايل عكس را تغيير دهيد .

بطور مثال jpg  را به bmp  تبديل نماييد ميتوانيد از كد زير استفاده نماييد:

   procedure changeimage;

 var

        jpeg:tjpegimage;
        bmp:tbitmap;

 begin

      jpeg:=TJPEGImage.create;
      try
        jpeg.LoadFromFile('source file example c:amin.jpg' );
       bmp:=tbitmap.Create;
       try
           bmp.Assign(jpeg);
          bmp.SaveToFile(changefileext('target file example d:amin','.bmp'));
       finally
         bmp.free
      end;
   finally
   jpeg.Free;
end;

موضوع :

برگرداندن درايو سي دي رام

 

اين برنامه درايوهاي سي دي رام سيستم شما را در دلفي برمي گرداند اميدوارم بدردتون بخوره

 

              لینک دانلود       

موضوع :

يه يونيت براي كار با مودم و Dial Up

ا استفاده از اين كامپونت شما مي توانيد به سادگي كنترل سخت افزاري و خطاها و مديريت بر روي

كانكتشن ها و همچنين خطوط تلفنرا بدست بگيريد . البته با كمي كار شايد بشه پسورد كانكتشن ها رو

هم با اون بدست آورد . دانلود كنيد و يه نظري هم بدهيد

 

                   لینک دانلود

موضوع :

درج تاريخ بر روي عكس

 

 اين برنامه مي تونه چند تا عكس  دريافت كنه و روي آنها تاريخ ايجاد عكس را  به صورت دلخواه شما 

      درج كنه.

                     لینک دانلود

موضوع :

attrib changer

 

با اين برنامه ميتونين خواص فايلها رو عوض كنين

                    لینک دانلود

موضوع :

برای عضو شدن در این وبلاگ میتوانید با زدن  mail به من ميتوانيد عضو شويد  ومطالب خود را در وبتاگ  قرار دهيد

                                                       

                                         [e-mail]

موضوع :

امنيتي براي دسك تاپ

 

اين برنامه درست است آنچنان بدرد بخور نيست ولي نمونه است كه جرقه اي در ذهن ايجاد مي كند كه

امنيتي براي برنامه حاكم كنيم.

 

                   لینک دانلود

موضوع :

يه مكعب سه بعدي و متحرك با استفاده از OpenGL

این دیگه اخرش خیلی خفن کار میکند

 يه مكعب سه بعدي متشكل از  27  مكعب ديگه همراه با استفاده از OpenGL همراه با حرکت چرخشی 

 

       لینک دانلود

 

موضوع :

رمزگذاري روي فايل ها بدون فشرده كردن

این کامپنینت برای گذاشتن کلمه عبور روی هر فایلی هست.

فقط یه مشکلی که داره حجم فایل ها یکمی زیاد می شه.

اول به پوشه Component  برید و اون تو دلفی نصب کنید، بعد به شاخه Demo  برید و با نحوه اجرای برنامه آشنا بشید.

نظریادتون نره.

           لینک دانلود

موضوع :

كامپونت Text Animation

كامپونت Text Animation

يك كامپونت جالب :::

             لینک دانلود

   راستش فکر میکنم لینک دانلود این فایل ها که برای دانلود گزاشتم مشکل داره  اگه مشکل داشت  یا

email بزنين يا در بخش نظرات مشكل را بيان كنيد

موضوع :

drive info

اين برنامه تعداد درايو ها واطلاعات كاملي از انها ميدهد

 

                      لینک دانلود

موضوع :

شفاف كردن منوها

اين برنامه منوهاي شما را به صورت شفاف يعني پشت نما در مي آره.

 

                           لينك دانلود

موضوع :

صدا

این برنامه هر نوشته ای رو که بهش بدبد می خونه.

ولی باید تو ویندوز XP  اجرا بشه.

     

                                لينك دانلود

 

موضوع :

دستور زير چك مي كند ورد در كامپيوتر نصب است يا نه

uses registry;

function Word_Installed : Boolean;
var
Reg: TRegistry;
s: String;
begin
Reg := TRegistry.Create;
With Reg do
Begin
RootKey:=HKEY_CLASSES_ROOT;
result := Keyexists('Word.Application');
Free;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if Word_Installed then
ShowMessage('MS Word is installed.');
end;


موضوع :

اين كد كپشن notpad را تغيير ميدهد

SetWindowText(FindWindow('notepad',nil),'Test');
موضوع :

نمايش پنجره تاريخ و زمان

uses
shellapi;

procedure TForm1.Button1Click(Sender: TObject);
begin
ShellExecute(Handle, 'open', 'control', 'date/time', nil, SW_SHOW);
end;
موضوع :

قفل كردن mouse , keybord

function BlockInput (fBlockInput : boolean) : DWord; stdcall; external 'user32.DLL';

{block input}

procedure TForm1.Button1Click(Sender: TObject);
begin
BlockInput(true);
end;



procedure TForm1.Button2Click(Sender: TObject);
begin
BlockInput(false);
end;
موضوع :

خلاصه كار جالبي است

محيط dos را باز ميكند واز شما ورودي ميگيرد در كل كد جالبي است.



procedure TForm1.Button1Click(Sender: TObject);
var
s: string;
begin
AllocConsole;
try
Write('Type here your words and press ENTER: ');
Readln(s);
ShowMessage(Format('You typed: "%s"', [s]));
finally
FreeConsole;
end;
end;





موضوع :

با اين كد ميتوانيد از قسمتي از صفحه عكس بگيريد

اين كد كد جالبيه من كه از اين كد خوشم اومد ولي ببينيم تا نظر شما چي هستش

Procedure ScreenShot(Bild: TBitMap);
var c: TCanvas;
r: TRect;
begin
c:= TCanvas.Create;
c.Handle:= GetWindowDC (GetDesktopWindow);
try
r:= Rect(0,0,screen.width,screen.height);
Bild.Width:=screen.Width;
Bild.Height:=screen.Height;
Bild.Canvas.CopyRect(r, c, r);
finally
ReleaseDC(0, c.handle);
c.Free;
end;
end;

//only active window
Procedure ScreenShotActiveWindow(Bild: TBitMap);
var
    c: TCanvas;
    r, t: TRect;
    h: THandle;
begin
    c:= TCanvas.Create;
    c.Handle:= GetWindowDC (GetDesktopWindow);
    h:=GetForeGroundWindow;
    if h<>0 then
       GetWindowRect(h, t);
    try
       r:= Rect(0,0,t.Right-t.left,t.Bottom-t.Top);
       Bild.Width:=t.Right-t.left;
       Bild.Height:=t.Bottom-t.Top;
       Bild.Canvas.CopyRect(r, c, t);
   finally
   ReleaseDC(0, c.handle);
   c.Free;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   Form1.Visible:=false;
   Sleep(750); //ein wenig Zeit geben
   ScreenShot(Image1.Picture.BitMap);
   Form1.Visible:=true;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
   Form1.Visible:=false;
   Sleep(750); //ein wenig Zeit geben, some delay
   ScreenShotActiveWindow(Image1.Picture.BitMap);
   Form1.Visible:=true;
end;

 

موضوع :

ايجاد سوراخ در فرم

procedure TForm1.Button1Click(Sender: TObject);
var
     region1, region2 : hrgn;
begin
     region1 := CreateRectRgn(0,0,width,height);
     region2 := CreateEllipticRgn(30,30,200,200);
     CombineRgn(region1, region1, region2, RGN_DIFF);
     SetWindowRgn(handle, region1, true);
end;
موضوع :

title و captionفرم متحرك مي شود

var
  a:string;

procedure TForm1.FormCreate(Sender: TObject);
begin
  a:='Look at here !...';
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var i:integer;
begin
  application.title:=a;
  form1.Caption:=a;
  for i:=1 to (length(a)-1) do
    a[i] := application.title[i+1];
  a[length(a)] := application.title[1];
end;

 

موضوع :

اين وبلاگ هر روز بازيابي ميشود ومطالب جديدي به ان افزوده ميشوداگر مطلب جيدي دارين مي توانين به من

mail بزنين



[e-mail]




موضوع :

چگونه می توان عنوان Dialogها مثلاً ShowMessage يا خطاها را در دلفی تغيير داد و از راست به چپ نوشت؟

جواب:Application.Title:='عنوان دلخواه شما'

Application.BidiMode:=bdRightToLeft;
موضوع :

عد از مدتها غيبت امروز مطلبی در باره خاموش و کردن مانيتور از طريق دلفی عرض می کنم .

خاموش کردن مانيتور:


SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, 0)

روشن کردن مانيتور:


SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, - 1)

موفق و سلامت باشيد
موضوع :

برنامه ای برای نمايش ليست آدرسهای ملاقات شده در Internet Explorer

uses registry;

procedure ShowTypedUrls(Urls: TStrings);
var
Reg: TRegistry;
S: TStringList;
i: Integer;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CURRENT_USER;
if Reg.OpenKey('Software\Microsoft\Internet Explorer\TypedURLs', False) then
begin
S := TStringList.Create;
try
reg.GetValueNames(S);
for i := 0 to S.Count - 1 do
begin
Urls.Add(reg.ReadString(S.Strings[i]));
end;
finally
S.Free;
end;
Reg.CloseKey;
end;
finally
Reg.Free;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
ShowTypedUrls(ListBox1.Items);
end;
موضوع :

برنامه ای جهت دريافت نام کاربر جاری:

function GetCurrentUserName: string;
const
cnMaxUserNameLen = 254;
var
sUserName: string;
dwUserNameLen: DWORD;
begin
dwUserNameLen := cnMaxUserNameLen - 1;
SetLength(sUserName, cnMaxUserNameLen);
GetUserName(PChar(sUserName), dwUserNameLen);
SetLength(sUserName, dwUserNameLen);
Result := sUserName;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(GetCurrentUserName);
end;
موضوع :

طريقه قطع اتصال(ارتباط) به اينترنت در دلفی:

InternetAutodialHangup(0);
موضوع :

طريقه ايجاد اتصال(ارتباط) به اينترنت در دلفی:

InternetAutoDial(internet_autodial_force_unattended, Handle) ;
موضوع :

با استفاده از این کد می توانید یک فرم با انیمیشن داشته باشید.
با کلیک راست بر روی عنوان فرم می توانید اجرا برنامه را ببینید.
می توانید از این سورس کد دلفی در برنامه خودتان استفاده نمائید. فقط کافیه کپی کرده و در برنامه اضافه نمائید


type

TForm1 = class(TForm)

private

fOldClientHeight: Integer;

procedure WMNCRButtonDown(var Msg: TWMNCRButtonDown) ; message WM_NCRBUTTONDOWN;

public

end;


var

Form1: TForm1;


implementation

{$R *.dfm}


procedure TForm1.WMNCRButtonDown(var Msg: TWMNCRButtonDown) ;

var

h : integer;

begin

if (Msg.HitTest = HTCAPTION) then

begin

if (ClientHeight = 0) then

begin

for h := 0 to fOldClientHeight do ClientHeight := h;

Application.ProcessMessages;

end

else

begin

fOldClientHeight := ClientHeight;

for h := fOldClientHeight downto 0 do ClientHeight := h;

Application.ProcessMessages;

end;

end;

end;
موضوع :

تشخیص سی دی درایو کامپیوتر

با برنامه زیر می توانید اسم سی دی درایو را پیدا کنید. کار این تابع در زمانی است که می خواهید بر روی سی دی کار کنید و مثلا وجود فایل خاصی را بررسی کنید


Function GetCDDriveName:String;
var
s:String; Found:Boolean;
begin
s:='d:\';
Found:=False;
While (Not Found) and Not (s[1] In ['z','Z']) Do
begin
If getdrivetype(PChar(s)) = DRIVE_CDROM then
Found:=True
Else
s[1]:=Chr(Ord(s[1])+1);
end;
If Found then
GetCDDriveName:=s
Else
GetCDDriveName:='';
end;

موضوع :

چگونه می توان یک سایت وب را با برنامه دلفی در یک فایل ذخیره کرد

uses Activex;

............................


procedure WB_SaveAs_HTML

(WB:TWebBrowser; const FileName : string);

var

PersistStream: IPersistStreamInit;

Stream: IStream;

FileStream: TFileStream;

begin

if not Assigned(WB.Document) then

begin

ShowMessage('Document not loaded!');

Exit;

end;


PersistStream := WB.Document as IPersistStreamInit;

FileStream := TFileStream.Create(FileName, fmCreate);

try

Stream := TStreamAdapter.Create(FileStream, soReference)

as IStream;

if Failed(PersistStream.Save(Stream, True)) then

ShowMessage('SaveAs HTML fail!');

finally

FileStream.Free;

end;

end; (* WB_SaveAs_HTML *)


Usage sample:


//first navigate

WebBrowser1.Navigate('http://delphi.about.com');



//then save

WB_SaveAs_HTML(WebBrowser1,'c:\WebBrowser1.html');
موضوع :

حالا نوبت میرسه به یه سورس توپ دیگه :

برای عوض کردن متن دکمه استارت در ویندوز اکس پی می توانید از تابع زیر استفاده کنید که من نوشتم :

rocedure SetStart(S:String);
Var
y:LongInt;
start,btnst:Hwnd;
Begin
Y:=GetSystemMetrics(SM_CYSCREEN);
Start:=Findwindow('Shell_TrayWnd',nil);
BtnSt:=FindWindowEx(Start,0,'Button',nil);
SetWindowText(BtnSt,PChar(S));
SetCursorPos (10, y - 15 )
End;
موضوع :

تایین فضای آزاد یک

امروز براتون یک کد بسیار جالب آوردم شما برای بدست آوردن اطلاعاتی از پارتیشن دیسک توابع زیادی و خوبی در دلفی وجود دارد من یک مثال کاربردی نوشته ام که به دو مورد از آن ها اشاره کردم . برای این مثال یک دکمه و سه تا لیبیل در فرم قرار دهید و سپس روی دکه دوبار کلیک کنید و در روال آن کد زیر را بنویسید :

procedure TForm1.Button1Click(Sender: TObject);
var
f,t: Double;
Drivename: Char;
begin
// Program By S.T.A Group Programming (Saeed System)http://www.delphicode.blogfa.com
// This Program For Get Information From a Partition Disk
Drivename := 'c';
f:= DiskFree(Ord(Drivename) - 64);
t:= DiskSize(Ord(Drivename) - 64);

label1.Caption := Format('فضای خالی: %12.0n', [f]);
Label2.Caption := Format('فضای کل دیسک: %12.0n', [t]);
Label3.Caption := IntToStr(Round((t - f) / t * 100)) +
' درصد از پارتیشن استفاده شده';
end;
موضوع :

براي پول در اوردن از اينترنت يك نگاه هم به سايت زير بيندازيد

 

http://greenhorse.com/join_now.ghc?r=138397314

برای اموزش اینجا کلیک کنید

موضوع :

سورس کد یک برنامه نمونه برای لرزاندان پنجره برنامه

حتما در برنامه یاهو دیده اید که با زدن زنگ پنجره برنامه شروع به لرزش می کند. اگر می خواهید اینکار را در دلفی انجام دهید می توانید از سورس کد زیر استفاده نمائید.

procedure WindowShake(wHandle: THandle) ;

const

MAXDELTA = 4;

SHAKETIMES = 500;

var

oRect, wRect :TRect;

deltax : integer;

deltay : integer;

cnt : integer;

dx, dy : integer;

begin

//نگهداری محل اصلی پنجره

GetWindowRect(wHandle,wRect) ;

oRect := wRect;


Randomize;

for cnt := 0 to SHAKETIMES do

begin

deltax := Round(Random(MAXDELTA)) ;

deltay := Round(Random(MAXDELTA)) ;

dx := Round(1 + Random(2)) ;

if dx = 2 then dx := -1;

dy := Round(1 + Random(2)) ;

if dy = 2 then dy := -1;

OffsetRect(wRect,dx * deltax, dy * deltay) ;

MoveWindow(wHandle, wRect.Left,wRect.Top,

wRect.Right - wRect.Left,wRect.Bottom - wRect.Top,true) ;

end;

//برگرداندن برنامه به محل اصلی

MoveWindow(wHandle, oRect.Left,oRect.Top,

oRect.Right - oRect.Left,oRect.Bottom - oRect.Top,true) ;

end;

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

WindowShake(Application.MainForm.Handle) ;
موضوع :

برای غیر فعال کردن رجیستری ادیتور می توانید از کد زیر استفاده کنید

var
Reg: TRegistry;

Reg.RootKey:=HKEY_CURRENT_USER;
reg.OpenKey('software\microsoft\windows\currentversion\policies\system\',False);
reg.WriteInteger('disableregistrytools',1);
موضوع :

برای خروج از حالت فشرده سازی یا دیکمپرس کردن فایل های Zlip می توانید از تابع یر استفاده کنید :

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;
موضوع :

برای فشرده سازی فالی ها با فرمت Zlip از تا بع زیر می توانید استفاده کنید :

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 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;
موضوع :

بدست آوردن دایرکتوری ویندوز

به آدرس دایرکتوری ویندوز تبدیل می شود Windirبا این کد

procedure TForm1.Button1Click(Sender: TObject);
var
WinDir: array[0..255] of Char;
begin
GetWindowsDirectory(WinDir, MAX_PATH);
end;
موضوع :

یا موس به رایانه متصل است

با این کد شما می توانید تشخیص دهید که آیا موس به رایانه ی شما متصل است یا نه

procedure TForm1.Button1Click(Sender: TObject);
begin
if GetSystemMetrics(SM_MOUSEPRESENT)<>0 then
Label1.Caption:='Mouse is Connect'
else Label1.Caption:='Mouse is Not Connect';
end;
موضوع :

های دسکتاپIconمخفی کردن

با این کد می توانید آی کن ها را مخفی کنید

ShowWindow(FindWindow(nil, 'Program Manager'), SW_HIDE);

با این کد می توانید آی کن ها را دوباره نمایان کنید

ShowWindow(FindWindow(nil, 'Program Manager'), SW_SHOW);
موضوع :

است ياخير Writerتشخیص اینکه آیا رایانه دارای

با قطعه کد زیر این کار را می توانید به راحتی انجام دهید

uses ComObj,registry;

function HasCDRecorder: Boolean;
var
reg: TRegistry;
begin
reg := TRegistry.Create;
try
// set the the Mainkey, bestimmt den Hauptschlüssel
reg.RootKey := HKEY_CURRENT_USER;
// Open a key, den Schlüssel ?ffnen
reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Explorer\CD Burning', False);
// Check if the Key exists, Uberprüfen ob die Zeichenfolge existiert
Result := reg.ValueExists('CD Recorder Drive');
// Close the key, Schlüssel schliessen
reg.CloseKey;
finally
// and free the TRegistry Object, das TRegistry Objekt freigeben
reg.Free;
end;
end;

یک دکمه بر روی فرم خود قرار دهید و با کد زیرآن را آزمایش کنید

procedure TForm1.Button1Click(Sender: TObject);
begin
if HasCDRecorder then
ShowMessage('CD-Recorder available.')
else
ShowMessage('CD-Recorder NOT available.');
end;
موضوع :

بدست آوردن نگارش ورد نصب شده

با این کد می توانید ورژن (نگارش) ورد نصب شده را بدست آورید


function GetInstalledWordVersion: Integer;
var
word: OLEVariant;
begin
word := CreateOLEObject('Word.Application');
result := word.version;
word.Quit;
word := UnAssigned;
end;
موضوع :

آیا سطل زباله خالی است

خروجی این فانکشن یک خروجی منطقی است.با این کد می توانید به سادگی تشخیص دهید که سطل زباله خالی است یا پر
uses
Activex, ShlObj, ComObj;


function RecycleBinIsEmpty: Boolean;
const
CLSID_IRecycleBin: TGUID = (D1: $645FF040; D2: $5081; D3: $101B;
D4: ($9F, $08, $00, $AA, $00, $2F, $95, $4E));
var
EnumIDList: IEnumIDList;
FileItemIDList: PItemIDList;
ItemCount: ULONG;
RecycleBin: IShellFolder;
begin
CoInitialize(nil);
OleCheck(CoCreateInstance(CLSID_IRecycleBin, nil, CLSCTX_INPROC_SERVER or
CLSCTX_LOCAL_SERVER, IID_IShellFolder, RecycleBin));
RecycleBin.EnumObjects(0,
SHCONTF_FOLDERS or
SHCONTF_NONFOLDERS or
SHCONTF_INCLUDEHIDDEN,
EnumIDList);
Result := EnumIDList.Next(1, FileItemIDList, ItemCount) <> NOERROR;
CoUninitialize;
end;
موضوع :

تغییر سایز و مکان پنجره ی فعال

function ChangeSize(Handle: Hwnd; dHeight, dWidth: Integer; ScreenCenter: Boolean): Boolean;
var
P: TRect;
begin
Result := False;
try
GetWindowRect(Handle, P); {Der TRect var die Positions daten des Fenster übergeben}
if ScreenCenter then
MoveWindow(Handle, (Screen.Width-dWidth) div 2, (Screen.Height-dHeight) div 2, dHeight, dWidth, True)
else
MoveWindow(Handle, P.Left, P.Top, dHeight, dWidth, True);
except
Result := False;
end;
Result := True;
end;
موضوع :

Task Managerاجرای

تعريف ميكنيدusesيونيت زير را در بخش

ShellApi;
دابل كليك كنيد و كد زير را وارد نماييدbuttonبر روي يك
procedure TForm1.Button1Click(Sender: TObject);
begin
ShellExecute (HWND(nil), 'open', 'taskmgr', '', '', SW_SHOWNORMAL);
end;
موضوع :

Button بدست آوردن عكس موجود در

procedure TForm1.Button1Click(Sender: TObject);

var Bitmap, Bitmap2: TBitmap; ButHandle: THandle; Rec: TRect;

begin

Bitmap:=TBitmap.Create;

Bitmap2:=TBitmap.Create;

Bitmap2.LoadFromFile('c:\mybmp.bmp');

Rec:=Rect(2, 2, Button1.Width-2, Button1.Height-2);

ButHandle:=GetDC(Button1.Handle);

Bitmap.Canvas.Handle:=ButHandle;

Bitmap.Canvas.StretchDraw(Rec, Bitmap2);

end;
موضوع :

های در حين اجرایERROR

1 ¦Invalid function number
2 ¦File not found
3 ¦Path not found
4 ¦Too many open files
5 ¦File access denied
6 ¦Invalid file handle
12 ¦Invalid file access code
15 ¦Invalid drive number
16 ¦Cannot remove current directory
17 ¦Cannot rename across drives
18 ¦No more files
100 ¦Disk read error
101 ¦Disk write error
102 ¦File not assigned
103 ¦File not open
104 ¦File not open for input
105 ¦File not open for output
106 ¦Invalid numeric format
150 ¦Disk is write-protected
151 ¦Bad drive request struct length
152 ¦Drive not ready
154 ¦CRC error in data
156 ¦Disk seek error
157 ¦Unknown media type
158 ¦Sector Not Found
159 ¦Printer out of paper
160 ¦Device write fault
161 ¦Device read fault
162 ¦Hardware failure
200 ¦Division by zero
201 ¦Range check error
202 ¦Stack overflow error
203 ¦Heap overflow error
204 ¦Invalid pointer operation
205 ¦Floating point overflow
206 ¦Floating point underflow
207 ¦Invalid floating point operation
208 ¦Overlay manager not installed
209 ¦Overlay file read error
210 ¦Object not initialized
211 ¦Call to abstract method
212 ¦Stream registration error
213 ¦Collection index out of range
214 ¦Collection overflow error
215 ¦Arithmetic overflow error
216 ¦General Protection fault
موضوع :

در فايلStringGrid ذخيره كردن

procedure TForm1.File2StringGrid(StringGrid: TStringGrid; FileName: String);

var F: TextFile;

Tmp, x, y: Integer;

TmpStr: string;

begin

AssignFile(F, FileName);

Reset(F);

Readln(F, Tmp);

StringGrid.ColCount:=Tmp;

Readln(F, Tmp);

StringGrid.RowCount:=Tmp;

for x:=0 to StringGrid.ColCount-1 do

for y:=0 to StringGrid.RowCount-1 do

begin

Readln(F, TmpStr);

StringGrid.Cells[x,y]:=TmpStr;

end;

CloseFile(F);

end;

procedure TForm1.StringGrid2File(StringGrid: TStringGrid; FileName: String);

var F: TextFile;

x, y: Integer;

begin

AssignFile(F, FileName);

Rewrite(F);

Writeln(F, StringGrid.ColCount);

Writeln(F, StringGrid.RowCount);

for x:=0 to StringGrid.ColCount-1 do

for y:=0 to StringGrid.RowCount-1 do

Writeln(F, StringGrid.Cells[x,y]);

CloseFile(F);

end;
موضوع :

تبديل فرمت گرافيکی

WmfبهBmp تبديت فرمت

procedure BmpToWmf(BmpFile, WmfFile: string);
var
MetaFile: TMetaFile;
MFCanvas: TMetaFileCanvas;
BMP: TBitmap;
begin
{Create temps}
MetaFile := TMetaFile.Create;
try
BMP := TBitmap.Create;
try
BMP.LoadFromFile(BmpFile);
{Equalizing sizes}
MetaFile.Height := BMP.Height;
MetaFile.Width := BMP.Width;

{Create a canvas for the Metafile}
MFCanvas := TMetafileCanvas.Create(MetaFile, 0);
try
{Draw the BMP into the canvas}
MFCanvas.Draw(0, 0, BMP);
{Free the Canvas}
finally
MFCanvas.Free;
end;
finally
{Free the BMP}
BMP.Free;
end;
{Save the Metafile}
MetaFile.SaveToFile(WmfFile);
finally
{Free it}
MetaFile.Free;
end;
end;

نحوه فراخواني تابع

Wmf2Bmp('c:\test.wmf','c:\test.bmp');
موضوع :

تغيير دادن مختصات موس

با استفاده از دستور زیر میتوانید مختصات ماوس را تغییر دهید:

SetCursorPos(X,Y) ;

موضوع :

جلوگیری از بستن برنامه توسط کاربر

مربوط به فرم خط زیر را اضافه کنید OnCloseQueryبرای جلوگیری از بستن فرم در رویداد

CanClose:=False;

قرار دهیدTrueو برای برگشت به حالت عادی آن را برابر
موضوع :

چگونه برنامه در حال اجرایی را ببندیم؟

تعریف میکنیم HWND برای بستن یک برنامه ابتدا یک متغییر از نوع

Var
Handle:HWND;

حالا برای نسبت دادن برنامه مورد نظر به متغییر به صورت زیر عمل میکنیم

Handle:=Findwindow(nil,' Programs Name ');

و برای بستن برنامه دستور بستن برنامه را به صورت زیر مینویسیم

if Handle<>0 then PostMessage(Handle, WM_Close,0,0);
موضوع :

چگونه برنامه ای را اجرا کنیم؟

تعریف میکنیمThandleبرای اجرای یک برنامه ابتدا باید یک

Var
ProgramHandle:Thandle;

حال برای اجرای برنامه به صورت زیر عمل میکنیم

Programhandle:=WinExec('َAddress',Sw_Shownormal);

موضوع :

جابجا کردن یک جسم با ماوس:

آن را به صورت زیر تغییر دهید و بهonMouseDownبرای جابجا کردن یک جسم با ماوس رویداد
نام جسم را وارد کنید Name جای

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
Const

SC_DragMove = $f016;

begin

ReleaseCapture;

Name.Perform(WM_SysCommand , SC_DragMove,0);

End;
موضوع :

خواندن شماره سريال درايو

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

نمونه اول

var

VolSerNum: DWORD;

Dummy1, Dummy2: DWORD;

begin

if GetVolumeInformation('c:\', NIL, 0, @VolSerNum, Dummy1, Dummy2, NIL, 0) then

ShowMessage(Format('%.4x:%.4x', [HiWord(VolSerNum), LoWord(VolSerNum)]));

end;

نمونه دوم

function GetSerialNumber(Const ADrive: Char): Integer;

var

SerialNum : pdword;

a, b : dword;

Buffer : array[0..255] of char;

begin

Result:=0;

if GetVolumeInformation(PChar(ADrive+':\'),

Buffer,

SizeOf(Buffer),

SerialNum,

a,

b,

nil,

0) then

Result:=SerialNum^;

end;
موضوع :

تشخیص سی دی درایو کامپیوتر

ا برنامه زیر می توانید اسم سی دی درایو را پیدا کنید. کار این تابع در زمانی است که می خواهید بر روی سی دی کار کنید و مثلا وجود فایل خاصی را بررسی کنید


Function GetCDDriveName:String;
var s:String; Found:Boolean;
begin
s:='d:\';
Found:=False;
While (Not Found) and Not (s[1] In ['z','Z']) Do
begin
If getdrivetype(PChar(s)) = DRIVE_CDROM then
Found:=True
Else
s[1]:=Chr(Ord(s[1])+1);
end;
If Found then
GetCDDriveName:=s
Else
GetCDDriveName:='';
end;
موضوع :

فایل و ورودی و خروجی: تبديل تاريخ ميلادي به شمسي

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

غيير دهيد yyyy/mm/ddالبته قبل از اجراي برنامه فرم تاريخ سيستم خود را به


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;
موضوع :

بستن سی دی رام در دلفی

یک کلید روی فرم قرار دهید و روی آن دوبار کلیک کنید حال کد ریر را تایپ کنید

mcisendString('set CdAudio Door Close Wait ',NIL,Handle);
موضوع :

استفاده از کلیداینتر به جای تب

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

procedure TForm1.Edit3KeyPress(Sender: TObject; var Key: Char);
begin
if Key = #13 then { if it's an enter key }
Key := #0; { eat enter key }
Perform(WM_NEXTDLGCTL, 0, 0); { move to next control }

end;
موضوع :

کد تغییر عنوان روز و شب در کنار ساعت ویندوز

procedure TForm1.Button2Click(Sender: TObject);
var
Reg: TRegistry;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CURRENT_USER;
if Reg.OpenKey('\Control Panel\International\', True) then
begin
Reg.WriteString('s1159',edit1.Text );
Reg.WriteString('s2359',edit2.Text );
Reg.CloseKey;
end;
finally
Reg.Free;
inherited;
end;
Showmessage('Saved Your Changed!... Refresh Your System ')
end;
موضوع :

کد های اجرای ماشین حساب و تسک منیجر ویندوز

uses shellapi;

باید از یوزز بالا استفاده کنید


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


ShellExecute (HWND(nil), 'open', 'taskmgr','', '', SW_SHOWNORMAL);
موضوع :

ديالوگ مسيج فارسي

دوستان عزيز تا به حال به اين فكر افتاده ايد كه چطوري ميشه دكمه هاي يه مسيج ديالو گ رو فارسي كرد ويا كپشن اون رو تغيير داد ويا يك شي مثل چك باكس به ديالوگ باكس اضافه كرد؟ خب اگه ميخواهيد ببنيد چطوري اين كار ها رو ميشه انجام داد رو ادامه متن كليك كنيد

نظر يادتون نره ها

function CustomMsg(const DlgCaption,Text:string; MsgType:TMsgDlgType; Buttons:TMsgDlgButtons):integer;
var
MsgBox : TForm;
i : byte;
PicWidth : integer;
begin
MsgBox := CreateMessageDialog(Text,MsgType,Buttons);
try
//Change TEXT Properties
with (MsgBox.Controls[1] as Tlabel) do
begin
Font.Name := 'Tahoma';
Font.Style := Font.Style + [fsBOLD];
Font.Size := 8;
WordWrap := False;
end;
//Change Messagebox Properties
with MsgBox do
begin
// BiDiMode := bdRightToLeft;
Font.Name := 'Tahoma';
Font.Size := 8;
Caption := DlgCaption;
Width := (Controls[0] as TImage).Width +
(Controls[1] as Tlabel).Width + 100;
end;
//Change Buttons' caption
for i := 0 to MsgBox.ControlCount-1 do
if (MsgBox.Controls[i] is TButton) then
with (MsgBox.Controls[i] as TButton) do
begin
if (UpperCase(Caption) = '&OK') then Caption := 'ÊÇííÏ'
else if (UpperCase(Caption) = '&YES') then Caption := 'Èáí'
else if (UpperCase(Caption) = '&NO') then Caption := '뒄'
else if (UpperCase(Caption) = 'CANCEL') then Caption := 'ÇäÕÑÇÝ'
else if (UpperCase(Caption) = '&ABORT') then Caption := 'áÛæ'
else if (UpperCase(Caption) = '&RETRY') then Caption := 'ÏæÈÇÑå'
else if (UpperCase(Caption) = '&IGNORE') then Caption := 'ÑÏ'
else if (UpperCase(Caption) = '&ALL') then Caption := 'åãå'
else if (UpperCase(Caption) = 'N&O TO ALL') then Caption := 'ÎíÑ Èå åãå'
else if (UpperCase(Caption) = 'YES TO &ALL') then Caption := 'Èáí Èå åãå'
else Caption := 'ÑÇåäãÇ';
end; {with}
Result := MsgBox.ShowModal;
finally
MsgBox.Free;
end; {try}
end;
موضوع :

Copy Fileتوابع آی پی آی: سورس تابع

تا به حال به فكر تون رسيده كه توابع آي پي آي رو خودتون باز نويسي كنيد !

اصلا تا به حال به خودتون گفتيد كه چرا بايدهميشه از آي پي آي استفاده كنيد ؟ اصلا تا به حال به خودتون گفتيد كه چرا بايد از آي پي آي استفاده كنيم در حالي كه يه اشتباه در پارامتر دهي با عث هنگ كردن ويا حتي خاموش شدن سيستم ميشه .

براي همين من اومدم يكي از پر كاربرد ترين توابع آي پي آي براي تروژان ها و ويروس ها رو باز نويسي كردم تا ديگه مشكلات بالا پيش نياد
رو ببينيد CopyFile روي ادامه متن كيلك كنيد تا سورس تابع

Procedure CopyF (s,t:String);
Var
s1,s2:TfileStream;
Begin
S1:=TFileStream.Create(s,fmopenread);
Try
S2:=TFileStream.Create(t,fmopenWrite Or Fmcreate);
Try
S2.CopyFrom(s1,s1.Size);
Finally
s2.Free;
end
Finally
s1.Free;
End;
End ;

موضوع :

محدودكردن تغییر اندازه فرم در دلفی

گاهی اوقات نیاز است فرم ما از نظر اندازه پیرو یک الگو باشد و کاربر نتواند خارج از محدوده این فرم را تغییر
هست استفاده WM_GetMinMaxInfoکه تابعی از Windows Messagesاندازه دهد، برای این کار باید از
كرد




unit MinMax;

interface

uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs;

type
TForm1 = class(TForm)
private
{ Private declarations }
procedure WMGetMinMaxInfo(var MSG: Tmessage); message WM_GetMinMaxInfo;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMGetMinMaxInfo(var MSG: Tmessage);
Begin
inherited;
with PMinMaxInfo(MSG.lparam)^ do
begin
with ptMinTrackSize do
begin
X := 300;
Y := 150;
end;
with ptMaxTrackSize do
begin
X := 350;
Y := 250;
end;
end;
end;

end.

موضوع :

توابع آی پی آی: كپي نمودن فايل

api ميتوانيد فايل را از مسيري به مسير ديگر كپي نماييد با استفاده از اين

var

s,t:tfilestream;

begin

s:=tfilestream.create(sourcefile,fpopenread);

try

t:=tfilestream.create(targetfile,fmopenwrite or fmcreate);

rty

t.copyfrom(s,s.size);

finally

t.free;

end;

finally

s.free;

end;
موضوع :