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

[Keramatifar]

با سلام و عرض خیر مقدم خدمت برنامه نویسان و برنامه نویسان بعد از این :wink: ...
در این بخش میخوایم در مورد مسائل و نکاتی از برنامه نویسی کاربردی بحث کنیم، مواردی که بعد از رسم تمامی دیاگرام ها و فلوچارتهای برنامه به آنها میرسیم و مثل ... میمونیم تو گل
امیدوارم دوستان دیگر هم اگه نکاتی دارن که به درد بقیه هم میخوره حتماً در اینجا مطرح کنن ... .


-- با اجازه آقا محمد --
hr110 : آدرس نکات برنامه نویسی درون این پست به این شرح می‌باشند:

باز و بسته کردن سیدی درایو
تغییر Volume ویندوز
چگونه لیست سیدی درایوهای کامپیوتر را بدست آوریم
تغییر Resolution مونیتور
قرار دادن یک Bitmap در یک متافایل
بدست آوردن Serial Number درایو
از بین بردن یک Task در ویندوز
شناسایی یک فایل
کلیه اعمال قابل انجام روی فلاپی دیسک
دیالوگ برای Select Directory
روش چرخاندن یک نقطه در فضای دو بعدی حول یک نقطه دوبعدی دیگر:
Screen Shots
محاسبه سن یک فرد
محاسبه لگاریتم با پایه متغیر
ضرب اعداد صحیح بزرگ
استفاده از الگوریتم Base64 جهت Encoding و Decoding
محاسبه فاکتوریل یک عدد
محاسبه معکوس یک ماتریس
تعیین اول بودن یک عدد
تغییر مبنای یک عدد از مبنای هشت به Integer
تغییر مبنای یک عدد Integer به مبنای هشت
تعیین شماره روز در سال
تبدیل یک عدد هگزادسیمال به باینری
تغییر مقیاس یک تصویر
رندر متن یک TrichEdit در یک Canvas
تغییر وضوح یک Jpg
اعمال فیلتر Emboss روی یک تصویر
highlight کردن متن درون Twebbrowser
بدست آوردن پروسسهای فعال شبکه
ایجاد یک TWebBrowser در RunTime
استفاده از ClientSocket و ServerSocket
بدست آوردن لیست کاربران موجود در شبکه Remote
چاپ یک صفحه در TwebBrowser
انتخاب یک کامپیوتر در شبکه
لود کردن یک کد html بصورت مستقیم در TWebBrowser
ارسال پیام در ICQ
تبدیل یک فایل CSV به XML
لیست تمام فایلهای موجود در یک دایرکتوری
نصب یک فایل INF در دلفی
دسترسی به ListBox از طریق API
لیست تمام زیرپوشه های یک پوشه اصلی
جایگزینی یک متن درون TextFile
تغییر نام یک دایرکتوری
خواندن یک فایل table-textfile درون یک StringGrid
استفاده از توابع shell برای copy/move یک فایل
اضافه کردن اطلاعات به یک فایل EXE
پاک کردن یک فایل درون پوشه Document
توابع مفید جهت کار با Stream
تبدیل OEM به ANSI
ثبت خروجی یک برنامه DOS
قرار دادن یک فایل Exe درون برنامه و اجرای آن
پاک کردن برنامه توسط خودش بعد از اجرای آن
غیر فعال کردن دکمه Close در فرم
روش استفاده از TFileStream
جایگزینی یک Dll در حال استفاده از آن
تغییر صفات یک فایل
خواندن یک فایل متنی بصورت خط به خط و تغییر آن
تعیین فضای آزاد دیسک
استفاده از فایلهای INI
سایز یک دایرکتوری
کپی کردن یک فایل
روش بدست آوردن اطلاعات CPU
مشخص کردن وجود Terminal Service ها
کپی فایلهای دایرکتوری
تعیین نسخه MS Word نصب شده روی کامپیوتر
وارد کردن یک متن RTF در Word
فشرده سازی و ترمیم یک بانک اطلاعاتی Access
ایجاد Database در یک بانک اطلاعاتی sql sever 2000 در حالت local
پیدا کردن یک مقدار در فیلد ایندکس نشده به کمک TTable
تهیه خروجی از جداول ADO به فرمتهای مختلف
ایجاد خروجی از TDBGrid به قالب Excel
دسترسی به جداول paradox روی cdrom یا درایوهای Read Only
ایجاد یک جدول مجازی
ایجاد سریع یک جدول پارادوکس به کمک کد
ایجاد یک اتصال DBExpress در زمان اجرا
رنگ آمیزی یک TDBGrid
خواندن تمام رکوردهای یک جدول در TstringGrid
جلوگیری از لیست توماری شدن منو
به چرخش در آوردن متن
یافتن فایل در تمام شاخه و زیر شاخه هایش
بدست آوردن Handle یک پروسه با نام فایلش
فرم شفاف شده و فقط کنترل ها نشان داده شود
مخفی و ظاهر ساختن عنوان فرم
خذف یا انتقال فایل در حال اجرا توسط برنامه دیگر ( فقط در ویندوز نوع NT)
تعیین وضعیت مانیتور
طریقه بوت کردن ویندوز 2000 و XP
چگونه میتوان پنجره اضافه کردن چاپگر را نمایش داد
چگونه میتوان کنترل صفحه کلید را در تمامی ویندوزها بدست گرفت
کد خطا های زمان اجرای دلفی
نشان دادن تمام گزینه های منو در روی دکمه برنامه در Taskbar
زمان آخرین دسترسی به یک فایل
فهمیدن اینکه آیا یک ایمیل از نظر املایی درست است یا نه
حذف داده های تکراری از لیست
ساده ترین راه برای باز کردن یک فایل توسط برنامه مرتبط با آن
ایجاد سایه در زیر فرم ها
پیدا کردن یک پروسه در پروسه های دیگر با نام فایلش
تقریبا کلیه فانکشن هایی که برای کار با فلاپی نیاز میشه ...
بدست آوردن پسورد فایلهای اکسس 97
تشخیص نصب بودن یا نبودن کارت صدا ...
بدست آوردن و تنظیم کردن صدا در سیستم
چگونه دکمه Caps Lock را روشن و خاموش کنیم
چگونه می توان از جابجایی فرم جلوگیری کرد
چگونه می توان RecycleBin را خالی کرد
فرمت کردن یک دریاو در win32
عوض کردن wallpaper
این یه کد برای نوشتن یک عدد به حروف
ذخیره کردن یک فرم به عنوان یک عکس
Drop Dawn کردن آیتم های لیست باکس
گذاشتن هرگونه عکس بر روی BitBtn ...
نمایش صفحه مشخصات یک فایل ( Properties ) ...
مشخص نمودن وضعیت اتصال به اینترنت
بدت آوردن نام کاربر
Extract an Icon from EXE or DLL file
این تابع برنامه مورد نظر را اجر میکند و تا زمان خاتمه آن منتظر میماند.
روشن و خاموش کردن Numlock
نمایش سطرهای یک Grid به صورت یکی در میان
چگونه سایز Col را در یک DBGrid به صورت اتوماتیک قرار دهیم
اضافه نمودن یک کاربر جدید داخل یک دیتابیس در SQLServer 2000
کنترل ولوم صدا با استفاده از کد نویسی
نحوه استفاده بررسی خالی بودن کنترل TImage
رنگ آمیزی کنترلهای تمکرز یافته(Focused Control)
CheckBox در DBGrid
تبدیل عدد به حرف
نشان دادن فرم بدون دکمه ای در تسکبار
تشخیص اتصال به شبکه
چه مدت است که ویندوز شما در حال اجراست
ایجاد میانبر از یک فایل در ویندوز
minimize کردن کلیه پنجره ها
تغییر تاریخ سیستم
نمایش مجموع مقادیر در DbGrid
تغییر Resolution مونیتور
shutdown and restart and logof windows
تصویر توسعه‌دهندگان دلفی 7
تعریف آرایه های ثابت (Constant) در Delphi
دو کد نمونه برای کار با آرایه هایی از کامپوننتها
بر زدن (Shuffle) آرایه
تشخیص اتصال (connection) به اینترنت (internet)
دانلود (download) فایل از اینترنت با نمایش درصد پیشرفت (progress indicator)
خواندن (Get) لیست favorites از IE
تغییر صفحه Home Page در IE
بدست آوردن لیست NetWork Drive ها
تعیین screen saver
تعیین زمان در حال اجرا بودن windows
تشخیص Administrator بودن کاربر (user)
تبدیل RGB به CMYK
یافتن MyDouments برای کاربر جاری
Cool how Can I Read a unicode text file in Delphi
تغییر اندازه کلید Start
چک کردن اینکه آیا فایل در Local Drive می باشد.
چک کردن اینکه پارتیشن Fat میباشد یا NTFS
چک کردن اینکه آیا سرویسی مورد نظر start می باشد
چک کردن اینکه آیا Sound card نصب شده است
چک کردن اینکه آیا دلفی در حال اجراست
پیدا کردن و بارگذاری Icon داخل فایل
با این تابع می توانید ولوم سریالِ دیسک را بدست آوردید
چگونه Edit فقط عدد بگیرد
چگونه برنامه مان فقط یک نسخه اجرا شود
تغییر رزولوشن مانیتور
خالی کردن Editهای یک فرم
چک کردن خالی بودن یک مسیر
آیا فایل مورد نظر باینری است یا نوشتاری است
چگونه فایلهای INI را نصب کنی
چگونه تعداد ایتمها ی ListBox را با API بدست اوریم
چگونه یک ایتم ListBox را با API حذف کنی
چگونه ایتم انتخاب شده ی ListBox را توسط API بدست اوریم
گرفتن ایتم یک ایتم ListBox توسط API
بدست اوردن تمامی ایتم های یک ListBox توسط API
تغییر نام یک پوشه
باز کردن یک پوشه توسط Windows Explorer
بدست اوردن مالک ( Owner ) یک فای
مقایسه ی اندازه ی دو فایل
بدست اوردن تاریخ یک فایل
ایا فایل ما ASCII است
بدست اوردن حجم یک فایل
کپی کردن یک پوشه
جا به جا کردن یک پوشه
حذف یک پوشه
گرفتن مسیر جاری و تغییر مسیر جاری
کپی کردن فایل
خواندن Version Info یک فایل
ریختن یک فایل در سطل زباله ویندوز ...

