صفحه 2 از 6 اولاول 1234 ... آخرآخر
نمایش نتایج 41 تا 80 از 214

نام تاپیک: سورسهاي نمونه آموزشي

  1. #41

    نمونه پروژه کار با فایل در دلفی

    دانلود کنید
    fileisempty,addisdone.rar

  2. #42

    نقل قول: سورسهاي نمونه آموزشي

    یک یونیت برای کار با FaceBook مثل login و ....
    فایل های ضمیمه فایل های ضمیمه

  3. #43
    کاربر دائمی آواتار مصطفی ساتکی
    تاریخ عضویت
    اردیبهشت 1386
    محل زندگی
    www.7khatcode.com
    پست
    1,193

    درخت فیثاغورث

    این سورس کامل درخت فیثاغورث که برای یکی از کاربران تازه وارد قرار داده بودم مثل اینکه ایشون زرنگ تشریف داشتن پس از برداشتن سورس تاپیک رو پاک کردن. توضیحات بیشتر در این تاپیک قرار دارد.http://www.barnamenevis.org/sh...=106906&page=2

    unit Unit1;

    interface

    uses
    Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
    Dialogs, StdCtrls, ComCtrls;

    type
    TPoints = Array of TPoint;
    Tline = record
    p1,p2 : TPoint;
    end;
    TForm1 = class(TForm)
    Button2: TButton;
    procedure Button2Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
    Shift: TShiftState; X, Y: Integer);
    private
    { Private declarations }
    public
    p1,p2 : TPoint;
    function NormDegre(Degre : integer):integer;
    procedure DrawPoint(Pnts : TPoints);
    procedure FillTringle(Pnts : TPoints);
    function LineLen(p1,p2 : TPoint) : Integer;
    function GetDegre(P1,p2 : TPoint):integer;
    function InterSection(P1, p2: TPoint; Deg1, Deg2: Real): TPoint;
    procedure DrawTree(p1,p2 : TPoint;counter : integer);
    function Square1(p1,p2 : TPoint):TPoints;
    function Tringle1(p1,p2 : TPoint):TPoints;
    end;

    var
    Form1: TForm1;

    implementation

    uses Math, Types;

    {$R *.dfm}


    procedure TForm1.Button2Click(Sender: TObject);
    var p1,p2 : TPoint;

    begin
    p1 := Point(400,400);
    p2 := Point(450,400);
    DrawTree(p1,p2,1);
    end;

    function TForm1.InterSection(P1, p2: TPoint; Deg1, Deg2: Real): TPoint;
    begin
    Deg1 := Tan( DegToRad(Deg1));
    Deg2 := Tan(DegToRad(Deg2));

    Result.X := round( ((P1.Y - P2.Y)+(Deg2*p2.X- Deg1*P1.X))/(-Deg1+Deg2)) ;
    Result.Y :=round( Deg2*(Result.X - P2.X)+P2.Y);
    {
    Result.X := round((-p1.Y+p2.Y+p1.X*Deg1-p2.X*Deg2)/(Deg1-Deg2));
    Result.Y :=round( Deg1*(Result.X - P1.X)+P1.Y);
    }
    end;

    function TForm1.GetDegre(P1, p2: TPoint): Integer;
    begin
    Result := round( RadToDeg( ArcTan2(p2.Y-p1.Y,p2.X-p1.X)));
    if Result <0 then Result := 360 + Result;
    end;

    function TForm1.LineLen(p1, p2: TPoint):Integer ;
    begin
    if p2.X = p1.X then Result := abs(p2.Y-p1.Y)
    else if p2.Y = p1.Y then Result := abs(p2.x-p1.x)
    else Result := trunc( sqrt( sqr(p2.Y-p1.Y)+sqr(p2.X-p1.X)));
    end;




    procedure TForm1.DrawPoint(Pnts: TPoints);
    var i , j : integer;
    colors:array[0..2] of byte;
    begin
    Canvas.Pen.Color := clBlack;
    Canvas.MoveTo(Pnts[0].x,Pnts[0].y);
    for i := 1 to Length(Pnts)-1 do
    Canvas.LineTo(Pnts[i].X,Pnts[i].Y);

    Canvas.LineTo(Pnts[0].X,Pnts[0].Y);

    if Length(Pnts)=3 then
    begin
    end;

    end;

    procedure TForm1.DrawTree(p1,p2 : TPoint;counter : integer);
    var SqrPnts ,TringPnts : TPoints;
    begin
    if counter> 16 then Exit;
    counter := counter+1;
    SqrPnts := Square1(p1,p2);
    DrawPoint(SqrPnts);
    TringPnts := Tringle1(SqrPnts[3],SqrPnts[2]);
    DrawPoint(TringPnts);
    FillTringle(TringPnts);
    DrawTree(TringPnts[2],TringPnts[1],counter+1);
    DrawTree(TringPnts[0],TringPnts[2],counter+1);

    end;

    procedure TForm1.FormCreate(Sender: TObject);
    begin
    Randomize;
    p1 := Point(-1,-1);
    p2 := Point(-1,-1);
    end;

    function TForm1.NormDegre(Degre: Integer): integer;
    begin
    Result := Degre;
    if Degre< 0 then Result := 360 + Degre
    else if Degre> 360 then Result := Degre mod 360;

    end;

    function TForm1.Square1(p1, p2: TPoint):TPoints;
    var G1,G2 : integer;
    r : integer;
    p3,p4 : TPoint;
    begin
    G1 := GetDegre(p1,p2);
    G2 := GetDegre(p2,p1);

    r := LineLen(p1,p2);
    SetLength(Result,4);

    Result[0] := p1;
    Result[1] := p2;

    Result[2].X := p2.X+ round( r*cos(DegToRad(NormDegre( g2+90 ))));
    Result[2].Y := p2.Y+ round(r*sin(DegToRad(NormDegre( g2+90))));

    Result[3].X :=p1.X+ round( r*cos(DegToRad(NormDegre( g1-90) )));
    Result[3].Y := p1.Y+ round(r*sin(DegToRad(NormDegre( g1-90) )));


    end;

    function TForm1.Tringle1(p1, p2: TPoint): TPoints;
    var g : Integer;
    r , l ,r2 : Real;
    begin
    SetLength(Result,3);
    Result[0] := p1;
    Result[1] := p2;
    g := GetDegre(p1,p2);
    r := LineLen(p1,p2);
    r2 := r /2;

    l := r2/ sin(DegToRad(45)) ;

    Result[2].X := round(p1.X +l*cos(DegToRad(NormDegre( g-45 ))));
    Result[2].Y := round(p1.Y +l*sin(DegToRad(NormDegre( g-45 ))));

    end;

    procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
    Shift: TShiftState; X, Y: Integer);
    begin
    if p1.X=-1 then p1 := Point(x,y)
    else if p2.X=-1 then p2 := Point(x,y);

    if (p1.X<>-1) and (p2.X<>-1) then
    begin
    Refresh;
    DrawTree(p1,p2,1);
    p1 := Point(-1,-1);
    p2 := Point(-1,-1);
    end;
    end;

    procedure TForm1.FillTringle(Pnts: TPoints);
    var
    g ,r : integer;
    p ,q: TPoint;
    tempB : TBrush;
    begin
    g := GetDegre(Pnts[0],Pnts[1]);
    r := LineLen(Pnts[0],Pnts[1]) div 2;
    p.X := Pnts[0].X+ round( r*cos(DegToRad(NormDegre( g ))));
    p.Y := Pnts[0].Y+ round(r*sin(DegToRad(NormDegre( g))));

    g := GetDegre(P,Pnts[2]);
    r := LineLen(P,Pnts[2]) div 2;
    q.X := P.X+ round( r*cos(DegToRad(NormDegre( g ))));
    q.Y := P.Y+ round(r*sin(DegToRad(NormDegre( g))));

    // tempB := Canvas.Brush;
    // Canvas.Brush.Style := bsSolid;
    Canvas.Brush.Color := clBlack;

    Canvas.FloodFill(q.X,q.Y,clBlack,fsBorder);
    // Canvas.Brush := tempB;

    end;

    end.

  4. #44

    کپی رکورد ها از یک جدول پایگاه داده و درج در جدول دوم

    این برنامه فیلد های جدول اول رو میخونه و در جدول دوم درج میکنه فقط باید دو جدول بسازید به اسم person1 و person2 و در جدول اول فیلد های id,fname,lname و در جدول دوم فیلد های fname و lname را قرار بدید و بعد پروژه رو اجرا کنید:


    table1totable2.rar

  5. #45

    حذف فایل ها به صورت غیر قابل بازگشت

    سلام
    با استفاده از این برنامه ای که ساخته ام شما می توانید فایل های مورد نظر خود را به صورتی از رایانه حذف کنید که دیگر با هیچ نرم افزار بازیابی اطلاعاتی قابل بازگشت نباشد. یادش بخیر این یکی از هفت برنامه ای بود که برای پروژه نهایی کاردانی نوشته بودم.
    روش کار با این برنامه بسیار ساده است. فقط باید فایلهای مورد نظر را به روی ListView درگ کرده و برای حذف آن ها چک باکس موجود در کنار فایل های مورد نظر را به صورت انتخاب شده در آورید و سپس بر روی دکمه Erase کلیک کنید. در اصطلاح کلی به این گونه برنامه ها File Shredder گفته می شود. در ضمن توجه کنید که برای ساخت این برنامه از دلفی 2010 استفاده کرده ام. بنابرین برای کامپایل و اجرای برنامه به دلفی 2010 نیاز دارید.
    عکس های ضمیمه عکس های ضمیمه
    • نوع فایل: png g.png‏ (46.8 کیلوبایت, 1266 دیدار)
    فایل های ضمیمه فایل های ضمیمه

  6. #46

    نقل قول: حذف فایل ها به صورت غیر قابل بازگشت

    نقل قول نوشته شده توسط شاهین عشایری مشاهده تاپیک
    سلام
    با استفاده از این برنامه ای که ساخته ام شما می توانید فایل های مورد نظر خود را به صورتی از رایانه حذف کنید که دیگر با هیچ نرم افزار بازیابی اطلاعاتی قابل بازگشت نباشد. یادش بخیر این یکی از هفت برنامه ای بود که برای پروژه نهایی کاردانی نوشته بودم.
    روش کار با این برنامه بسیار ساده است. فقط باید فایلهای مورد نظر را به روی ListView درگ کرده و برای حذف آن ها چک باکس موجود در کنار فایل های مورد نظر را به صورت انتخاب شده در آورید و سپس بر روی دکمه Erase کلیک کنید. در اصطلاح کلی به این گونه برنامه ها File Shredder گفته می شود. در ضمن توجه کنید که برای ساخت این برنامه از دلفی 2010 استفاده کرده ام. بنابرین برای کامپایل و اجرای برنامه به دلفی 2010 نیاز دارید.
    اعلان تابع IsTextFile با تعریفی که تو برنامه کردید متفاوت هست ، اعلان رو به صورت زیر تغییر بدید :
    function IsTextFile(const sFileName: string): Boolean;

  7. #47

    نقل قول: سورسهاي نمونه آموزشي

    امروز یکی از کاربران تاپیکی زده بود و درخواست کدی کرده بود که بتونه یک فایل رو تو آدرس مورد نظر کپی و روند پیشرفت عملیات رو داخل یک ProgressBar نمایش بده ، بدین منظور کتابخانه ای با نام PBCopy نوشتم که یک فایل رو به آدرس مورد نظر کپی میکنه و روند پیشرفت عملیات کپی رو داخل یک ProgressBar نمایش میده که کتابخانه و نمونه برنامه رو میتونید از فایل ضمیمه دریافت کنید .
    عکس های ضمیمه عکس های ضمیمه
    فایل های ضمیمه فایل های ضمیمه
    آخرین ویرایش به وسیله Felony : سه شنبه 07 دی 1389 در 09:00 صبح دلیل: اضافه کردن نمایش % روند عملیات

  8. #48

    Wink به دست آوردن نام نسخه سیستم عامل ویندوز(مثلاً Microsoft Windows 7 Ultimate 6.1.7600)

    با استفاده از کد زیر شما می توانید نام نسخه سیستم عامل ویندوز را بدست آورید: (این کد در Delphi XE تست شده است)
    uses ActiveX, OleAuto;

    function GetWin32_OSNameVersion: string;
    var
    objWMIService: OLEVariant;
    colItems: OLEVariant;
    colItem: OLEVariant;
    oEnum: IEnumvariant;
    iValue: LongWord;

    function GetWMIObject(const objectName: String): IDispatch;
    var
    chEaten: Integer;
    BindCtx: IBindCtx;
    Moniker: IMoniker;
    begin
    OleCheck(CreateBindCtx(0, BindCtx));
    OleCheck(MkParseDisplayName(BindCtx, StringToOleStr(objectName), chEaten,
    Moniker));
    OleCheck(Moniker.BindToObject(BindCtx, nil, IDispatch, Result));
    end;

    begin
    try
    objWMIService := GetWMIObject('winmgmts:\\localhost\root\cimv2');
    colItems := objWMIService.ExecQuery('SELECT * FROM Win32_OperatingSystem',
    'WQL', 0);
    oEnum := IUnknown(colItems._NewEnum) as IEnumvariant;
    if oEnum.Next(1, colItem, iValue) = 0 then
    Result := Format('%s %s', [colItem.Caption, colItem.Version]);
    except
    Result := '?'
    end;
    end;

    procedure TForm1.Button1Click(Sender: TObject);
    begin
    ShowMessage(GetWin32_OSNameVersion);
    end;

  9. #49

    Wink نقل قول: Overload کردن تابع ShowMessage برای پذیرفتن مقادیر اعشاری، صحیح و بولی

    Overload کردن تابع ShowMessage برای پذیرفتن مقادیر اعشاری، صحیح و بولی:
    unit common;

    interface

    uses dialogs, sysutils;

    procedure ShowMessage(const value : string) ; overload;
    procedure ShowMessage(const value : integer) ; overload;
    procedure ShowMessage(const value : extended) ; overload;
    procedure ShowMessage(const value : boolean) ; overload;

    implementation

    //displays a string in a dialog box
    procedure ShowMessage(const value : string) ;
    begin
    Dialogs.ShowMessage(value) ;
    end;

    //displays an integer in a dialog box
    procedure ShowMessage(const value : integer) ;
    begin
    ShowMessage(IntToStr(value)) ;
    end;

    //displays a float in a dialog box
    procedure ShowMessage(const value : extended) ;
    begin
    ShowMessage(FloatToStr(value)) ;
    end;

    //displays a boolean in a dialog box
    procedure ShowMessage(const value : boolean) ;
    begin
    ShowMessage(BoolToStr(value, true)) ;
    end;

    end.

  10. #50

    نقل قول: سورسهاي نمونه آموزشي

    چند روز پیش یکی از دوستان از فضای کم میز کارش و اینکه مانیتورش کوچیک هست گله میکرد و به ذهنم رسید تا برنامه ای بنویسم تا چند تا میز کار مختلف در اختیار کابر بزاره تا بتونه تو هر کدومش کار متفاوتی انجام بده و ...

    برنامه رو تا جایی که بشه ازش استفاده کرد نوشتم ولی بازم روش میشه کار کرد ، میتونید ازش برای یادگیری نحوه استفاده از تابع SetThreadDesktop , CretaeDesktop ، SwitchToDesktop , CreateProcess استفاده کنید ، چون منبع جامعی برای استفاده از این توابع Desktop در دلفی پیدا نمیشه ، من هم با خوندن MSDN برنامه رو نوشتم .

    برنامه بهتون علاوه بر میزکار پیش فرض ، 2 میز کار اضافی هم میده و میتونید از هر میز کاری که هستید یک برنامه رو تو میزکار دیگه اجرا کنید یا بهش سوئیچ کنید .

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

  11. #51

    نقل قول: سورسهاي نمونه آموزشي

    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;

  12. #52

    به دست آوردن نام ، کلاس و هندل کنترل های برنامه دیگر

    سلام ،

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

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

  13. #53

    Arrow هوش مصنوعی ساده به زبان دلفی

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


  14. #54

    نقل قول: سورسهاي نمونه آموزشي

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

    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;

  15. #55

    نقل قول: سورسهاي نمونه آموزشي

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


    وَ سَيَعْلَمُ الَّذِينَ ظَلَمُوا [آل محمد حقهم] أَيَّ مُنْقَلَبٍ يَنْقَلِبُونَ - الشعراء (227)
    و ظالمین [حق آل محمد (ص) ] به زودی خواهند دانست که به کدام بازگشتگاه بازخواهند گشت.

  16. #56
    کاربر دائمی آواتار mbshareat
    تاریخ عضویت
    آبان 1387
    محل زندگی
    شهر مقدس قم-چهارمردان-کوچه 37
    پست
    962

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

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

  17. #57
    کاربر دائمی
    تاریخ عضویت
    فروردین 1388
    محل زندگی
    ایران سرای من است
    پست
    2,655

  18. #58

    نقل قول: سورسهاي نمونه آموزشي

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

  19. #59
    کاربر دائمی آواتار مصطفی ساتکی
    تاریخ عضویت
    اردیبهشت 1386
    محل زندگی
    www.7khatcode.com
    پست
    1,193

    نقل قول: سورسهاي نمونه آموزشي

    کدی جهت بدست آوردن تقاطع 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.

  20. #60
    کاربر دائمی
    تاریخ عضویت
    فروردین 1388
    محل زندگی
    ایران سرای من است
    پست
    2,655

    نقل قول: سورسهاي نمونه آموزشي


  21. #61

    نقل قول: سورسهاي نمونه آموزشي

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

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

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

  22. #62

    نقل قول: سورسهاي نمونه آموزشي

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

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

    موفق باشید .
    فایل های ضمیمه فایل های ضمیمه

  23. #63

    نقل قول: سورسهاي نمونه آموزشي

    امروز تو یکی از برنامه ها که داشتم مینوشتم نیاز به تولید اعداد تصادفی ( 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;
    آخرین ویرایش به وسیله Felony : یک شنبه 06 شهریور 1390 در 06:23 صبح

  24. #64

    نقل قول: سورسهاي نمونه آموزشي

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

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

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


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

  25. #65
    کاربر دائمی آواتار zidane
    تاریخ عضویت
    آذر 1385
    محل زندگی
    مشهد - خيابان دلفي - پلاک XE5
    سن
    38
    پست
    141

    Lightbulb SQL Server Database Manager

    با سلام
    چند وقتی بود که دنبال یک برنامه کوچیک و جمع و جور می گشتم که باهاش بتونم رو سیستمی که SQL Server Express یا MSDE نصب شده، لیست دیتابیس ها رو ببینم و بتونم باهاش Attach و Detach دیتابیس هم انجام بدم.
    چون برنامه جالبی پیدا نکردم خودم دست به کار شدم و این برنامه رو نوشتم.
    امیدوارم به درد شما هم بخوره:
    عکس های ضمیمه عکس های ضمیمه
    فایل های ضمیمه فایل های ضمیمه
    آخرین ویرایش به وسیله zidane : پنج شنبه 12 آبان 1390 در 11:46 صبح دلیل: سازگاری با SQL Server 2000

  26. #66

    تغییر فونت مربوط به کنترل TMainMenu

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

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

  27. #67

    نقل قول: سورسهاي نمونه آموزشي

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

    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;

  28. #68
    کاربر دائمی آواتار SayeyeZohor
    تاریخ عضویت
    اسفند 1387
    محل زندگی
    ا-ص-ف-ه-ا-ن
    پست
    631

    نقل قول: سورسهاي نمونه آموزشي

    نقل قول نوشته شده توسط مجتبی تاجیک مشاهده تاپیک
    امروز تو یکی از برنامه ها که داشتم مینوشتم نیاز به تولید اعداد تصادفی ( 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 بشه
    ممنون

  29. #69
    کاربر دائمی آواتار mbshareat
    تاریخ عضویت
    آبان 1387
    محل زندگی
    شهر مقدس قم-چهارمردان-کوچه 37
    پست
    962

    دکمه با بیت مپ برای وضعیتهای ماوس بدون لبه!

    سلام به همگی
    من یه دکمه ساده طراحی کردم.چند تا حالت از جمله دکمه بدون لبه داره.
    برای حالتهای MouseUp ,Mouse Down ,MouseOver می تونین رنگ دکمه رو تعیین کنین.
    اگه دوست داشتین بردارین:
    untitled.jpgImageButton.rar
    آخرین ویرایش به وسیله mbshareat : چهارشنبه 30 فروردین 1391 در 01:17 صبح دلیل: تکمیل

  30. #70
    کاربر دائمی آواتار mbshareat
    تاریخ عضویت
    آبان 1387
    محل زندگی
    شهر مقدس قم-چهارمردان-کوچه 37
    پست
    962

    Smile نقل قول: سورسهاي نمونه آموزشي

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

  31. #71
    کاربر دائمی آواتار mbshareat
    تاریخ عضویت
    آبان 1387
    محل زندگی
    شهر مقدس قم-چهارمردان-کوچه 37
    پست
    962

    نقل قول: سورسهاي نمونه آموزشي

    سلام
    یونیت پنجره پیغام و سوال و InputBox رنگی(جالبه بدونین که حرف ی- ي رو هم درست می کنه):
    MSGs.rar
    Untitled-1.jpg
    البته پروسیجرهای آقای شاهین عشایری رو هم تو یونیت ریختم. می تونین از راه InstallComponent یونیت رو نصب کنین و هر دفعه فقط MSGs رو به لیست Uses اضافه کنین.
    یک کم توسعش دادم .اینها رو هم اضافه کردم:
    2.jpg
    آخرین ویرایش به وسیله mbshareat : چهارشنبه 30 فروردین 1391 در 01:44 صبح

  32. #72

    نقل قول: سورسهاي نمونه آموزشي

    برای کپی من با خطای 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;
    عکس های ضمیمه عکس های ضمیمه
    • نوع فایل: jpg e11.jpg‏ (34.3 کیلوبایت, 865 دیدار)

  33. #73
    کاربر دائمی آواتار mbshareat
    تاریخ عضویت
    آبان 1387
    محل زندگی
    شهر مقدس قم-چهارمردان-کوچه 37
    پست
    962

    نقل قول: سورسهاي نمونه آموزشي

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

    SendMessage2.rar
    من محتوای یونیت 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;
    آخرین ویرایش به وسیله mbshareat : چهارشنبه 06 اردیبهشت 1391 در 09:40 صبح

  34. #74
    کاربر تازه وارد
    تاریخ عضویت
    اسفند 1390
    محل زندگی
    تهران
    پست
    31

    نقل قول: سورسهاي نمونه آموزشي

    سلام دوستان!



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



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



    دانلود کنید.

  35. #75
    کاربر دائمی آواتار Ananas
    تاریخ عضویت
    آبان 1390
    محل زندگی
    طول 50 و عرض 34 درجه
    سن
    36
    پست
    894

    نقل قول: سورسهاي نمونه آموزشي

    سلام.
    کنترل 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.


  36. #76

    نقل قول: MySQL Backup Maker

    نقل قول نوشته شده توسط مهران رسا مشاهده تاپیک
    در طول انجام یه پروژه نیاز شد تا از بانک 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) را از کجا بياورم؟؟

  37. #77

    نقل قول: سورسهاي نمونه آموزشي

    من نمي توانم پروژه را اجرا کنم راجع به اين سه فايل پيغام ميدهد؟
    WideStrings, DBXMySql
    این فایل ها به همراه دلفی وجود دارند. احتمالاً بنا به دلایلی فایل dcu مربوط به آنها از سیستم شما حذف شده است. اگر این مشکل رو با یونیت های دیگر هم دارید به نظر من بهتره که دلفی رو دوباره نصب کنید.
    ضمنا درایور های مربوطه (dbxmys.dll و libmySQL.dll) را از کجا بياورم؟؟
    فایلهایی که اول نامشون dbx هست با نصب دلفی به سیستم کپی می شوند و فایل دیگر هم با نصب آن DBMS خاص (در اینجا MySQL) به سیستم کپی می شوند.

  38. #78
    کاربر دائمی آواتار Ananas
    تاریخ عضویت
    آبان 1390
    محل زندگی
    طول 50 و عرض 34 درجه
    سن
    36
    پست
    894

    نقل قول: سورسهاي نمونه آموزشي

    _

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

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

  39. #79
    کاربر دائمی آواتار SayeyeZohor
    تاریخ عضویت
    اسفند 1387
    محل زندگی
    ا-ص-ف-ه-ا-ن
    پست
    631

    نقل قول: سورسهاي نمونه آموزشي

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

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

  40. #80
    کاربر دائمی آواتار SayeyeZohor
    تاریخ عضویت
    اسفند 1387
    محل زندگی
    ا-ص-ف-ه-ا-ن
    پست
    631

    نقل قول: سورسهاي نمونه آموزشي

    ساعت باينري



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

صفحه 2 از 6 اولاول 1234 ... آخرآخر

برچسب های این تاپیک

قوانین ایجاد تاپیک در تالار

  • شما نمی توانید تاپیک جدید ایجاد کنید
  • شما نمی توانید به تاپیک ها پاسخ دهید
  • شما نمی توانید ضمیمه ارسال کنید
  • شما نمی توانید پاسخ هایتان را ویرایش کنید
  •