سورسهاي نمونه آموزشي

undocument messagebox
این تابع از توابع استاندارد ویندوز درون User32.dll هست که یک messagebox با قابلیت زماندهی برای بسته شدن میباشد

function MessageBoxTimeOut( 

      hWnd: HWND; lpText: PChar; lpCaption: PChar; 

      uType: UINT; wLanguageId: WORD; dwMilliseconds: DWORD): Integer; stdcall;

function MessageBoxTimeOutA( 

      hWnd: HWND; lpText: PChar; lpCaption: PChar; 

      uType: UINT; wLanguageId: WORD; dwMilliseconds: DWORD): Integer; stdcall;



function MessageBoxTimeOutW( 

      hWnd: HWND; lpText: PWideChar; lpCaption: PWideChar; 

      uType: UINT; wLanguageId: WORD; dwMilliseconds: DWORD): Integer; stdcall;



implementation 



// this const is not defined in Windows.pas 

const 

  MB_TIMEDOUT = 32000; 



function MessageBoxTimeOut; externaluser32 name 'MessageBoxTimeoutA'; 

function MessageBoxTimeOutA; external user32 name 'MessageBoxTimeoutA'; 

function MessageBoxTimeOutW; external user32 name 'MessageBoxTimeoutW'; 

نمونه مثال:

var 

  iResult: Integer; 

  iFlags: Integer; 

begin 

  // Define a MessagBox  with an OK button and a timeout of 2 seconds 

  iFlags  := MB_OK or MB_SETFOREGROUND or MB_SYSTEMMODAL or MB_ICONINFORMATION;

  iResult := MessageBoxTimeout( 

   Application.Handle, 

   'Test a timeout of 2 seconds.', 

   'MessageBoxTimeout Test', iFlags, 0, 2000); 



  // iResult will = 1 (IDOK) 

  ShowMessage(IntToStr(iRet)); 



  // Define a MessageBox with a Yes and No button and a timeout of 5 seconds 

  iFlags  := MB_YESNO or MB_SETFOREGROUND or MB_SYSTEMMODAL or MB_ICONINFORMATION; 



  iResult := MessageBoxTimeout( 

    Application.Handle, 

    'Test a timeout of 5 seconds.', 

    'MessageBoxTimeout Test', iFlags, 0, 5000); 



  // iResult = MB_TIMEDOUT if no buttons clicked, otherwise 

  // iResult will return the value of the button clicked 



  case iResult of 

  IDYES:  // Pressed Yes button 

    ShowMessage('Yes'); 



  IDNO:  // Pressed the No button 

    ShowMessage('No'); 



  MB_TIMEDOUT: // MessageBox timed out 

    ShowMessage('TimedOut'); 

  end; 

end; 

سلام ،

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

این نمونه برای یادگیری Callback Function ها منجمله EnumChildWindow بسیار مناسب هست .

با سلام.
توسط برنامه زیر اگه یه پیکسل مشکی انتخاب کنید . برنامه میگرده و بقیشو پیدا میکنه.
http://up.iranblog.com/images/dd1ygpnrrpw4624sfwwf.rar

استخراج تمامی ایمیل های موجود در یک رشته طولانی :

procedure TForm1.ExtractEmails(StrContent: string);

var

  i, r, P1, P2, DContinue: integer;

  Email, StrPre, StrPos: string;

begin

  StrContent := StringReplace(StrContent, #13#10, ' ', [rfReplaceAll]);

  StrContent := StrContent + #13#10;

  i := 1;

  ListBox1.Items.Clear;

  while (i <= length(StrContent)) do

  begin

    r := PosEx('@', StrContent, i);

    if r > 0 then

    begin

      StrPre := copy(StrContent, 1, r - 1);

      P1 := r + 1;

      StrPos := copy(StrContent, P1, length(StrContent));

      P2 := pos(' ', StrPos) - 1;

      //

      StrPre := ReverseString(StrPre);

      StrPre := ReverseString(copy(StrPre, 1, pos(' ', StrPre) - 1));

      StrPos := copy(StrPos, 1, P2);

      // Catch the email

      Email := StrPre + '@' + StrPos;

      if pos('.', Email) > 0 then

        ListBox1.Items.Add(Email);

      DContinue := P1 + P2;

    end

    else

    begin

      Break;

    end;

    // Continue searching

    i := DContinue + 1;

  end;

end;

نقل قول:

---

استخراج تمامی ایمیل های موجود در یک رشته طولانی

---

البته این تاپیک جای بحث نیست، ولی این کار رو میشه با Regular Expression با دقت و سرعت بالاتر، به راحتی انجام داد.

با سلام و خدا قوت خدمت سروران گرانقدر
چند روز پیش تاپیکی ایجاد کردم و در مورد چگونگی ضبط صوت سوال پرسیدم.
با راهنمایی جناب SAASTN برنامه کوچکی تهیه کردم.:خجالت:
گفتم شاید به درد دوستان بخوره.فایدش اینه که اگه مثلا در کار تقلید از قاریان قرآن باشیم یا بخواهیم صدای بازی ضبط کنیم، می تونیم ازش استفاده کنیم.(من خودم برای ضبط قسمتی از صوت تبلیغات لینا لوله ای ازش استفاده کردم:بامزه:)
گرچه برنامه Sound Recorder هم در خود ویندوز هست ولی من می خواستم قسمتی از صوت پخش شده از یک برنامه رو ضبط کنم فقط کمی از اول صوت رو ذخیره می کرد و بقیه فایل بدون صدا ضبط می شد ولی با این برنامه این مشکل رو نداشتم!!:گیج:
برای شروع و خاتمه ضبط باین برنامه ترکیب Ctrl+Space زا فشار دهید::تشویق:

ارتباط و کنترل avi برای ساخت لوگوهای آموزشی و تصویری

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

کدی جهت بدست آوردن تقاطع 2 خط بر حسب angle.
ابتدا با دو کلیک نقاط خط اول و سپس با دو کلیک دیگر نقاط خط دوم را وارد نمایید سپس تقاطع دو خط نمایش داده می شود.

unit Unit1;



interface



uses

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

  Dialogs, StdCtrls;



type

  TForm1 = class(TForm)

    Button1: TButton;

    procedure FormCreate(Sender: TObject);

    procedure FormMouseUp(Sender: TObject; Button: TMouseButton;

      Shift: TShiftState; X, Y: Integer);

  private

    { Private declarations }

  public

     index : Integer;

     p :Array[0..3] of TPoint;

  end;



var

  Form1: TForm1;



implementation



uses Math;



{$R *.dfm}

function GetDegree(p1,p2 : TPoint): Double;

begin

  Result :=  ArcTan2(p2.Y-p1.Y,p2.X -p1.X);

end;



function GetConflictPoint(p1,p2 : TPoint;deg1 ,deg2 : Double):TPoint;

var m1,m2 : Double;

    x ,y : Double;

begin

  m1 := tan( deg1);

  m2 := tan( deg2);



  X :=  (m1*p1.X - m2*p2.X + p2.Y - p1.Y) /(m1-m2);

  Y := m1 *(x- p1.X)+p1.Y;

  Result := point(round(x),round(y));

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

   index := 0;

end;



procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;

  Shift: TShiftState; X, Y: Integer);

 var resPoint : TPoint;