[مهدی کرامتی]

سلام.

آقا محمد، به جامعه برنامه نویس خوش آمدی.

در ضمن، اگر میخواهی مطلب بنویسی یادت باشه که توضیحات انگلیسی‌اش رو هم حتما ترجمه کنی.

[Akam Zandi]

باسلام وتشکّر:
من روی هر لینکی که کلیک می کنم اون لینک باز نمی شه؟

[Keramatifar]

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

uses

  MMSystem;



procedure TForm1.Button1Click(Sender: TObject);

begin

{/باز کردن سیدی رام: در صورت موفقیت 0 برمیگرداند/}

 {/ open CD-ROM drive; returns 0 if successfull /}

  mciSendString('set cdaudio door open wait', nil, 0, handle);



  {/ close the CD-ROM drive; returns 0 if successfull /}

{/بستن سیدی رام: در صورت موفقیت 0 برمیگرداند/}

  mciSendString('set cdaudio door closed wait', nil, 0, handle);

end;

اینجانب بدینوسیله آمادگی پذیرش هر نوع انتقاد، راهنمایی و پیشنهاد را اعلام میدارم ...

[Keramatifar]

تغییر 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.Posit  ion*4369)*65536+longint(TrackBar1.Position  *4369));

end;

end;

و با TrackBar بازی کنید ...

[zahra_no]

تغییر 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;

و با TrackBar بازی کنید ...

برای waveOutSetVolume ایراد میگیره

[Keramatifar]

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

Function GetCDList : String;

Var

   I    : Integer;

  Drives: Integer;

  Tmp   : String;

begin

Drives := GetLogicalDrives;

  Result := '';

// units A=0 to el Z=25

  For I := 0 To 25 Do

    If (((1 Shl I) And Drives)<>0) Then

    Begin

      Tmp := Char(65+I)+':\';

      If (GetDriveType(PChar(Tmp))=DRIV  E_CDROM) Then

                                   Result := Result+Char(65+I);

     End;

End;