begin

  if index > 3 then

   begin

     index := 0;

     Canvas.FillRect(ClientRect);

   end;

  p[index] := point(x,y);

  if index mod 2 = 1 then

    begin

      Canvas.Ellipse(p[index-1].X-2,p[index-1].Y-2,p[index-1].X+2,p[index-1].Y+2);

      Canvas.Ellipse(p[index].X-2,p[index].Y-2,p[index].X+2,p[index].Y+2);

      Canvas.MoveTo(p[index-1].X,p[index-1].Y);

      Canvas.LineTo(p[index].X,p[index].Y);

      Caption := FloatToStr(GetDegree(p[index-1],p[index]));

    end;

  if index = 3 then

    begin

      resPoint := GetConflictPoint(p[0],p[2],GetDegree(p[0],p[1]),GetDegree(p[2],p[3]));

      Canvas.Ellipse(resPoint.X-2,resPoint.Y-2,resPoint.X+2,resPoint.Y+2);

    end;

  inc(index);

end;



end.

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

چند وقت پیش از روی بیکاری تصمیم گرفتم کتابخانه ای برای محاسبات بزرگ ریاضی بنویسم ، کتابخانه رو تا قسمت هایی توسعه دادم و بعد به دلیل کنکور و پروژه و ... نتونستم کاملش کنم .

پروژه ضمیمه شده شامل کتابخانه و نمونه برنامه کار با اون هست ، فعلا بخش جمع کتابخانه نوشته شده و عددهای بسیار بسیار بزرگ رو به درستی با هم جمع میکنه ؛ انشاالله اگر وقت کردم و تکمیلش کردم همین جا قرارش میدم .

برای نوشتن کتابخانه از روش آرایه استفاده شده ، با خوندن سورس کتابخانه روند کار دستتون میاد و میتونید خودتون توسعش بدید .

تو یکی از تاپیک ها یکی از کاربران ازم درخواست کرد تا نمونه کدی برای Split کردن یک فایل به چند فایل و سپس Merge کردن فایل های Split شده به یک فایل قرار بدم .

الان کمی بیکار بودم و یک نمونه برنامه نوشتم ، سعی کردم Comment ها واضح و گویا باشه .

موفق باشید .

امروز تو یکی از برنامه ها که داشتم مینوشتم نیاز به تولید اعداد تصادفی ( Random ) غیر تکراری داشتم و تابع زیر رو برای این کار نوشتم :

procedure GenerateRandomList(var NumberList: TStringList; const NumberOfRandomGenerated, RandomRange: Integer);

begin

  if RandomRange < NumberOfRandomGenerated then

    raise Exception.Create('Random range must be equal or greater than number of random generated !');



  NumberList.Duplicates := dupIgnore;

  NumberList.Sorted := True;

  RandSeed := MilliSecondOf(Now);

  repeat

    NumberList.Add(IntToStr(Random(RandomRange)));

  until (NumberList.Count = NumberOfRandomGenerated);

end;

این هم نمونه استفاده :

var

  RandomList: TStringList;

begin

  RandomList := TStringList.Create;

  try

    GenerateRandomList(RandomList, 10000, 20000);

    ListBox1.Items.Assign(RandomList);

  finally

    RandomList.Free;

  end;

end;

نقل قول:

---

MySQL Backup Maker

---

در مورد این برنامه به دو نکته جدید برخوردم :

1. یک قسمت برای بررسی اینکه جدول وجود دارد یا نه باید در نظر گرفته بشه تا در زمان فراخوانی پشتیبان، در صورتیکه جدول از بانک حذف شده بود به صورت خودکار ایجاد بشه.
2. بین خطوط 116 و 117 باید کد زیر اضافه بشه :

Qry.SQL.Text := 'DELETE FROM `' + TableName + '`';

      Qry.ExecSQL;

اینکار باعث میشه عملیات Replace روی رکورد ها انجام بشه.

با سلام
چند وقتی بود که دنبال یک برنامه کوچیک و جمع و جور می گشتم که باهاش بتونم رو سیستمی که SQL Server Express یا MSDE نصب شده، لیست دیتابیس ها رو ببینم و بتونم باهاش Attach و Detach دیتابیس هم انجام بدم.
چون برنامه جالبی پیدا نکردم خودم دست به کار شدم و این برنامه رو نوشتم.
امیدوارم به درد شما هم بخوره:

در اکثر برنامه هایی که با دلفی نوشته شده اند متاسفانه دیده می شود که منوها فونت خوبی ندارند. این موضوع در ویندوز های ویستا و سون به شکل بهتری قابل درک است. با استفاده از تکنیکی که در زیر به توضیح آن می پردازم به راحتی می توانید این مشکل را برطرف نمایید و برای همیشه از دست این مشکل رها شوید.
1- ابتدا یک کنترل TMainMenu بر روی فرم قرار دهید و گزینه های مورد نظر خود را به آن اضافه کنید.
2- خاصیت OwnerDraw مربوط به کنترل TMainMenu را به True تغییر دهید.
3- به رویداد OnCreate مرربوط به فرم رفته و کد های زیر را در آن بنویسید:

Screen.MenuFont.Name := 'tahoma';

حال می بینید که این مشکل برطرف شده است.

چک کردن جنیون بودن ویندوز

function IsWindowsGenuine() : Boolean;

const

  app_guid : TGUID = '{55C92734-D682-4D71-983E-D6EC3F16059F}';

  module   : string = 'Slwga.dll';

  api      : string = 'SLIsGenuineLocal';

var

  app_id : TGUID;

  state  : Byte;

  ret    : HRESULT;

  CheckGenuine : function (var appID : TGUID ; var result : Byte ; uReserved : Pointer): HRESULT;stdcall;

begin

  CheckGenuine := GetProcAddress(LoadLibrary(PChar(module)),PChar(ap  i));

  if @CheckGenuine <> nil then

  begin

     app_id := app_guid;

     ret := CheckGenuine(app_id,state,nil);

     if Succeeded(ret) then

     begin

       Result := (state = 0);

       SetLastError(ERROR_SUCCESS);

     end

     else

     begin

       Result := False;

       SetLastError(ERROR_ACCESS_DENIED);

     end;

  end

  else

  begin

    Result := False;

    SetLastError(ERROR_INVALID_FUNCTION);

  end;

end;



procedure TForm2.Button1Click(Sender: TObject);

begin

if (IsWindowsGenuine()) and (GetLastError() = ERROR_SUCCESS) then

ShowMessage('windows is genuine')

else

ShowMessage('window is not genuine');

end;

نقل قول:

---

نوشته شده توسط مجتبی تاجیک

امروز تو یکی از برنامه ها که داشتم مینوشتم نیاز به تولید اعداد تصادفی ( Random ) غیر تکراری داشتم و تابع زیر رو برای این کار نوشتم :

procedure GenerateRandomList(var NumberList: TStringList; const NumberOfRandomGenerated, RandomRange: Integer);

begin

  if RandomRange < NumberOfRandomGenerated then

    raise Exception.Create('Random range must be equal or greater than number of random generated !');



  NumberList.Duplicates := dupIgnore;

  NumberList.Sorted := True;

  RandSeed := MilliSecondOf(Now);

  repeat

    NumberList.Add(IntToStr(Random(RandomRange)));

  until (NumberList.Count = NumberOfRandomGenerated);

end;

این هم نمونه استفاده :

var

  RandomList: TStringList;

begin

  RandomList := TStringList.Create;

  try

    GenerateRandomList(RandomList, 10000, 20000);

    ListBox1.Items.Assign(RandomList);

  finally

    RandomList.Free;

  end;

end;

---

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

سلام به همگی
من یه دکمه ساده طراحی کردم.چند تا حالت از جمله دکمه بدون لبه داره.
برای حالتهای MouseUp ,Mouse Down ,MouseOver می تونین رنگ دکمه رو تعیین کنین.
اگه دوست داشتین بردارین::گیج:
ضمیمه 85827ضمیمه 85826

با سلام:قلب:
این هم یه برنامه ساده و دلچسب جستجو و نمایش کل متن قرآن کریم نوشته خودم!؟
لطفاً بزرگوارانی که قبلا برداشتن دوباره بردارند؛ چون هم اصلاحش کردم هم تکمیل..
(با قلم رایگان QuranTaha1 به همراه فایل متن کل قرآن کریم):
--
حالا آیه ای که با کلیک وسط آیات انتخاب کردیم کپی میشه نه آیه اول!
-------
یکی از دوستان سایت تقاضای سورس برنامه رو فرمودند. این برنامه در واقع قسمتی از یه برنامه حجیم دیگه نوشته خودمه که متن قرآن عثمان طه رو به همراه ترجمه استاد فولادوند نمایش میده. اما چون دسترسی به اینترنت پر سرعت ندارم فعلا نذاشتم.(ممکنه بعدا آپلود کنم و برای دانلود لینک بدم)
لطفا اگه کسی از رفقا روی رابط کاربری یا قسمت دیگه ای کار کرد نسخه اصلاح شده رو برای دانلود بذاره.
به طور مثال یکی از ایرادات برنامه اینه که وقتی از پنجره اصلی وارد پنجره متن کامل قرآن میشیم پنجره متن قرآن پرش داره. همچنین رابط گرافیکی اون رئال نیست و رنگهای خیلی شاد داره که ممکنه یکی بخواد از پوسته (Skin) یا تصویر قشنگتری برای رابط گرافیکی استفاده کنه.
اون رفیق عزیز فرمودند که ممکنه کسی بخواد ترتیل بهش اضافه کنه.
فکر نکنم کسی بتونه ترتیل آیه به آیه از اینترنت یا نرم افزاری گیر بیاره؛ اما ترتیل صفحه ای در آدرس http://haji-shohada.persianblog.ir/page/12 هست. برنامه پارس قرآن هم که منبع ترجمه برنامم بوده و برنامه قشنگیه. یه برنامه جستجو هست به نام AlMobin که جستجوی قرآن هست اما نتیجه قابل قبولی نداره مثلا اگه کلمه 'موسی' رو جستجو بدید متوجه میشید.
این هم سورس برنامه+یونیت ClrCtrls(خیلی پیش میخواستم روش کار کنم تکمیلش کنم.فعلا تو جزئیات همه کامپوننتهاش خورد نشین!):

سلام
یونیت پنجره پیغام و سوال و InputBox رنگی(جالبه بدونین که حرف ی- ي رو هم درست می کنه):
ضمیمه 85905
ضمیمه 85907
البته پروسیجرهای آقای شاهین عشایری رو هم تو یونیت ریختم. می تونین از راه InstallComponent یونیت رو نصب کنین و هر دفعه فقط MSGs رو به لیست Uses اضافه کنین.
یک کم توسعش دادم .اینها رو هم اضافه کردم:
ضمیمه 85906

برای کپی من با خطای Can not open file در کد های زیر در یونیت PBCopy مواجه شدم

procedure TCopyThread.CopyFile;

var

  S_FileStream, D_FileStream: TFileStream;

  Pos, Buff: Cardinal;

begin

  S_FileStream:= TFileStream.Create(SFile, fmOpenRead);

  D_FileStream:= TFileStream.Create(DFile, fmCreate + fmOpenWrite);

  Buff:= (S_FileStream.Size div 100);

  Pos:= 0;

  // Send max size of progress bar

  PostMessage(HWND, WM_UpdatePB, 0, (S_FileStream.Size div 100));

  try

    S_FileStream.Seek(0, soFromBeginning);

    D_FileStream.Seek(0, soFromBeginning);

    while Pos < S_FileStream.Size do

    begin

      if Pos+ Buff > S_FileStream.Size then

        Buff:= (S_FileStream.Size - Pos);

      D_FileStream.CopyFrom(S_FileStream, Buff);

      Inc(Pos, Buff);

      // Send current position of progress bar

      PostMessage(HWND, WM_UpdatePB, (Pos div 100), 0);

      S_FileStream.Position:= Pos;

      D_FileStream.Position:= Pos;

      Application.ProcessMessages;

    end;

  finally

    S_FileStream.Free;

    D_FileStream.Free;

  end;

end;

سلام به همه دوستان
آقا مجتبی تاجیک یه برنامه نوشته بودند برای گزارش هندل و خصوصیات دیگه پنجره و کامپوننت.
من یه کم روش کار کردم که بشه باهاش پیغام هم فرستاد.
استفاده اصلی این برنامه تعامل با برنامه های دیگه هست.
اگه خواستین سورس برنامه تغییر یافته رو بردارین:
ضمیمه 86267