نتیجه یک استرینگ است که لیست سیدی درایوها را بترتیب نشان میدهد[/b]

[Keramatifar]

تغییر 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;

نکته بسیار مهم:

اگر اعداد غیر استاندارد برای Resolutoin مونیتور وارد کنید احتمال آسیب رسیدن به مونیتور وجود دارد، از رزولوشن های استاندارد مثل 320*240 ، 640*480 ، 1024*768 و ... استفاده کنید

[ali_abbasi22145]

تغییر 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;

نکته بسیار مهم:

اگر اعداد غیر استاندارد برای Resolutoin مونیتور وارد کنید احتمال آسیب رسیدن به مونیتور وجود دارد، از رزولوشن های استاندارد مثل 320*240 ، 640*480 ، 1024*768 و ... استفاده کنید

سلام
1-با اخطار دوستم کمی ترسیدم!!! 1024 را مثلا کجا و 768 را کجا وارد کنیم.
2- می شود اول چک کند که 1024*768 است اگر نباشد به این حالت مانیتور را ببرد.

[Keramatifar]

سلام
1-با اخطار دوستم کمی ترسیدم!!! 1024 را مثلا کجا و 768 را کجا وارد کنیم.
2- می شود اول چک کند که 1024*768 است اگر نباشد به این حالت مانیتور را ببرد.

برای اینکه رزولوشن فعلی مونیتور را بدست بیاری کافیه دو متغیر x,y از نوع int تعریف کنی و به این صورت عمل کنی:

x:= screen.width;

y:=screen.height

حالا رزولوشن صفحه رو توی دو متغیر داری (افقی داخل x و عمودی داخل y) موقعی که میخوای رزولوشن رو چک کنی که اگه مثلا 800 در 600 نبود عوضش کنه این کد رو بزن:

if (x<>800) and (y<>600) 

then ....

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

[shamshiri1]

خیلی ممنون ولی میخواستم بپرسم این پذوسجرهایی که اینجا نوشتید رو چچجوری من باید وارد برنامه کنم
آخه همش توی یک خطه و یکسری علامتهایی داره که مفهوم نیست

[Keramatifar]

قرار دادن یک Bitmap در یک متافایل

procedure TForm1.Button1Click(Sender: TObject);

var

  m : TmetaFile;

  mc : TmetaFileCanvas;

  b : tbitmap;

begin

  m := TMetaFile.Create;

  b := TBitmap.create;

  b.LoadFromFile('C:\SomePath\SomeBitmap.BMP  ');

  m.Height := b.Height;

  m.Width := b.Width;

  mc := TMetafileCanvas.Create(m, 0);

  mc.Draw(0, 0, b);

  mc.Free;

  b.Free;

  m.SaveToFile('C:\SomePath\Test.emf');

  m.Free;

  Image1.Picture.LoadFromFile('C:\SomePath\Test.emf'  );

end;

[Keramatifar]

بدست آوردن Serial Number درایو

procedure TForm1.Button1Click(Sender: TObject);

var

  VolumeName,

  FileSystemName     : array [0..MAX_PATH-1] of Char;

  VolumeSerialNo     : DWord;

  MaxComponentLength,

  FileSystemFlags    : Integer;

begin

  GetVolumeInformation('C:\',VolumeName,MAX_  PATH,@VolumeSerialNo,

                       MaxComponentLength,FileSystemFlags,

                       FileSystemName,MAX_PATH);

  Memo1.Lines.Add('VName = '+VolumeName);

  Memo1.Lines.Add('SerialNo = $'+IntToHex(VolumeSerialNo,8));

  Memo1.Lines.Add('CompLen = '+IntToStr(MaxComponentLength));

  Memo1.Lines.Add('Flags = $'+IntToHex(FileSystemFlags,4));

  Memo1.Lines.Add('FSName = '+FileSystemName);

end;

[Keramatifar]

از بین بردن یک Task در ویندوز
با استفاده از این فانکشن کوچولو میتونید هر نوع برنامه اجرا شده ای رو که پسوند .Exe دارد، از لیست Task Manager ویندوز پاک کنید
مثلا:

KillTask('notepad.exe');

           KillTask('iexplore.exe'); /}

uses

  Tlhelp32, Windows, SysUtils;

 

function KillTask(ExeFileName: string): integer;

const

  PROCESS_TERMINATE=$0001;

var

  ContinueLoop: BOOL;

  FSnapshotHandle: THandle;

  FProcessEntry32: TProcessEntry32;