ضمیمه 86266
من محتوای یونیت Messages رو تو یه فایل txt ریختم و تو برنامه پیغامها رو جدا می کنم و در یک ListBox می ریزم. دلفی من قدیمیه اگر دوست داشتین محتوای یونیت Messages دلفی خودتون رو رو توی فایل Messages.txt کنار برنامه بریزین تا کامل تر بشه.وقتی در لیست باکس مربوط به نام پیغام هستین می تونین کارکتر اول نام پیغام (بدون پیشوند!) رو فشار بدین تا یکراست (چیزی مثل AutoComplete) به اون پیغام منتقل بشین!
اگه نمی دونستین کدوم پیغام به دردتون میخوره می تونین دکمه View Messages Text File رو فشار بدین و در فایل جستجو بدینتا پیغام مربوطه رو پیدا کنین.البته بعضی پیغامها تو یونیت Windows هستند که البته اگه خواستین می تونین پیغامهاش رو تو فایل Messages.txt بریزین و توی برنامه استفاده کنین.
برای تولید کد یا ارسال پیام روی کامپوننت یا فرم مورد نظر برین و Ctrl+Space رو فشار بدین و بعد دکمه مربوطه رو در برنامه فشار بدین تا برنامه با استفاده از اطلاعات کادرهای بالای فرم کد رو تولید کنه یا پیغام رو بفرسته.Ctrl+L هم باعث میشه برنامه چیزی گزارش نکنه!
توی کادر پارامترها هم می تونین عدد یا رشته وارد کنین. دکمه Send Message هم پیغام می فرسته هم کد ایجاد می کنه.
یک تجربه:
من هندل یک کامپوننت رو نداشتم با ;(متن کامپوننت,نام کلاس کامپوننت)FindWindow نتونستم هندش رو بدست بیارم!
ولی اگه هندل کامپوننت رو دارین با کد جناب MohsenB می تونین هندل فرم رو بدست بیارین:

function GetFormHandle(ObjHandle: THandle): THandle;

begin

  if GetParent(ObjHandle) = 0 then

    Result := ObjHandle

  else

    Result := GetFormHandle(GetParent(ObjHandle));

end;

سلام دوستان!



این هم یک برنامه ماشین حساب :



که چهار عمل اصلی + توان را حساب می کند و شما با فهمیدن این برنامه تاحد خوبی برنامه نویسی در دلفی را خواهید آموخت.



دانلود کنید.

سلام.
کنترل TUpDown برای تغییر عدد تو کادر TEdit استفاده میشه که من یه تغییر کوچیکی توش دادم که موقع کلیک کردن رو دکمه هاش میتونید کلید موس رو نگه دارید و به بالا و پایین درگ کنید و با حرکت موس عدد رو تنظیم کنید. کامپوننتش :

unit SpinnerUpDown;



interface



uses

  SysUtils, Classes, Controls, ComCtrls, Types, Windows;



type

  TSpinnerUpDown = class(TUpDown)

  private

    _Scale : Single;

    procedure MyOnMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);

  protected

  public

    constructor Create(AOwner : TComponent);override;

  published

    property Scale : Single read _Scale write _Scale;

    property AlignButton;

    property Anchors;

    property Associate;

    property ArrowKeys;

    property DoubleBuffered;

    property Enabled;

    property Hint;

    property Min;

    property Max;

    property Increment;

    property Constraints;

    property Orientation;

    property ParentDoubleBuffered;

    property ParentShowHint;

    property PopupMenu;

    property Position;

    property ShowHint;

    property TabOrder;

    property TabStop;

    property Thousands;

    property Visible;

    property Wrap;

    property OnChanging;

    property OnChangingEx;

    property OnContextPopup;

    property OnClick;

    property OnEnter;

    property OnExit;

    property OnMouseActivate;

    property OnMouseDown;

    property OnMouseEnter;

    property OnMouseLeave;

    property OnMouseMove;

    property OnMouseUp;

  end;



procedure Register;



implementation



procedure TSpinnerUpDown.MyOnMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);

{$J+}

const

  MouseLastPos : TPoint = (X : 0; Y : 0);

  currVal : Integer = 0;

  r : TRect = ();

{$J-}

var

  p : TPoint;

begin

  if (GetAsyncKeyState(VK_LBUTTON) and $8000 = 0) then

  begin

    GetCursorPos(MouseLastPos);

    GetWindowRect((Sender as TWinControl).Handle, r);

  end else begin

    GetCursorPos(p);

    SetFocus;



    if (MouseLastPos.X <> p.X) or (MouseLastPos.Y <> p.Y) then

    begin

      currVal := currVal + p.Y - MouseLastPos.Y;//Point(X - MouseLastPos.X, Y - MouseLastPos.Y);

      if (Abs(currVal * _Scale) > 1.0) then

      begin

        (Sender as TUpDown).Position := (Sender as TUpDown).Position - Trunc(currVal * _Scale);

        if Assigned(Associate) then

          Associate.Update;

        currVal := 0;

      end;

      GetWindowRect((Sender as TWinControl).Handle, r);

      MouseLastPos := Point(r.Left - 5, (r.Top + r.Bottom) div 2);

      SetCursorPos(MouseLastPos.X, MouseLastPos.Y);

    end;

  end;

end;



constructor TSpinnerUpDown.Create(AOwner : TComponent);

begin

  inherited Create(AOwner);

  _Scale := 0.1;

  Self.OnMouseMove := MyOnMouseMove;

end;



procedure Register;

begin

  RegisterComponents('MHD', [TSpinnerUpDown]);

end;



end.

نقل قول:

---

نوشته شده توسط مهران رسا

در طول انجام یه پروژه نیاز شد تا از بانک Mysql به صورت داخلی پشتیبان بگیرم. یه نمونه کد نوشتم که البته بیشتر وقتم صرف قسمت پردازش رشته ای و ذخیره و بازیابی اطلاعات شد.

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

• استفاده از کلاس ini برای ذخیره سازی اطلاعات جداول در فایل
• استفاده از توابع String Encoder برای حفظ امنیت اطلاعات جداول
• استفاده از کامپوننت DbExpress برای تعامل با MySQL

ضمیمه 74846

procedure TForm1.CreateBackup;

var

  i, j: integer;

  IniFile: TIniFile;

  TableName, FieldName, FieldValue, TmpValues, CodedStr: string;

var

  StrEnc: TStrEncoder;

begin

  if LST.Items.Count < 1 then

  begin

    LbSt.Caption := 'Status : Canceled';

    exit;

  end;

  SaveDlg.FileName := '';

  SaveDlg.Filter := 'M8B Files|*.m8b';

  SaveDlg.DefaultExt := 'm8b';

  SaveDlg.Execute();

  if SaveDlg.FileName = '' then

  begin

    LbSt.Caption := 'Status : Canceled';

    exit;

  end;

  if FileExists(SaveDlg.FileName) then

    DeleteFile(SaveDlg.FileName);



  StrEnc := TStrEncoder.Create(nil);

  IniFile := TIniFile.Create(SaveDlg.FileName);

  Pr.Position := 0;

  Pr.Max := LST.Items.Count - 1;

  try

    for i := 0 to LST.Items.Count - 1 do

    begin

      Pr.Position := i;

      TableName := LST.Items[i].Caption;

      if LST.Items[i].Checked then

      begin

        // Get list of fileds

        Qry.SQL.Text := 'SHOW COLUMNS FROM ' + TableName;

        Qry.Open;

        while not(Qry.Eof) do

        begin

          FieldName := Qry.Fields[0].AsString;

          if FieldName <> '' then

          begin

            Qry2.SQL.Text := 'SELECT ALL `' + FieldName + '` FROM `' +

              TableName + '`';

            Qry2.Open;

            if Qry2.RecordCount > 0 then

            begin

              TmpValues := '';

              Pr2.Position := 0;

              Pr2.Max := Qry2.RecordCount;

              for j := 0 to Qry2.RecordCount - 1 do

              begin

                Pr2.Position := j;

                FieldValue := Qry2.FieldByName(FieldName).AsString;

                if FieldValue = '' then

                begin

                  FieldValue := SEmpty;

                  CodedStr := FieldValue;

                end

                else

                begin

                  CodedStr := StrEnc.StringCoder(FieldValue);

                end;

                TmpValues := TmpValues + ',' + CodedStr;

                Qry2.Next;

              end; // for j

              IniFile.WriteString(TableName, FieldName, TmpValues);

            end; // if Qry2.RecordCount

          end; // if FieldName <> ''

          Qry.Next;

        end; // while not(Qry.Eof)

      end; // if LST.Items[i].Checked

    end;

  finally

    IniFile.free;

    StrEnc.free;

  end; // try

  Pr.Max := 1;

  Pr.Position := Pr.Max;

  Pr2.Max := 1;

  Pr2.Position := Pr2.Max;

  LbSt.Caption := 'Status : Done';

end;



procedure TForm1.RestoreBackup;

var

  StrEnc: TStrEncoder;

var

  IniFile: TIniFile;

  Tstr, TstrSectionValues, TstrValues: TStringList;

  i, j, k, m, Cl: integer;

  TableName, FieldName, GroupValue: string;

  Tmp, Tmp2, Tmp3, SqlSmnt: string;

  VArray: array of array of string;

begin

  OpenDlg.FileName := '';

  OpenDlg.Filter := 'M8B Files|*.m8b';

  OpenDlg.DefaultExt := 'm8b';

  OpenDlg.Execute();

  if OpenDlg.FileName = '' then

    exit;

  LST2.Items.Clear;

  StrEnc := TStrEncoder.Create(nil);

  IniFile := TIniFile.Create(OpenDlg.FileName);

  Tstr := TStringList.Create;

  TstrSectionValues := TStringList.Create;

  TstrValues := TStringList.Create;

  try

    IniFile.ReadSections(Tstr);

    Pr.Position := 0;

    Pr.Max := Tstr.Count - 1;

    for i := 0 to Tstr.Count - 1 do

    begin

      TableName := Tstr[i];

      SqlSmnt := 'INSERT INTO `' + TableName + '` (';

      Pr.Position := i;

      IniFile.ReadSection(TableName, TstrSectionValues);

      Tmp := '';

      Tmp2 := '';

      TstrValues.Clear;

      for j := 0 to TstrSectionValues.Count - 1 do

      begin

        FieldName := TstrSectionValues[j];

        Tmp := Tmp + '`' + FieldName + '`,';

        GroupValue := IniFile.ReadString(TableName, FieldName, '');

        StrEnc.split(',', GroupValue, TstrValues);

      end;

      Cl := (TstrValues.Count) div (TstrSectionValues.Count);

      Pr2.Position := 0;

      Pr2.Max := Cl - 1;

      for k := 0 to Cl - 1 do

      begin

        Pr2.Position := k;

        m := k;

        Tmp3 := '';

        while (m < (TstrValues.Count)) do

        begin

          if UpperCase(TstrValues[m]) = SEmpty then

            Tmp2 := ''

          else

            Tmp2 := StrEnc.StringDecoder(TstrValues[m]);

          Tmp3 := Tmp3 + '"' + Tmp2 + '",';

          m := m + Cl;

        end;

        SqlSmnt := SqlSmnt + copy(Tmp, 1, length(Tmp) - 1) + ') VALUES(' + copy

          (Tmp3, 1, length(Tmp3) - 1) + ')';

        Qry.SQL.Text := SqlSmnt;

        try

          Qry.ExecSQL;

        except

          on e: exception do

          begin

            LST2.Items.Add('Table ' + TableName + ' : ' + e.Message);

          end;

        end;

        SqlSmnt := 'INSERT INTO `' + TableName + '` (';

      end;

    end;

  finally

    StrEnc.free;

    IniFile.free;

    Tstr.free;

    TstrSectionValues.free;

    TstrValues.free;

  end;

  Pr.Max := 1;

  Pr.Position := Pr.Max;

  Pr2.Max := 1;

  Pr2.Position := Pr2.Max;

end;

نکته 1 : برای ارتباط DbExpress با Mysql به درایور های مربوطه (dbxmys.dll و libmySQL.dll) نیاز دارید.
نکته 2 : پیشنهاد میشه به صورت دلخواه از توابع Optimize کننده هم استفاده کنید.

---

من نمي توانم پروژه را اجرا کنم راجع به اين سه فايل پيغام ميدهد؟
WideStrings, DBXMySql

[Fatal Error] Unit1.pas(11): File not found: 'WideStrings.dcu'
ممنون مي شوم کمک کنيد
ضمنا درایور های مربوطه (dbxmys.dll و libmySQL.dll) را از کجا بياورم؟؟

نقل قول:

---

من نمي توانم پروژه را اجرا کنم راجع به اين سه فايل پيغام ميدهد؟
WideStrings, DBXMySql

---

این فایل ها به همراه دلفی وجود دارند. احتمالاً بنا به دلایلی فایل dcu مربوط به آنها از سیستم شما حذف شده است. اگر این مشکل رو با یونیت های دیگر هم دارید به نظر من بهتره که دلفی رو دوباره نصب کنید.

نقل قول:

---

ضمنا درایور های مربوطه (dbxmys.dll و libmySQL.dll) را از کجا بياورم؟؟

---

فایلهایی که اول نامشون dbx هست با نصب دلفی به سیستم کپی می شوند و فایل دیگر هم با نصب آن DBMS خاص (در اینجا MySQL) به سیستم کپی می شوند.

_