begin

  result := 0;

 

  FSnapshotHandle := CreateToolhelp32Snapshot

                     (TH32CS_SNAPPROCESS, 0);

  FProcessEntry32.dwSize := Sizeof(FProcessEntry32);

  ContinueLoop := Process32First(FSnapshotHandle,

                                 FProcessEntry32);

 

  while integer(ContinueLoop) <> 0 do

  begin

    if ((UpperCase(ExtractFileName(FProce  ssEntry32.szExeFile)) =

         UpperCase(ExeFileName))

     or (UpperCase(FProcessEntry32.szExeFile&#4  1; =

         UpperCase(ExeFileName))) then

      Result := Integer(TerminateProcess(OpenProcess(

                        PROCESS_TERMINATE, BOOL(0),

                        FProcessEntry32.th32ProcessID), 0));

    ContinueLoop := Process32Next(FSnapshotHandle,

                                  FProcessEntry32);

  end;

 

  CloseHandle(FSnapshotHandle);

end;

[mamizadeh]

preocedure wallpaper;

begin

systemparametersinfo(spi_setdeskwallpaper,0,pchar(  'f:paniz.bmp'),0);

end;

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

[Keramatifar]

شناسایی یک فایل

function GetCheckSum (FileName : string) : DWORD;

var

  F : File of DWORD;

  Fsize : DWORD;

  Buffer : Array [0..500] of DWORD;

  P : Pointer;

begin

  FileMode := 0;

  AssignFile ( F , FileName);

  Reset ( F );

  Seek ( F , FileSize ( F ) div 2);

  Fsize := FileSize( F )-1-FilePos( F );

  if Fsize > 500 then Fsize := 500;

  BlockRead ( F, Buffer, Fsize);

  Close ( F );

  P:=@Buffer;

   asm

     xor eax, eax

     xor ecx, ecx

     mov edi , p

     @again:

       add eax, [edi + 4*ecx]

       inc ecx

       cmp ecx, fsize

     jl @again

     mov @result, eax

   end;

end;

[Mah6447]

محاسبه و نمایش مجموع مقادیر فیلدهای DbGrid
برداشت از سایت
http://search.experts-exchange.com/

[ali_abbasi22145]

محاسبه و نمایش مجموع مقادیر فیلدهای DbGrid
برداشت از سایت
http://search.experts-exchange.com/

سلام برنامه تان خطا می دهد!

[Mah6447]

سلام برنامه تان خطا می دهد!

فایل ضمیمه همان پست اصلاح شد ...

[دکمه64]

StatusBarروی ProgressBar نصب

StatusBar می باشد. انجام این کار بسیار ساده است. برای این کار کافی است بر روی فرم خود یک StatusBar اضافه نمایید حالا در قسمت تعاریف متغیر های عمومی کد زیر را بنویسید:

ProgressBar1: TprogressBar;

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

var
ProgressBarStyle: LongInt;
begin
{create a run progress bar in the status bar}
ProgressBar1 := TProgressBar.Create(StatusBar1);
ProgressBar1.Parent := StatusBar1;
{remove progress bar border}
ProgressBarStyle := GetWindowLong(ProgressBar1.Handle, GWL_EXSTYLE);
ProgressBarStyle := ProgressBarStyle - WS_EX_STATICEDGE;
SetWindowLong(ProgressBar1.Handle, GWL_EXSTYLE, ProgressBarStyle);
{set progress bar position and size - put in Panel[2]}
ProgressBar1.Left := StatusBar1.Panels.Items[0].Width +
StatusBar1.Panels.Items[1].Width + 4;
ProgressBar1.Top := 4;
ProgressBar1.Height := StatusBar1.Height - 6;
ProgressBar1.Width := StatusBar1.Panels.Items[2].Width - 6;
{set range and initial state}
ProgressBar1.Min := 0;
ProgressBar1.Max := 100;
ProgressBar1.Step := 1;
ProgressBar1.Position := 0;
end;

حالا برای آنکه پس از خارج شدن از فرم حافظه اشغال شده آزاد گردد، در قسمت

OnDestroy در Event فرمتان دستور زیر را اضافه نمایید:

ProgressBar1.free;

[Keramatifar]

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

==================================================  ===========

unit lDrives;

interface

uses Forms, Messages, Classes, WinProcs, WinTypes, SysUtils,

     Dialogs, Controls;

 

const

  MsgAskDefault = 'Please insert a disk on drive %s:';

  MsgWProtected = 'Error: The disk %s is write-protected.';

 

type

  TDriveType = (dtAll,dtFixed,dtRemovable,dtRemote{/$IFDE  F WIN32/},dtCDRom,dtRamDisk{/$ENDIF/}&#4  1;;

 

function ComposeFileName (Dir,Name:string):string;

function  HasDiskSpace({/$IFDEF WIN32/}Drive: string{/$ELSE/}Drive: char{/$ENDIF/}; MinRequired: LongInt): boolean;

function  GetDirectorySize(const Path: string): LongInt;

function  GetFileSizeByName(const Filename: string): longInt;

function  IsDiskRemovable(Drive: char): boolean;

function  IsDiskInDrive(Drive: char): boolean;

function  IsDiskWriteProtected(Drive: char): boolean;

function  AskForDisk(Drive: char; Msg: string; CheckWriteProtected: boolean): boolean;

procedure GetAvailableDrives(DriveType: TDriveType; Items: TStrings);

 

implementation

 

function ComposeFileName (Dir,Name:string):string;

var

  Separator: string[1];

begin

  if (length(Dir) > 0) and (Dir[length(Dir)]='\') then

    delete(Dir, length(Dir), 1);

  if (length(Name) > 0) and (Name[1]='\') then

    delete(Name, 1, 1);

  if Name='' then Separator:='' else Separator:='\';

  result:=format('%s%s%s',[Dir,Separator  ,Name]);

end;

 

function HasDiskSpace(Drive: {/$IFDEF WIN32/}string{/$ELSE/}char{/$ENDIF  /}; MinRequired: LongInt): boolean;

begin

  if Drive='' then Drive:='C';

  {/$IFDEF WIN32/}

  result:=((GetDriveType(PChar(D  rive))<>0) and

           (SysUtils.DiskFree(Ord(UpCase(Driv  e[1]))-$40)=-1) or

           (SysUtils.DiskFree(Ord(UpCase(Driv  e[1]))-$40)>=MinRequired));

  {/$ELSE/}

  result:=((GetDriveType(Ord(UpC  ase(Drive))-$40)<>0) and

           (DiskFree(Ord(UpCase(Drive)&#4  1;-$40)=-1) or

           (DiskFree(Ord(UpCase(Drive)&#4  1;-$40)>=MinRequired));

  {/$ENDIF/}

end;

 

function GetDirectorySize(const Path: string): LongInt;

var

  S: TSearchRec;

  TotalSize: LongInt;

begin

  TotalSize:=0;

  if FindFirst(ComposeFileName(Path,'*.*'), faAnyFile, S)=0 then

  repeat

    Inc(TotalSize, S.Size);

  until FindNext(S)<>0;

  result:=TotalSize;

end;

 

function GetFileSizeByName(const Filename: string): longInt;

var

  F: File;

begin

  AssignFile(F, Filename);

  Reset(F,1);

  result:=FileSize(F);

  CloseFile(F);

end;

 

function IsDiskRemovable(Drive: char): boolean;

begin

  {/$IFDEF WIN32/}

  result:=GetDriveType(PChar(Drive+'&#58  ;\'))=DRIVE_REMOVABLE;

  {/$ELSE/}

  result:=GetDriveType(ord(UpCase(Dr  ive))-65)=DRIVE_REMOVABLE;

  {/$ENDIF/}

end;

 

function IsDiskInDrive(Drive: char): Boolean;

var

  ErrorMode: word;

begin

  Drive:=Upcase(Drive);

  if not (Drive in ['A'..'Z']) then

    begin

      Result:=False;

      Exit;

    end;

  ErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);

  try

    if DiskSize(Ord(Drive) - 64) = -1 then

      Result := False

    else

      Result := True;

  finally

    SetErrorMode(ErrorMode);

  end;

end;

 

function IsDiskWriteProtected(Drive: char): Boolean;

var

  F: File;

  ErrorMode: Word;

begin

  ErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);

  AssignFile(F,Drive+':\_$.$$$');

  try

    try

      Rewrite(F);

      CloseFile(F);

      Erase(F);

      Result:=False;

    except

      Result:=True;

    end;

  finally

    SetErrorMode(ErrorMode);

  end;

end;

 

{/$IFDEF WIN32/}

procedure GetAvailableDrives(DriveType: TDriveType; Items: TStrings);

var

  Drive: Integer;

  DriveLetter: string;

begin

  Items.Clear;

  for Drive := 0 to 25 do

  begin

    DriveLetter := Chr(Drive + ord('A'))+':\';

    case DriveType of

      dtAll      : if GetDriveType(PChar(DriveLetter)) in [DRIVE_REMOVABLE,DRIVE_FIXED,DRIVE_REMOTE,

                                                           DRIVE_CDROM,DRIVE_RAMDISK] then

                     Items.Add(DriveLetter);

      dtRemovable: if GetDriveType(PChar(DriveLetter))=D  RIVE_REMOVABLE then

                     Items.Add(DriveLetter);

      dtFixed    : if GetDriveType(PChar(DriveLetter))=D  RIVE_FIXED then

                     Items.Add(DriveLetter);

      dtRemote   : if GetDriveType(PChar(DriveLetter))=D  RIVE_REMOTE then

                     Items.Add(DriveLetter);

      dtCDRom    : if GetDriveType(PChar(DriveLetter))=D  RIVE_CDROM then

                     Items.Add(DriveLetter);

      dtRamDisk  : if GetDriveType(PChar(DriveLetter))=D  RIVE_RAMDISK then

                     Items.Add(DriveLetter);

    end;

  end;

end;

{/$ELSE/}

procedure GetAvailableDrives(DriveType: TDriveType; Items: TStrings);

var

  Drive: Integer;

  DriveLetter: char;

begin

  Items.Clear;

  for Drive := 0 to 25 do

  begin

    DriveLetter := Chr(Drive + ord('A'));

    case DriveType of

      dtAll      : if GetDriveType(Drive) in [DRIVE_REMOVABLE,DRIVE_FIXED,DRIVE_REMOTE&#  93; then

                     Items.Add(DriveLetter+':\');

      dtRemovable: if GetDriveType(Drive)=DRIVE_REMOVABLE then

                     Items.Add(DriveLetter+':\');

      dtFixed    : if GetDriveType(Drive)=DRIVE_FIXED then

                     Items.Add(DriveLetter+':\');

      dtRemote   : if GetDriveType(Drive)=DRIVE_REMOTE then

                     Items.Add(DriveLetter+':\');

    end;

  end;

end;

{/$ENDIF/}

 

function AskForDisk(Drive: char; Msg: string; CheckWriteProtected: boolean): boolean;

var

  Ready     : boolean;

begin

  Ready:=false; Result:=false;

  if Msg='' then Msg:=Format(MsgAskDefault,[Drive]&  #41;;

  while not(Ready) do

    try

      if IsDiskRemovable(Drive) then

        case MessageDlg(Msg, mtConfirmation, [mbOk,mbCancel],0) of

          mrOk    : ready:=IsDiskInDrive(Drive);

          mrCancel: exit;

        end

      else

        Ready:=true;

    except

      result:=false;

      exit;

    end;

  ready:=false;

  while not(Ready) do

    try

      if CheckWriteProtected and IsDiskWriteProtected(Drive) then

        begin

          ready:=false;

          if MessageDlg(Format(MsgWProtected,[Upcas  e(Drive)+':']),mtError,[mb  Retry,mbCancel],0)=mrCancel then

            exit;

        end

      else

        ready:=true;

    except

      result:=false;

      exit;

    end;

  result:=Ready;

end;

 

end.

[Keramatifar]

اضافه کردن تکست به Log Files

function AddTextToFile(const aFileName, aText: string; AddCRLF: Boolean): Boolean;

var

  lF: Integer;

  lS: string;

begin

  Result := False;

  if FileExists(aFileName) then lF := FileOpen(aFileName, fmOpenWrite + fmShareDenyNone)

   else lF := FileCreate(aFileName);

  if (lF >= 0) then

    try

      FileSeek(lF, 0, 2);

      if AddCRLF then lS := aText + #13#10

else lS := aText;

      FileWrite(lF, lS[1], Length(lS));

    finally

      FileClose(lF);

    end;

end;

[Keramatifar]

دیالوگ برای Select Directory

uses FileCtrl; // for SelectDirectory

 

var

  Dir: string;

  (...)

  Dir := 'C:\Windows';

  if SelectDirectory(Dir, [sdAllowCreate, sdPerformCreate,

                           sdPrompt], 0) then

    Label1.Caption := Dir;

[پسر خاک]

روش چرخاندن یک نقطه در فضای دو بعدی حول یک نقطه دوبعدی دیگر:

const

  PIDiv180 = 0.017453292519943295769236907684886;

 

procedure Rotate(RotAng: Double; x, y, ox, oy: Double; var Nx, Ny: Double);

begin

  Rotate(RotAng, x - ox, y - oy, Nx, Ny);

  Nx := Nx + ox;

  Ny := Ny + oy;

end;

(* End Of Rotate Cartesian Point About Origin *)

 

 

procedure Rotate(RotAng: Double; x, y: Double; var Nx, Ny: Double);

var

  SinVal: Double;

  CosVal: Double;

begin

  RotAng := RotAng * PIDiv180;

  SinVal := Sin(RotAng);

  CosVal := Cos(RotAng);

  Nx := x * CosVal - y * SinVal;

  Ny := y * CosVal + x * SinVal;

end; 

[Keramatifar]

Screen Shots
با استفاده از این کد میتوانید تصویر Screen را در یک فایل Bitmap ذخیره نمائید. اگر نمیخواهید از یک برنامه فعال دلفی استفاده کنید میتوانید یک 'Application.Minimize;' در Beginning پروسیجر وارد کنید.

uses

  Windows, Graphics, Forms;

 

procedure TForm1.Button1Click(Sender: TObject);

var

  DC: HDC;

  Canvas: TCanvas;

  MyBitmap: TBitmap;

begin

  Canvas := TCanvas.Create;

  MyBitmap := TBitmap.Create;

  DC := GetDC(0);

 

  try

    Canvas.Handle := DC;

    with Screen do

    begin

      {/ detect the actual height and with of the screen /}

      MyBitmap.Width := Width;

      MyBitmap.Height := Height;

 

      {/ copy the screen content to the bitmap /}

      MyBitmap.Canvas.CopyRect(Rect(0, 0, Width, Height), Canvas,

                               Rect(0, 0, Width, Height));

      {/ stream the bitmap to disk /}

      MyBitmap.SaveToFile('c:\windows\desktop\sc  reen.bmp');

    end;

 

  finally

    {/ free memory /}

    ReleaseDC(0, DC);

    MyBitmap.Free;

    Canvas.Free

  end;

end;

[پسر خاک]

محاسبه سن یک فرد

function CalculateAge(Birthday, CurrentDate: TDate): Integer;

var

  Month, Day, Year, CurrentYear, CurrentMonth, CurrentDay: Word;

begin

  DecodeDate(Birthday, Year, Month, Day);

  DecodeDate(CurrentDate, CurrentYear, CurrentMonth, CurrentDay);

 

  if (Year = CurrentYear) and (Month = CurrentMonth) and (Day = CurrentDay) then

  begin

    Result := 0;

  end

  else

  begin

    Result := CurrentYear - Year;

    if (Month > CurrentMonth) then

      Dec(Result)

    else

    begin

      if Month = CurrentMonth then

        if (Day > CurrentDay) then

          Dec(Result);

    end;

  end;

end;

 

procedure TForm1.Button1Click(Sender: TObject);

begin

  Label1.Caption := Format('Your age is %d', [CalculateAge(StrToDate('01.01.1903'&#  41;, Date)]);

end; 

[پسر خاک]

محاسبه لگاریتم با پایه متغیر

function Log(x, b: Real): Real;

begin

  Result := ln(x) / ln(b);

end;

 

procedure TForm1.Button1Click(Sender: TObject);

begin

  ShowMessage(Format('%f', [Log(10, 10)]));

end; 

[پسر خاک]

ضرب اعداد صحیح بزرگ

type

  IntNo = record

    Low32, Hi32: DWORD;

  end;

 

function Multiply(p, q: DWORD): IntNo;

var

  x: IntNo;

begin

  asm

    MOV EAX,[p]

    MUL [q]

    MOV [x.Low32],EAX

    MOV [x.Hi32],EDX

  end;

  Result := x

end;

 

 

 

var

  r: IntNo;

begin

   r := Multiply(40000000, 80000000);

   ShowMessage(IntToStr(r.Hi32) + ', ' + IntToStr(r.low32))

end; 

[پسر خاک]

استفاده از الگوریتم Base64 جهت Encoding و Decoding

function Decode(const S: AnsiString): AnsiString;

const

  Map: array[Char] of Byte = (0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,

    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,

    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 62, 0, 0, 0, 63, 52, 53,

    54, 55, 56, 57, 58, 59, 60, 61, 0, 0, 0, 0, 0, 0, 0, 0, 1, 2,

    3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19,

    20, 21, 22, 23, 24, 25, 0, 0, 0, 0, 0, 0, 26, 27, 28, 29, 30,

    31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45,

    46, 47, 48, 49, 50, 51, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,

    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,

    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,

    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,

    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,

    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,

    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,

    0);

var

  I: LongInt;

begin

  case Length(S) of

    2: 

      begin

        I := Map[S[1]] + (Map[S[2]] shl 6);

        SetLength(Result, 1);

        Move(I, Result[1], Length(Result))

      end;

    3: 

      begin

        I := Map[S[1]] + (Map[S[2]] shl 6) + (Map[S[3]] shl 12);

        SetLength(Result, 2);

        Move(I, Result[1], Length(Result))

      end;

    4: 

      begin

        I := Map[S[1]] + (Map[S[2]] shl 6) + (Map[S[3]] shl 12) +

          (Map[S[4]] shl 18);

        SetLength(Result, 3);

        Move(I, Result[1], Length(Result))

      end

  end

end;

 

function Encode(const S: AnsiString): AnsiString;

const

  Map: array[0..63] of Char = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' +

    'abcdefghijklmnopqrstuvwxyz0123456789+/';

var

  I: LongInt;

begin

  I := 0;

  Move(S[1], I, Length(S));

  case Length(S) of

    1:

      Result := Map[I mod 64] + Map[(I shr 6) mod 64];

    2:

      Result := Map[I mod 64] + Map[(I shr 6) mod 64] +

        Map[(I shr 12) mod 64];

    3:

      Result := Map[I mod 64] + Map[(I shr 6) mod 64] +

        Map[(I shr 12) mod 64] + Map[(I shr 18) mod 64]

  end

end; 

[پسر خاک]

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

function FacIterative(n: Word): Longint;

var

  f: LongInt;

  i: Integer;

begin

  f := 1;

  for i := 2 to n do f := f * i;

  Result := f;

end; 

function FacRecursive(n: Word): LongInt;

begin

  if n > 1 then

    Result := n * FacRecursive(n-1)

  else

    Result := 1;

end; 

[ParsaNM]

تغییر اندازه کلید Start..

procedure TForm1.Button1Click(Sender: TObject);

begin

  MoveWindow(FindWindowEx(FindWindow('Shell_TrayWnd'  , nil), 0, 'Button', nil),

             300, 0, 80, 22, true);

end;

[ParsaNM]

چک کردن اینکه آیا فایل در Local Drive می باشد.

function IsOnLocalDrive(aFileName: string): Boolean;

var

  aDrive: string;

begin

  aDrive := ExtractFileDrive(aFileName);

  if (GetDriveType(PChar(aDrive)) = DRIVE_REMOVABLE) or

     (GetDriveType(PChar(aDrive)) = DRIVE_FIXED) then

    Result := True

  else

    Result := False;

end;





// Example:

procedure TForm1.Button1Click(Sender: TObject);

begin

  if OpenDialog1.Execute then

    if IsOnLocalDrive(OpenDialog1.FileName) then

      ShowMessage(OpenDialog1.FileName + ' is on a local drive.');

end;

[ParsaNM]

چک کردن اینکه پارتیشن Fat میباشد یا NTFS

 

 

 

function GetHardDiskPartitionType(const DriveLetter: Char): string;

var

  NotUsed: DWORD;

  VolumeFlags: DWORD;

  VolumeInfo: array[0..MAX_PATH] of Char;

  VolumeSerialNumber: DWORD;

  PartitionType: array[0..32] of Char;

begin

  GetVolumeInformation(PChar(DriveLetter + ':\'),

    nil, SizeOf(VolumeInfo), @VolumeSerialNumber, NotUsed,

    VolumeFlags, PartitionType, 32);

  Result := PartitionType;

end;

 

 

procedure TForm1.Button1Click(Sender: TObject);

begin

  ShowMessage(GetHardDiskPartitionType('c'));

  ShowMessage(GetHardDiskPartitionType('a'));

end;

 

[ParsaNM]

چک کردن اینکه آیا سرویسی مورد نظر start می باشد

 

 

 

 

uses

  WinSvc;

 

function ServiceGetStatus(sMachine, sService: PChar): DWORD;

  {******************************************}

  {*** Parameters: ***}

  {*** sService: specifies the name of the service to open

  {*** sMachine: specifies the name of the target computer

  {*** ***}

  {*** Return Values: ***}

  {*** -1 = Error opening service ***}

  {*** 1 = SERVICE_STOPPED ***}

  {*** 2 = SERVICE_START_PENDING ***}

  {*** 3 = SERVICE_STOP_PENDING ***}

  {*** 4 = SERVICE_RUNNING ***}

  {*** 5 = SERVICE_CONTINUE_PENDING ***}

  {*** 6 = SERVICE_PAUSE_PENDING ***}

  {*** 7 = SERVICE_PAUSED ***}

  {******************************************}

var

  SCManHandle, SvcHandle: SC_Handle;

  SS: TServiceStatus;

  dwStat: DWORD;

begin

  dwStat := 0;

  // Open service manager handle.

  SCManHandle := OpenSCManager(sMachine, nil, SC_MANAGER_CONNECT);

  if (SCManHandle > 0) then

  begin

    SvcHandle := OpenService(SCManHandle, sService, SERVICE_QUERY_STATUS);

    // if Service installed

    if (SvcHandle > 0) then

    begin

      // SS structure holds the service status (TServiceStatus);

      if (QueryServiceStatus(SvcHandle, SS)) then

        dwStat := ss.dwCurrentState;

      CloseServiceHandle(SvcHandle);

    end;

    CloseServiceHandle(SCManHandle);

  end;

  Result := dwStat;

end;

 

function ServiceRunning(sMachine, sService: PChar): Boolean;

begin

  Result := SERVICE_RUNNING = ServiceGetStatus(sMachine, sService);

end;

 

// Check if Eventlog Service is running

procedure TForm1.Button1Click(Sender: TObject);

begin

  if ServiceRunning(nil, 'Eventlog') then

    ShowMessage('Eventlog Service Running')

  else

    ShowMessage('Eventlog Service not Running')

end;

 

[پسر خاک]

محاسبه معکوس یک ماتریس

type

  RCOMat = array of array of Extended;



var

  DimMat: integer;



procedure InvertMatrix(var aa: RCOMat);

var

  numb, nula1, ipiv, indxr, indxc: array of Integer;

  i, j, l, kod, jmax, k, ll, icol, irow: Integer;

  amax, d, c, pomos, big, dum, pivinv: Double;

  ind: Boolean;

begin

  for j := 0 to Pred(DimMat) do ipiv[j] := 0;



  irow := 1;

  icol := 1;

  for i := 0 to Pred(DimMat) do

  begin

    big := 0;



    for j := 0 to Pred(DimMat) do

    begin

      if (ipiv[j] <> 1) then

      begin

        for k := 0 to Pred(DimMat) do

        begin

          if (ipiv[k] = 0) then

            if (Abs(aa[j, k]) >= big) then

            begin

              big  := Abs(aa[j, k]);

              irow := j;

              icol := k;

            end

            else;

        end;

      end;

    end;



    ipiv[icol] := ipiv[icol] + 1;

    if (irow <> icol) then

    begin

      for l := 0 to Pred(DimMat) do

      begin

        dum         := aa[irow, l];

        aa[irow, l] := aa[icol, l];

        aa[icol, l] := dum;

      end;

      for l := 0 to Pred(DimMat) do

      begin

        dum := aa[irow + DimMat + 1, l];

        aa[irow + DimMat + 1, l] := aa[icol + DimMat + 1, l];

        aa[icol + DimMat + 1, l] := dum;

      end;

    end;

    indxr[i] := irow;

    indxc[i] := icol;

    if (aa[icol, icol] = 0) then;

    pivinv         := 1.0 / aa[icol, icol];

    aa[icol, icol] := 1.0;

    for l := 0 to Pred(DimMat) do aa[icol, l] := aa[icol, l] * pivinv;

    for l := 0 to Pred(DimMat) do aa[icol + DimMat + 1, l] :=

        aa[icol + DimMat + 1, l] * pivinv;

    for ll := 0 to Pred(DimMat) do

    begin

      if (ll <> icol) then

      begin

        dum          := aa[ll, icol];

        aa[ll, icol] := 0.0;

        for l := 0 to Pred(DimMat) do aa[ll, l] := aa[ll, l] - aa[icol, l] * dum;

        for l := 0 to Pred(DimMat) do aa[ll + DimMat + 1, l] :=

            aa[ll + DimMat + 1, l] - aa[icol + DimMat + 1, l] * dum;

      end;

    end;

  end;



  for l := Pred(DimMat) downto 0 do

  begin

    if (indxr[l] <> indxc[l]) then

    begin

      for k := 0 to Pred(DimMat) do

      begin

        dum := aa[k, indxr[l]];

        aa[k, indxr[l]] := aa[k, indxc[l]];

        aa[k, indxc[l]] := dum;

      end;

    end;

  end;

end; 

[پسر خاک]

تعیین اول بودن یک عدد

unction IsPrime(N: Cardinal): Boolean; register;

  // test if N is prime, do some small Strong Pseudo Prime test in certain bounds

  // copyright (c) 2000 Hagen Reddmann, don't remove

asm

      TEST  EAX,1            {/ Odd(N) ?? /}

      JNZ   @@1

      CMP   EAX,2            {/ N == 2 ?? /}

      SETE  AL

      RET

@@1:  CMP   EAX,73           {/ N        JB    @@C /}

      JE    @@E              {/ N == 73 ?? /}

      PUSH  ESI

      PUSH  EDI

      PUSH  EBX

      PUSH  EBP

      PUSH  EAX              {/ save N as Param for @@5 /}

      LEA   EBP,[EAX - 1]    {/  M == N -1, Exponent /}

      MOV   ECX,32           {/ calc remaining Bits of M and shift M' /}

      MOV   ESI,EBP

@@2:  DEC   ECX

      SHL   ESI,1

      JNC   @@2

      PUSH  ECX              {/ save Bits as Param for @@5 /}

      PUSH  ESI              {/  save M' as Param for @@5 /}

      CMP   EAX,08A8D7Fh     {/  N = 9080191 ?? /}

      JAE   @@3

      // now if (N       MOV   EAX,31

      CALL  @@5              {/ 31^((N-1)(2^s)) mod N /}

      JC    @@4

      MOV   EAX,73           {/ 73^((N-1)(2^s)) mod N /}

      PUSH  OFFSET @@4

      JMP   @@5

      // now if (N @@3:   MOV   EAX,2

      CALL  @@5

      JC    @@4

      MOV   EAX,7

      CALL  @@5

      JC    @@4

      MOV   EAX,61

      CALL  @@5

@@4:  SETNC AL

      ADD   ESP,4 * 3

      POP   EBP

      POP   EBX

      POP   EDI

      POP   ESI

      RET

// do a Strong Pseudo Prime Test

@@5:  MOV   EBX,[ESP + 12]     {/ N on stack /}

      MOV   ECX,[ESP +  8]     {/ remaining Bits /}

      MOV   ESI,[ESP +  4]     {/ M' /}

      MOV   EDI,EAX            {/ T = b, temp. Base /}

@@6:  DEC   ECX

      MUL   EAX

      DIV   EBX

      MOV   EAX,EDX

      SHL   ESI,1

      JNC   @@7

      MUL   EDI

      DIV   EBX

      AND   ESI,ESI

      MOV   EAX,EDX

@@7:  JNZ   @@6

      CMP   EAX,1      {/ b^((N -1)(2^s)) mod N ==  1 mod N ?? /}

      JE    @@A

@@8:  CMP   EAX,EBP    {/ b^((N -1)(2^s)) mod N == -1 mod N ?? , EBP = N -1 /}

      JE    @@A

      DEC   ECX        {/ second part to 2^s /}

      JNG   @@9

      MUL   EAX

      DIV   EBX

      CMP   EDX,1

      MOV   EAX,EDX

      JNE   @@8

@@9:  STC

@@A:  RET

@@B:  DB    3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67  ,71

@@C:  MOV   EDX,OFFSET @@B

      MOV   ECX,18

@@D:  CMP   AL,[EDX + ECX]

      JE    @@E

      DEC   ECX

      JNL   @@D

@@E:  SETE  AL

end;

 

procedure TForm1.Button1Click(Sender: TObject);

begin

  if IsPrime(3453451) then

    ShowMessage('yes');

end;

 

{/**** Another function ***/}

 

function IsPrime(Prim: Longint): Boolean;

var

  Z: Real;

  Max: LongInt;

  Divisor: LongInt;

begin

  Prime := False;

  if (Prim and 1) = 0 then Exit;

  Z       := Sqrt(Prim);

  Max     := Trunc(Z) + 1;

  Divisor := 3;

  while Max > Divisor do

  begin

    if (Prim mod Divisor) = 0 then Exit;

    Inc(Divisor, 2);

    if (Prim mod Divisor) = 0 then Exit;

    Inc(Divisor, 4);

  end;

  Prime := True;

end; 

[پسر خاک]

تغییر مبنای یک عدد از مبنای هشت به Integer

function OctToInt(Value: string): Longint;

var 

  i: Integer;

  int: Integer;

begin

  int := 0;

  for i := 1 to Length(Value) do

  begin

    int := int * 8 + StrToInt(Copy(Value, i, 1));

  end;

  Result := int;

end; 

[پسر خاک]

تغییر مبنای یک عدد Integer به مبنای هشت

function IntToOct(Value: Longint; digits: Integer): string;

var

  rest: Longint;

  oct: string;

  i: Integer;

begin

  oct := '';

  while Value <> 0 do

  begin

    rest  := Value mod 8;

    Value := Value div 8;

    oct := IntToStr(rest) + oct;

  end;

  for i := Length(oct) + 1 to digits do

    oct := '0' + oct;

  Result := oct;

end; 

[پسر خاک]

تعیین شماره روز در سال

function GetDays(ADate: TDate): Extended;

var

  FirstOfYear: TDateTime;

begin

  FirstOfYear := EncodeDate(StrToInt(FormatDateTime('yy  yy', now)) - 1, 12, 31);

  Result      := ADate - FirstOfYear;

end;

 

procedure TForm1.Button1Click(Sender: TObject);

begin

  label1.Caption := 'Today is the ' + FloatToStr(GetDays(Date)) + '. day of the year';

end; 

[پسر خاک]

تبدیل یک عدد هگزادسیمال به باینری

function HexToBin(Hexadecimal: string): string;

const

  BCD: array [0..15] of string =

    ('0000', '0001', '0010', '0011', '0100', '0101', '0110', '0111',

    '1000', '1001', '1010', '1011', '1100', '1101', '1110', '1111');

var

  i: integer;

begin

  for i := Length(Hexadecimal) downto 1 do

    Result := BCD[StrToInt('$' + Hexadecimal[i])] + Result;

end;

 

procedure TForm1.Button1Click(Sender: TObject);

begin

  ShowMessage(HexToBin('FFA1'));

  // Returns 1111111110100001

end;