برنامه ی تبدیل یک فایل به فایل های کوچک تر.
احتمالا شما هم به فایل هایی برخوردید که خیلی حجمشون زیاده و بخواید اونا رو تو فلش و یا dvd بریزید ولی به دلیل حجم بالا نتونید این کارو بکنید و بخواید اون فایل رو تیکه تیکه کنید و بعد با فلش یا dvd جابجا کنید و رو سیستم مقصد اونا رو بچسبونید. من برنامشو نوشتم. البته حتما برنامه هایی ازین قبیل نوشته شدن و استفاده میشن ولی من دوست داشتم خودم برنامه رو بنویسم. این برنامه فایل ها رو به قطعات 64 مگابایتی تقسیم میکنه. از روشی استفاده کردم که کل فایل لازم نباشه یکجا بیاد روی رم و مثلا تو سیستم من که 4 گیگ رم داره می شه فایل 20 گیگابایتی رو تیکه تیکه کرد چون برای تیکه کردن فایل لازم نیست اون رو روی رم بارگذاری کنیم و 64 مگابایت، 64 مگابایت پیش میره که رو اکثر سیستما جواب بده.
فقط فرصت نکردم دکمه ی Cancel براش بگذارم اگه دیدید کارش طولانی شد و خواستید cancel اش کنید از روش Alt + Ctrl + Delete استفاده کنید.
http://uplod.ir/von20v52jvvy/FileCutter.zip.htm

عكس گرفتن از Desktop يا از پنجره فعال

دانلود سورس كد

ساعت باينري

http://www.planet-source-code.com/Up...0235376278.JPG

دانلود سورس كد

بدست آوردن موقعيت دقيق موس با كشيدن دو خط افقي و عمودي

http://0.tqn.com/d/delphi/1/G/o/e/xmouse.gif

دانلود سورس كد

اجراي افكت روي متن

a
b...
d
da
db...
de
dea
deb
dec...
del
dela
delb
delc...
delp
...
delphi rulez

دانلود سورس كد

به لرزه در آوردن فرم دلخواهتون

دانلود سورس كد

يك خط كش توپ براي ويندوز
خداييش خودمم ديدم شوك شدم:خجالت:

دانلود سورس كد

http://0.tqn.com/d/delphi/1/0/B/e/ls...creenruler.png

اينم يك سورس كه باهاش ميشه هر برنامه اي كه مي خواند سريع اجرا كنيد تو اين نرم افزار Add كنيد و بعد با دابل كليك روي آن ها ، اجراشون كنيد

دانلود سورس كد

http://0.tqn.com/d/delphi/1/G/Q/c/fdac_applauncher.png

یاده سازی الگوریتم کلونی مورچه ها با دلفی
http://0.tqn.com/d/delphi/1/G/d/e/fdac-ants.gif

دانلود سورس كد

تا حالا با مكينتاش كار كردين؟
من با گجت پايينش خيلي حال مي كنم
http://0.tqn.com/d/delphi/1/G/X/e/doc-app-launcher.gif

دانلود سورس كد

يك launcher جديد

دانلود سورس كد

http://0.tqn.com/d/delphi/1/G/e/c/fdac_wiilauncher.png

نقل قول:

---

نوشته شده توسط SayeyeZohor

ساعت باينري

http://www.planet-source-code.com/Up...0235376278.JPG

دانلود سورس كد

---

کی این کد رو نوشته ؟ باید به صورت زیر تغییر پیدا کنه وگرنه در زمان های تک رقمی مشکل پیدا میکنه :

var

  Str: String;

  Hour, Min, Sec, MSec: Word;

begin

  Str := TimeToStr(Time);



  DecodeTime(Now, Hour, Min, Sec, MSec);



  // recive 'binary' string

  Label1.caption := IntToBin(Hour) + ':' + IntToBin(Min) + ':' + IntToBin(Sec);



  // this label is for the others 01 people who don't

  Label2.caption := Str;

end;

نقل قول:

---

نوشته شده توسط SayeyeZohor

اين يك بازي توپ با مورچه ها
http://0.tqn.com/d/delphi/1/G/d/e/fdac-ants.gif

دانلود سورس كد

---

این بازی نیست ؛ پیاده سازی الگوریتم کلونی مورچه ها با دلفی هست !

سلام
من یک برنامه درست کردم برای multi ping کردن که به صورت فرم MDI می باشد ولی بلد نیستم که از Thread ها استفاده بکنم کسی می تواند کمک بکند.
اگر بشود از Thread استفاده کرد برای هر فرمی که ساخته می شود (هر IP یک نام که برای کپشن فرم می باشد می گیرد و یک form child ساخته میشود که داخلش یک timer می باشد که هر یک ثانیه یا هر زمانی که تنظیم کرده باشیم از طریق کامپوننت ایندی ICMP آی پی فرم مربوطه را پینگ می کند)،
برنامه بسیار خوبی برای مدیران شبکه ها می شود.
source کامل اش را گزاشته ام.
http://s1.picofile.com/file/74361611..._ICMP.rar.html

سلام علیکم
درورد بر برنامه نویسای دلفی
جستجوش و شکستن خط و ذخیره و نمایش نام فایل در نوار عنوان یه کم ایراد داشت یه کم درستش کردم!
این یه برنامه کوچیک همراه با سورشه که متن رو رنگی نشون میده.
تو محیط اصلی برنامه از لیست باکس استفاده کردم که با DrawItem متن و اشکال داخلش رو ترسیم می کنم و در محیط تایپ او یه ادیت با امکانات ساده داریم.استفاده اصلیش برای من تولید راهنمای رنگی برای برنامه است.

قابلیتهایی هم داره:
امکان ارسال تصویر متن به ClipBoard
تنظیم فاصله سطرها
تعیین رنگ پس زمینه
چهار نوع بولت
شش رنگ همزمان برای متن فارسی
جستجوی متن رو به پایین و رو به بالا با کلیدهای F5-F6-F7
(البته تو محیط اصلی کلمه رو مشخص نمی کنه!)
تصحیح "ی" و "ي"!
یه نکته :
اصطلاح صفحه در لیست کلیدهای محیط اصلی رو برای محدوده ای از متن که به سطر خالی برسه به کار بردم (برای درک مساله فایل ترجمه سوره حمد و بقره در کنار برنامه رو ببینین)

امیدوارم خوشتون بیاد و اگه حوصله کردین تکمیلش کنین.

برنامه ماشین حساب


http://uploadkon.ir/?file=56531793b1...6ad175ffee.rar

ساخت Generate SQL Script با دلفي براي اسكيوال سرور 2000 با اين تفاوت كه انتقال اطلاعات هم داشته باشه

دانلود فايل ساخت Generate SQL Script

سلام
نیاز به یه برنامه برای تغییر نام فایلهای شاخه به دسته ای داشتم یه برنامه ساده نوشتم.تستش کردم ان شاء الله درست کار میکنه!!(مثل وقتی توی Total Commander ترکیب Ctrl+M رو فشار میدیم!)
یه برنامه ساده هم میخواستم که با فشاز ترکیب خاصی از کلیدها تصویر پنجره زیر ماوس یا قسمتی قابل انتخاب از دسکتاپ رو بگیره بفرسته به کلیپ برد یا ذخیره کنه!(برای گرفتن تصویر بازی از شبیه ساز بازی موبایل!)
چند تا تابع هم نیاز داشتم که قسمتی از رشته رو بگیرم.(مثلا گرفتن آدرس تصویر از لینک تصویر Google!)
گفتم شاید به درد کسی خورد براتون میذارم:
توابع رشته ای:

Uses

  StrUtils;

Function CopyBetween(S,St,En:String):String;

begin

  Result:=Copy(S,pos(St,S)+Length(St),pos(En,S)-pos(St,S)-Length(St));

end;

Function CopyAfter(S,St:String):String;

begin

  Result:=Copy(S,pos(St,S)+Length(St),Length(S));

end;

Function CopyAfterLastTo(S,St,En:String):String;

Var

  N:Word;

begin

  N:=Pos(ReverseString(St),ReverseString(S));

  Result:=RightStr(S,n-1);

  If En<>'' then

    Result:=LeftStr(Result,pos(En,Result)-1);

end;

Function LastPos(S,S2:String):Integer;

begin

  Result:=Length(S)-

  Pos(ReverseString(S2),ReverseString(S))+1;

end;

این هم دو برنامه ذکر شده:

سلام دوستان!
یه برنامه کوچیک دارم برای بزرگ کردن و رنگی کردن نقطه های ریز متن.
کامل و دقیق نیست اما بدک نیست!؟
یه کم روش کار کردم زوائد نقطه ها رو برداشتم . حالا دیگه اعراب رو نقطه حساب نمی کنه و میشه محدوده برای رنگ کردن نقطه تعیین کرد!
یه سوتی داده بودم: رنگها در بیت مپ به ترتیی BGR هستش و به دلیل بی توجهی به این مساله نقطه ها در جای مناسب ترسیم نمی شدند که حالا اصلاح شد!
پروسیجر برای یکپارچه کردن نقاط واجد رنگ مشابه با رنگ داده شه هم بهش اضافه کردم.
فرض کنید چند نقطه با RGB نزدیک به AA00FF$ داریم میخوایم همه این نقاط دقیقا RGB معادل AA00FF$ داشته باشند.شباهت کوچکی هم به MagicWand داره. (بیشتر وقتی بیت مپی که متنی توش هست به صورت HalfTone کوچک بشه کمک می کنه!)

سلام
ترسیمات پیشفرض دایره و خط و .. دارای لبه سخت هستند.
با کد زیر می تونین ترسیمات دایره و خط و غیره رو با خطوط خارجی که رنگش کم کم کمرنگ و با رنگ نقاط اطراف ترکیب میشه، انجام بدید. به این شکل که سایه ای از رنگ خطوط محیطی بین شکستگیهای Pixel ها ایجاد میشه.
تصویر بزرگ شده زیر رو که با این پروسیجر ترسیم شده ملاحظه بفرمایید:
ضمیمه 94218
نحوه استفاده:
قبل از هر کار یک بیت مپ برای نگه داشتن تصویر پشت شکل تعریف می کنیم( بیشتر به خاطر استفاده در برنامه طراحی با ماوس به درد می خوره)
پارامترها:
0)بیت مپ برای ذخیره ناحیه پشت شکل!(برای طراحی برنامه هایی مثل Paint خوبه)
1)کانواس مربوطه
2)آرایه عددی شامل 4 یا 6 عدد مختصات و شعاع گوشه مستطیل گوشه دار که به عنوان پارامتر در دستورات ترسیم به کار می رود
3)رشته معرف نوع شکل:
L: خط R: مستطیل RR: مستطیل لبه گرد E:بیضی
4)رشته معرف نحوه ترسیم:
B: تنها خط محیطی F: تنها رنگ داخلی BF: ترکیب خط محیطی و رنگ داخلی
5)رنگ خط محیطی
6)رنگ داخل
7)ضخامت خط
در برنامه نمونه میتونید با درگ ماوس روی تصویر مستطیل با گوشه گرد بکشید.

امروز داشتم یه خونه تکونی روی سورس های قدیمی شرکت میدادم و تصمیم گرفتم تمام Dynamic Query ها و ... رو به Stored Procedure تبدیل کنم ، تعداد این موارد خیلی بود بنابراین نوشتن متدهای تکراری برام خسته کننده بود ، 3 تا متد در یک کلاس پایه تعریف کردم که تو کل کلاس های برنامه ازشون استفاده کنم کد مربوط به این سه تابع رو اینجا قرار میدم ، به وسیله این توابع خیلی راحت میتونید Stored Procedure ها رو بدون انجام عملیات تکراری و خسته کننده مقداردهی و اجرا کنید :

تابع اول StoredProcedureExists ، بررسی میکنه Stored Procedure ی که نامش داده شده در بانک جاری که بهش متصل شدید موجود هست یا نه :

function StoredProcedureExists(const SPName: string): Boolean;

var

  SPList: TStringList;

begin

  // Get list of stord procedure in current database & check given sp exists in it or not

  SPList := TStringList.Create;

  try

    ADOConnection.GetProcedureNames(SPList);

    Result := (SPList.IndexOf(SPName + ';1') > 0) or

      (SPList.IndexOf(SPName + ';0') > 0);

  finally

    SPList.Free;

  end;

end;

تابع دوم FetchStoredProcParams ، لیست پارامترهای Stored Procedure ی که نامش به عنوان پارامتر داده شده رو به صورت Comma Delimited در یک رشته برمیگردونه :

function FetchStoredProcParams(const SPName: string): string;

var

  ParamCount: Integer;

  StoredProcedureParams: TStringList;

begin

  // Return given stored procedure parameters

  if StoredProcedureExists(SPName) then

  begin

    StoredProcedureParams := TStringList.Create;

    try

      with ADOStoredProc do

      begin

        Close;

        ProcedureName := SPName;

        Parameters.Refresh;

        for ParamCount := 0 to Parameters.Count - 1 do

          if (Parameters[ParamCount].Direction = pdInput) then

          StoredProcedureParams.Add(Parameters[ParamCount].Name);

        Result := StoredProcedureParams.CommaText;

      end;

    finally

      StoredProcedureParams.Free;

    end;

  end;

end;

* در ضمن در تابع بالا از پارامتری هایی که به صورت Output تعریف شدن چشم پوشی شده چون اصولا بهشون نیازی نیست ، اگر بهشون نیاز داشتید خودتون تغییرش بدید .

و تابع آخر ExecuteStoredProc ، که نام یک Stored Procedure رو به همراه نام پارامترها و مقدار اون ها میگیره و اون رو اجرا میکنه :

function ExecuteStoredProc(const SPName, ParamNames: string;

  ParamValues: array of const): Byte;

var

  ParamCount: Integer;

  StoredProcedureParams: TStringList;

begin

  // Parse given parameters name

  StoredProcedureParams := TStringList.Create;

  try

    StoredProcedureParams.CommaText := ParamNames;

    // Check given param names & given param count is equal , if yes check given procedure name exits in database or no

    if (StoredProcedureParams.Count = Length(ParamValues)) and

      (StoredProcedureExists(SPName)) then

    begin

      with ADOStoredProc do

      begin

        Close;

        ProcedureName := SPName;

        Parameters.Refresh;

        for ParamCount := 0 to StoredProcedureParams.Count - 1 do

        begin

          case ParamValues[ParamCount].VType of

            vtInteger:

              Parameters.ParamByName(StoredProcedureParams[ParamCount]).Value :=

                ParamValues[ParamCount].VInteger;

            vtBoolean:

              Parameters.ParamByName(StoredProcedureParams[ParamCount]).Value :=

                ParamValues[ParamCount].VBoolean;

            vtExtended:

              Parameters.ParamByName(StoredProcedureParams[ParamCount]).Value :=

                Single(ParamValues[ParamCount].VExtended);

            vtUnicodeString:

              Parameters.ParamByName(StoredProcedureParams[ParamCount]).Value :=

                String(ParamValues[ParamCount].VPWideChar);

          else // for other datatypes such as TDate and etc , you can cast it in SQL Server to your own datatype

            Parameters.ParamByName(StoredProcedureParams[ParamCount]).Value :=

              String(ParamValues[ParamCount].VPWideChar);

          end;

        end;

        ExecProc;

        Result := Parameters.ParamValues['@return_value'];

      end;

    end

    else

      raise Exception.Create(Format('The Stored Procedure : %s was not found',

        [SPName]));

  finally

    StoredProcedureParams.Free;

  end;

end;

نمونه استفاده :

ExecuteStoredProc(ProcName, FetchStoredProcParams(ProcName),

      [EmployeeID, FirstName, LastName]);

یا

ExecuteStoredProc(ProcName, 'ID,Fname,LName',

      [EmployeeID, FirstName, LastName]);

موفق باشید .

بنا به درخواست یکی از مشتری ها قرار شد تو برنامه ای که داشتم براش مینوشتم پروسه ای رو پیداه سازی کنم که زمان تغییر کلمه عبور کاربران نرم افزار میزان امنیت کلمه عبور رو بررسی کنه و اگر کلمه عبور ساده ای بود از تغییر رمز جلوگیری کنه ، امروز صبح تابع زیر رو عجله ای برای این کار نوشتم که میتونید بسته به نیازتون میزان سختگیری برای تایید امنیت یک رمز رو با تغییر اعداد کم یا زیاد کنید :

function IsSafePassword(const Password: string): Boolean;

// Count number of numeric characters in password

  function ContainNumber(const Password: string): Boolean;

  var

    CurrChar: Char;

    CharCount: Byte;

  begin

    CharCount := 0;

    for CurrChar in Password do

      if CurrChar in ['0' .. '9'] then

        Inc(CharCount);



    Result := not(CharCount < (Length(Password) div 4));

  end;



// Count number of alphabetic characters in password

  function ContainChar(const Password: string): Boolean;

  var

    CurrChar: Char;

    CharCount: Byte;

  begin

    CharCount := 0;

    for CurrChar in Password do

      if IsCharAlpha(CurrChar) then

        Inc(CharCount);



    Result := not(CharCount < (Length(Password) div 4));

  end;



// Count number of upper characters in password

  function ContainUpperChar(const Password: string): Boolean;

  var

    CurrChar: Char;

    CharCount: Byte;

  begin

    CharCount := 0;

    for CurrChar in Password do

      if IsCharUpper(CurrChar) then

        Inc(CharCount);



    Result := not(CharCount < Length(Password) div 8);

  end;



// Count number of lower characters in password

  function ContainLowerChar(const Password: string): Boolean;

  var

    CurrChar: Char;

    CharCount: Byte;

  begin

    CharCount := 0;

    for CurrChar in Password do

      if IsCharLower(CurrChar) then

        Inc(CharCount);



    Result := not(CharCount < Length(Password) div 8);

  end;



// Count number of symbol characters in password

  function ContainSymbolChar(const Password: string): Boolean;

  var

    CurrChar: Char;

    CharCount: Byte;

  begin

    CharCount := 0;

    for CurrChar in Password do

      if not(IsCharAlpha(CurrChar)) and not(CharInSet(CurrChar, ['0' .. '9']))

      then

        Inc(CharCount);



    Result := not(CharCount < 1);

  end;



// Count number of consecutive characters in password

  function ConsecutiveNumbers(const Password: string): Boolean;

  var

    BaseChar, CurrChar: Char;

    BaseCount, NextChars: Byte;

    ConsecutiveCount: Byte;

  begin

    Result := False;

    for BaseCount := 1 to Length(Password) - 1 do

    begin

      ConsecutiveCount := 0;

      BaseChar := Password[BaseCount];

      for NextChars := BaseCount to Length(Password) do

        if (BaseChar = Password[NextChars]) then

          Inc(ConsecutiveCount);

      if (ConsecutiveCount > Length(Password) div 5) then

        Exit(True);

    end;

  end;

begin

if (Length(Password) < 8) or ContainNumber(Password) = False or

  ContainChar(Password) = False or ContainUpperChar(Password) = False or

  ContainLowerChar(Password) = False or ContainSymbolChar(Password) = False or

  ConsecutiveNumbers(Password) = False then

  Result := False

else

  Result := True;

end;

موفق باشید .

بدست اوردو ورزن و نام ویندوز تا ویندوز 8

function WindowsVersion: String;

begin

 Result := 'Unknown';

 if Win32Platform = VER_PLATFORM_WIN32_NT then

 case Win32MajorVersion of

  4: Result := 'Windows NT';

  5: case Win32MinorVersion of

      0: Result := 'Windows 2000';

      1: Result := 'Windows XP';

      2: Result := 'Windows 2003 Server';

     end;

  6: case Win32MinorVersion of

      0: Result := 'Windows Vista';

      1: Result := 'Windows 7';

      2: Result := 'Windows 8';

     end;

 end else

 case Win32MinorVersion of

  00: Result := 'Windows 95';

  10: if Trim(Win32CSDVersion) = 'A' then Result := 'Windows 98 SE'

      else Result := 'Windows 98';

  90: Result := 'Windows ME';

 end;

 if Win32BuildNumber >0 then

 result:=result+' '+inttostr(Win32BuildNumber)+ ' ' +Win32CSDVersion;

end;

استفاده

ShowMessage(WindowsVersion);

گذاشتن برنامه در System Tray (کنار ساعت ویندوز) و باز کردن برنامه با دبل کلیک روی آیکن.

با مینیمایز کردن یا بستن برنامه ، برنامه کنار ساعت ویندوز قرار میگیره. و با کلیک راست روی آیکن و زدن گزینه exit نرم افزار بسته میشه.

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