صفحه 11 از 11 اولاول ... 91011
نمایش نتایج 401 تا 431 از 431

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

  1. #401
    کاربر دائمی آواتار gholami146
    تاریخ عضویت
    آبان 1388
    محل زندگی
    مشهد مقدس
    پست
    374

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

    ايجاد Database در يك بانك اطلاعاتي sql sever 2000 در حالت local

    procedure CreateDatabase(WindowsSecurity: Boolean; Username, Password: String);
    var
    ConnectionString: String;
    CommandText: String;
    begin
    if WindowsSecurity then
    ConnectionString := 'Provider=SQLOLEDB.1;' +
    'Integrated Security=SSPI;' +
    'Persist Security Info=False;' +
    'Initial Catalog=master'
    else
    ConnectionString := 'Provider=SQLOLEDB.1;' +
    'Password=' + Password + ';' +
    'Persist Security Info=True;' +
    'User ID=' + Username + ';' +
    'Initial Catalog=master';

    try

    try
    ADOConnection.ConnectionString := ConnectionString;
    ADOConnection.LoginPrompt := False;
    ADOConnection.Connected := True;


    CommandText := 'CREATE DATABASE test ON ' +
    '( NAME = test_dat, ' +
    'FILENAME = ''c:\program files\microsoft sql server\mssql\data\test.mdf'', ' +
    'SIZE = 4, ' +
    'MAXSIZE = 10, ' +
    'FILEGROWTH = 1 )';

    ADOCommand.CommandText := CommandText;
    ADOCommand.Connection := ADOConnection;
    ADOCommand.Execute;
    MessageDlg('Database succesfully created.', mtInformation, [mbOK], 0);

    except
    on E: Exception do MessageDlg(E.Message, mtWarning, [mbOK], 0);
    end;

    finally
    ADOConnection.Connected := False;
    ADOCommand.Connection := nil;
    end;

    end;

  2. #402
    کاربر دائمی آواتار gholami146
    تاریخ عضویت
    آبان 1388
    محل زندگی
    مشهد مقدس
    پست
    374

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

    ايجاد خروجي از TDBGrid به قالب Excel

    unit DBGridExportToExcel;

    interface

    uses
    Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
    ExtCtrls, StdCtrls, ComCtrls, DB, IniFiles, Buttons, dbgrids, ADOX_TLB, ADODB;


    type TScrollEvents = class
    BeforeScroll_Event: TDataSetNotifyEvent;
    AfterScroll_Event: TDataSetNotifyEvent;
    AutoCalcFields_Property: Boolean;
    end;

    procedure DisableDependencies(DataSet: TDataSet; var ScrollEvents: TScrollEvents);
    procedure EnableDependencies(DataSet: TDataSet; ScrollEvents: TScrollEvents);
    procedure DBGridToExcelADO(DBGrid: TDBGrid; FileName: string; SheetName: string);


    implementation

    //Support procedures: I made that in order to increase speed in
    //the process of scanning large amounts
    //of records in a dataset

    //we make a call to the "DisableControls" procedure and then disable the "BeforeScroll" and
    //"AfterScroll" events and the "AutoCalcFields" property.
    procedure DisableDependencies(DataSet: TDataSet; var ScrollEvents: TScrollEvents);
    begin
    with DataSet do
    begin
    DisableControls;
    ScrollEvents := TScrollEvents.Create();
    with ScrollEvents do
    begin
    BeforeScroll_Event := BeforeScroll;
    AfterScroll_Event := AfterScroll;
    AutoCalcFields_Property := AutoCalcFields;
    BeforeScroll := nil;
    AfterScroll := nil;
    AutoCalcFields := False;
    end;
    end;
    end;

    //we make a call to the "EnableControls" procedure and then restore
    // the "BeforeScroll" and "AfterScroll" events and the "AutoCalcFields" property.
    procedure EnableDependencies(DataSet: TDataSet; ScrollEvents: TScrollEvents);
    begin
    with DataSet do
    begin
    EnableControls;
    with ScrollEvents do
    begin
    BeforeScroll := BeforeScroll_Event;
    AfterScroll := AfterScroll_Event;
    AutoCalcFields := AutoCalcFields_Property;
    end;
    end;
    end;

    //This is the procedure which make the work:

    procedure DBGridToExcelADO(DBGrid: TDBGrid; FileName: string; SheetName: string);
    var
    cat: _Catalog;
    tbl: _Table;
    col: _Column;
    i: integer;
    ADOConnection: TADOConnection;
    ADOQuery: TADOQuery;
    ScrollEvents: TScrollEvents;
    SavePlace: TBookmark;
    begin
    //
    //WorkBook creation (database)
    cat := CoCatalog.Create;
    cat._Set_ActiveConnection('Provider=Microsoft.Jet. OLEDB.4.0; Data Source=' + FileName + ';Extended Properties=Excel 8.0');
    //WorkSheet creation (table)
    tbl := CoTable.Create;
    tbl.Set_Name(SheetName);
    //Columns creation (fields)
    DBGrid.DataSource.DataSet.First;
    with DBGrid.Columns do
    begin
    for i := 0 to Count - 1 do
    if Items[i].Visible then
    begin
    col := nil;
    col := CoColumn.Create;
    with col do
    begin
    Set_Name(Items[i].Title.Caption);
    Set_Type_(adVarWChar);
    end;
    //add column to table
    tbl.Columns.Append(col, adVarWChar, 20);
    end;
    end;
    //add table to database
    cat.Tables.Append(tbl);

    col := nil;
    tbl := nil;
    cat := nil;

    //exporting
    ADOConnection := TADOConnection.Create(nil);
    ADOConnection.LoginPrompt := False;
    ADOConnection.ConnectionString := 'Provider=Microsoft.Jet.OLEDB.4.0; Data Source=' + FileName + ';Extended Properties=Excel 8.0';
    ADOQuery := TADOQuery.Create(nil);
    ADOQuery.Connection := ADOConnection;
    ADOQuery.SQL.Text := 'Select * from [' + SheetName + '$]';
    ADOQuery.Open;


    DisableDependencies(DBGrid.DataSource.DataSet, ScrollEvents);
    SavePlace := DBGrid.DataSource.DataSet.GetBookmark;
    try
    with DBGrid.DataSource.DataSet do
    begin
    First;
    while not Eof do
    begin
    ADOQuery.Append;
    with DBGrid.Columns do
    begin
    ADOQuery.Edit;
    for i := 0 to Count - 1 do
    if Items[i].Visible then
    begin
    ADOQuery.FieldByName(Items[i].Title.Caption).AsString := FieldByName(Items[i].FieldName).AsString;
    end;
    ADOQuery.Post;
    end;
    Next;
    end;
    end;

    finally
    DBGrid.DataSource.DataSet.GotoBookmark(SavePlace);
    DBGrid.DataSource.DataSet.FreeBookmark(SavePlace);
    EnableDependencies(DBGrid.DataSource.DataSet, ScrollEvents);

    ADOQuery.Close;
    ADOConnection.Close;

    ADOQuery.Free;
    ADOConnection.Free;

    end;

    end;

    end.

  3. #403
    کاربر دائمی آواتار gholami146
    تاریخ عضویت
    آبان 1388
    محل زندگی
    مشهد مقدس
    پست
    374

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

    ايجاد سايه براي Hint ها

    type
    TXPHintWindow = class(THintWindow)
    protected
    procedure CreateParams(var Params: TCreateParams); override;
    procedure WMNCPaint(var msg: TMessage); message WM_NCPAINT;
    end;

    function IsWinXP: Boolean;
    begin
    Result := (Win32Platform = VER_PLATFORM_WIN32_NT) and
    (Win32MajorVersion >= 5) and (Win32MinorVersion >= 1);
    end;

    procedure TXPHintWindow.CreateParams(var Params: TCreateParams);
    const
    CS_DROPSHADOW = $00020000;
    begin
    inherited;
    if IsWinXP then
    Params.WindowClass.Style := Params.WindowClass.Style or CS_DROPSHADOW;
    end;

    procedure TXPHintWindow.WMNCPaint(var msg: TMessage);
    var
    R: TRect;
    DC: HDC;
    begin
    DC := GetWindowDC(Handle);
    try
    R := Rect(0, 0, Width, Height);
    DrawEdge(DC, R, EDGE_ETCHED, BF_RECT or BF_MONO);
    finally
    ReleaseDC(Handle, DC);
    end;
    end;

    initialization
    HintWindowClass := TXPHintWindow;
    Application.ShowHint := False;
    Application.ShowHint := True;
    end.

  4. #404
    کاربر دائمی آواتار gholami146
    تاریخ عضویت
    آبان 1388
    محل زندگی
    مشهد مقدس
    پست
    374

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

    ايجاد سايه براي پنجره هاي برنامه

    type
    TForm1 = class(TForm)
    protected
    procedure CreateParams(var Params: TCreateParams); override;
    end;

    var
    Form1: TForm1;

    implementation

    {$R *.dfm}

    procedure TForm1.CreateParams(var Params: TCreateParams);
    const
    CS_DROPSHADOW = $00020000;
    begin
    inherited;
    Params.WindowClass.Style := Params.WindowClass.Style or CS_DROPSHADOW;
    end;

  5. #405
    کاربر دائمی آواتار gholami146
    تاریخ عضویت
    آبان 1388
    محل زندگی
    مشهد مقدس
    پست
    374

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

    ايجاد سريع يك جدول پارادوكس به كمك كد

    procedure TForm1.Button1Click(Sender: TObject);
    begin
    with Query1 do
    begin
    DatabaseName := 'DBDemos';
    with SQL do
    begin
    Clear;
    {
    CREATE TABLE creates a table with the given name in the
    current database

    CREATE TABLE erzeugt eine Tabelle mit einem angegebenen
    Namen in der aktuellen Datenbank
    }
    Add('CREATE TABLE "PDoxTbl.db" (ID AUTOINC,');
    Add('Name CHAR(255),');
    Add('PRIMARY KEY(ID))');
    {
    Call ExecSQL to execute the SQL statement currently
    assigned to the SQL property.

    Mit ExecSQL wird die Anweisung ausgeführt,
    welche aktuell in der Eigenschaft SQL enthalten ist.
    }
    ExecSQL;
    Clear;
    Add('CREATE INDEX ByName ON "PDoxTbl.db" (Name)');
    ExecSQL;
    end;
    end;
    end;

  6. #406
    کاربر دائمی آواتار gholami146
    تاریخ عضویت
    آبان 1388
    محل زندگی
    مشهد مقدس
    پست
    374

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

    ايجاد صدا هنگام وارد شدن ماوس روي كنترل

    uses ... , MMSystem;

    TYourObject = class(TAnyControl)
    ...
    private
    procedure CMMouseEnter(var AMsg: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var AMsg: TMessage); message CM_MOUSELEAVE;
    ...
    end;

    implementation

    procedure TYourObject.CMMouseEnter(var AMsg: TMessage);
    begin
    sndPlaySound('c:\win98\media\ding.wav',snd_Async or snd_NoDefault);
    end;

    procedure TYourObject.CMMouseLeave(var AMsg: TMessage);
    begin
    sndPlaySound(nil,snd_Async or snd_NoDefault);
    end;

  7. #407
    کاربر دائمی آواتار gholami146
    تاریخ عضویت
    آبان 1388
    محل زندگی
    مشهد مقدس
    پست
    374

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

    ايجاد ميانبر از يك فايل در ويندوز

    procedure CreateShortcut(SourceFileName, Title: string; Location:
    ShortcutType; SubDirectory : string);
    var
    MyObject : IUnknown;
    MySLink : IShellLink;
    MyPFile : IPersistFile;
    Directory,
    LinkName : string;
    WFileName : WideString;
    MyReg,
    QuickLaunchReg : TRegIniFile;
    begin
    MyObject := CreateComObject(CLSID_ShellLink);
    MySLink := MyObject as IShellLink;
    MyPFile := MyObject as IPersistFile;

    MySLink.SetPath(PChar(SourceFileName));

    MyReg := TRegIniFile.Create('Software\MicroSoft\Windows\Cur rentVersion\Explorer');
    try
    LinkName := ChangeFileExt(SourceFileName, '.lnk');
    LinkName := ExtractFileName(LinkName);
    case Location of
    _DESKTOP : Directory := MyReg.ReadString('Shell Folders', 'Desktop', '');
    _STARTMENU : Directory := MyReg.ReadString('Shell Folders', 'Start Menu', '');
    _SENDTO : Directory := MyReg.ReadString('Shell Folders', 'SendTo', '');
    _QUICKLAUNCH:
    begin
    QuickLaunchReg := TRegIniFile.Create('Software\MicroSoft\Windows\Cur rentVersion\GrpConv');

    try
    Directory := QuickLaunchReg.ReadString('MapGroups', 'Quick Launch', '');
    finally
    QuickLaunchReg.Free;
    end; {try..finally}
    end; {case _QUICKLAUNCH}
    end; {case}
    if Directory <> '' then
    begin
    if SubDirectory <> '' then
    WFileName := Directory + '\'+ SubDirectory +'\' + LinkName
    else
    WFileName := Directory + '\' + LinkName;
    MyPFile.Save(PWChar(WFileName), False);
    end; {Directory <> ''}
    finally
    MyReg.Free;
    end; {try..finally}
    end; {CreateShortcut}

  8. #408
    کاربر دائمی آواتار gholami146
    تاریخ عضویت
    آبان 1388
    محل زندگی
    مشهد مقدس
    پست
    374

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

    ايجاد يك TWebBrowser در RunTime

    procedure TForm1.Button1Click(Sender: TObject);
    var
    wb: TWebBrowser;
    begin
    wb := TWebBrowser.Create(Form1);
    TWinControl(wb).Name := 'MyWebBrowser';
    TWinControl(wb).Parent := Form1;
    wb.Align := alClient;
    // TWinControl(wb).Parent := TabSheet1; ( To put it on a TabSheet )
    wb.Navigate('http://www.google.com');
    end;

  9. #409
    کاربر دائمی آواتار gholami146
    تاریخ عضویت
    آبان 1388
    محل زندگی
    مشهد مقدس
    پست
    374

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

    ايجاد يك اتصال DBExpress در زمان اجرا

    procedure TVCLScanner.PostUser(const Email, FirstName, LastName: WideString);
    var
    Connection: TSQLConnection;
    DataSet: TSQLDataSet;
    begin
    Connection := TSQLConnection.Create(nil);
    with Connection do
    begin
    ConnectionName := 'VCLScanner';
    DriverName := 'INTERBASE';
    LibraryName := 'dbexpint.dll';
    VendorLib := 'GDS32.DLL';
    GetDriverFunc := 'getSQLDriverINTERBASE';
    Params.Add('User_Name=SYSDBA');
    Params.Add('Password=masterkey');
    Params.Add('Database=milo2:D:\frank\webservices\um lbank.gdb');
    LoginPrompt := False;
    Open;
    end;
    DataSet := TSQLDataSet.Create(nil);
    with DataSet do
    begin
    SQLConnection := Connection;
    CommandText := Format('INSERT INTO kings VALUES("%s","%s","%s")',
    [Email, FirstN, LastN]);
    try
    ExecSQL;
    except
    end;
    end;
    Connection.Close;
    DataSet.Free;
    Connection.Free;
    end;

  10. #410
    کاربر دائمی آواتار gholami146
    تاریخ عضویت
    آبان 1388
    محل زندگی
    مشهد مقدس
    پست
    374

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

    ايجاد يک ديتا بيس Access را در زمان اجرا

    uses
    ComObj;

    procedure TForm1.Button1Click(Sender: TObject);
    var
    AccessApp: Variant;
    begin
    AccessApp := CreateOleObject('Access.Application');
    AccessApp.NewCurrentDatabase('c:\111.mdb');
    AccessApp := Unassigned;
    end;

  11. #411
    کاربر دائمی آواتار gholami146
    تاریخ عضویت
    آبان 1388
    محل زندگی
    مشهد مقدس
    پست
    374

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

    اين تابع براي حذف کليه يک فولدر با کليه فايل ها داخل آن

    procedure TForm1.Button1Click(Sender: TObject);
    var
    DirInfo: TSearchRec;
    r : Integer;
    begin
    r := FindFirst('C:\Download\Test\*.*', FaAnyfile, DirInfo);
    while r = 0 do begin
    if ((DirInfo.Attr and FaDirectory <> FaDirectory) and
    (DirInfo.Attr and FaVolumeId <> FaVolumeID)) then
    if DeleteFile(pChar('C:\Download\test\' + DirInfo.Name))
    = false then
    {Si no puede borrar el fichero}
    ShowMessage('Unable to delete : C:\Download\test\' +
    DirInfo.Name);
    r := FindNext(DirInfo);
    end;
    SysUtils.FindClose(DirInfo);
    if RemoveDirectory('C:\Download\Test') = false then
    {Si no puedes borrar el directorio}
    ShowMessage('Unable to delete dirctory : C:\Download\test');
    end;

  12. #412
    کاربر دائمی آواتار gholami146
    تاریخ عضویت
    آبان 1388
    محل زندگی
    مشهد مقدس
    پست
    374

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

    اين تابع براي عوض کردن مشخصات همه کامپوننت ها در يک فرم است

    procedure TForm1.SetReadOnly(Value:boolean) ;
    var
    PropInfo : PPropInfo;
    Component : TComponent;
    i : integer;
    begin
    for i := 0 to ComponentCount - 1 do begin
    Component := Components[ i ];
    if Component is TControl then begin
    PropInfo := GetPropInfo( Component.ClassInfo, 'ReadOnly' );
    if Assigned( PropInfo ) and
    ( PropInfo^.PropType^.Kind = tkEnumeration ) then
    SetOrdProp( Component, PropInfo, integer( Value ) );
    end;
    end;
    end;


  13. #413
    کاربر دائمی آواتار gholami146
    تاریخ عضویت
    آبان 1388
    محل زندگی
    مشهد مقدس
    پست
    374

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

    با اين کد مي توانيد عنوان دکمه برنامه خودتون رو در Taskbar متحرک کنيد

    procedure TForm1.Timer1Timer(Sender: TObject);
    const
    {$J+}
    animatedTitle : string = 'www.mojtabaie.persianblog.ir';
    {$J-}
    var
    cnt: Integer;

    begin
    Application.Title := animatedTitle;
    for cnt := 1 to (Length(animatedTitle) - 1) do
    begin
    animatedTitle[cnt] := Application.Title[cnt + 1];
    animatedTitle[Length(animatedTitle)] := Application.Title[1];
    end;
    end;

  14. #414
    کاربر دائمی آواتار gholami146
    تاریخ عضویت
    آبان 1388
    محل زندگی
    مشهد مقدس
    پست
    374

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

    با کد زير مي توانيد يک ProgressBar در يک MessageBox معمولي

    procedure TForm1.Button1Click(Sender: TObject) ;
    var
    AMsgDialog : TForm;
    AProgressBar : TProgressBar;
    ATimer : TTimer;
    begin
    AMsgDialog := CreateMessageDialog('Quickly! Answer Yes or No!', mtWarning, [mbYes, mbNo]) ;
    AProgressBar := TProgressBar.Create(AMsgDialog) ;
    ATimer := TTimer.Create(AMsgDialog) ;
    with AMsgDialog do
    try
    Tag := 10; //seconds!

    Caption := 'You have 10 seconds';
    Height := 150;

    with AProgressBar do begin
    Name := 'Progress';
    Parent := AMsgDialog;
    Max := AMsgDialog.Tag; //seconds
    Step := 1;
    Top := 100;
    Left := 8;
    Width := AMsgDialog.ClientWidth - 16;
    end;

    with ATimer do
    begin
    Interval := 1000;
    OnTimer:=DialogTimer;
    end;

    case ShowModal of
    ID_YES: ShowMessage('Answered "Yes".') ;
    ID_NO: ShowMessage('Answered "No".') ;
    ID_CANCEL: ShowMessage('Time up!')
    end;//case
    finally
    ATimer.OnTimer := nil;
    Free;
    end;
    end;


    //make sure you add this function's header in the private part of the TForm1 type declaration.
    procedure TForm1.DialogTimer(Sender: TObject) ;
    var
    aPB : TProgressBar;
    begin
    if NOT (Sender is TTimer) then Exit;

    if ((Sender as TTimer).Owner) is TForm then
    with ((Sender as TTimer).Owner) as TForm do
    begin
    aPB := TProgressBar(FindComponent('Progress')) ;

    if aPB.Position >= aPB.Max then
    ModalResult := mrCancel
    else
    aPB.StepIt;
    end;
    end;

  15. #415
    کاربر دائمی آواتار gholami146
    تاریخ عضویت
    آبان 1388
    محل زندگی
    مشهد مقدس
    پست
    374

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

    باز كردن پنجره پروپرتي پرينتر

    uses WinSpool, Printers;
    ...
    procedure TForm1.Button1Click(Sender: TObject);
    var
    MyPrinter, MyDriver, MyPort: array[0..100] of Char;
    PrinterHandle, DevMode: THandle;
    begin
    Printer.GetPrinter(MyPrinter, MyDriver, MyPort, DevMode);
    OpenPrinter(MyPrinter, PrinterHandle, nil);
    PrinterProperties(Form1.Handle, PrinterHandle);
    end;

  16. #416
    کاربر دائمی آواتار gholami146
    تاریخ عضویت
    آبان 1388
    محل زندگی
    مشهد مقدس
    پست
    374

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

    باز كردن دكمه Start ويندوز

    procedure TForm1.Button1Click(Sender: TObject);
    begin
    SendMessage(Handle, WM_SYSCOMMAND, SC_TASKLIST, 1);
    end;

  17. #417
    کاربر دائمی آواتار gholami146
    تاریخ عضویت
    آبان 1388
    محل زندگی
    مشهد مقدس
    پست
    374

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

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

    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;

  18. #418
    کاربر دائمی آواتار gholami146
    تاریخ عضویت
    آبان 1388
    محل زندگی
    مشهد مقدس
    پست
    374

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

    باز کردن پوشه پرينترها توسط اين تابع انجام مي شود

    procedure TForm1.Button1Click(Sender: TObject);
    var
    PIDL:PItemIDList;
    Info:TShellExecuteInfo;
    pInfo:PShellExecuteInfo;
    WaitCode:DWord;
    begin
    {Obtenemos PIDL de la carpeta virtual}
    {get PIDL of the virtual folder}
    SHGetSpecialFolderLocation(Handle,
    CSIDL_PRINTERS,
    PIDL);
    {Puntero a Info}
    {Pointer to Info}
    pInfo:=@Info;
    {Rellenamos Info}
    {Fill info}
    with Info do
    begin
    cbSize:=SizeOf(Info);
    fMask:=SEE_MASK_NOCLOSEPROCESS+
    SEE_MASK_IDLIST;
    wnd:=Handle;
    lpVerb:=nil;
    lpFile:=nil;
    {Parametros al ejecutable}
    {Executable parameters}
    lpParameters:=nil;
    lpDirectory:=nil;
    nShow:=SW_ShowNormal;
    hInstApp:=0;
    lpIDList:=PIDL;
    end;
    {Ejecutamos}
    {Execute}
    ShellExecuteEx(pInfo);

    {Esperamos que termine}
    {Wait to finish}
    repeat
    WaitCode := WaitForSingleObject(Info.hProcess,500);
    Application.ProcessMessages;
    until (WaitCode <> WAIT_TIMEOUT);

    end;

  19. #419
    کاربر دائمی آواتار gholami146
    تاریخ عضویت
    آبان 1388
    محل زندگی
    مشهد مقدس
    پست
    374

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

    بازگرداندن بزرگترين ID بوسيله SQL

    CREATE PROCEDURE MaxId
    @Max int output,
    @para char(30)
    AS
    select @Max = (select max(Code) from tblBank Where Country = @para)
    return @Max
    GO


  20. #420
    کاربر دائمی آواتار gholami146
    تاریخ عضویت
    آبان 1388
    محل زندگی
    مشهد مقدس
    پست
    374

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

    بدست آوردن آيپي اينترنت External IP

    //add URLMon In Uses
    function Ipfilter(sTexto: String): String;
    var
    iCont: Short;
    sTemp: String;
    begin
    sTemp := '';
    for iCont := 1 to Length(sTexto) do
    if (sTexto[iCont] in ['0'..'9','.']) then
    sTemp:=sTemp+sTexto[iCont];
    //AppendStr(sTemp, sTexto[iCont]);
    Result := sTemp;
    end;
    procedure TForm1.FormCreate(Sender: TObject);
    var
    parser:TStrings;
    begin
    if URLDownloadToFile(nil, 'http://checkip.dyndns.org/', 'c:\windows\temp\externalip.txt', 0, nil) <> 0 then
    MessageBox(Handle, 'An error ocurred while downloading the file.', PChar(Application.Title), MB_ICONERROR or MB_OK);
    parser := TStringList.Create;
    parser.LoadFromFile('c:\windows\temp\externalip.tx t');
    //showmessage(parser.Text);
    edt1.text:=ipfilter(copy(parser.text,pos('IP Address: ',parser.text)+12,16));
    parser.Free;
    end;


  21. #421
    کاربر دائمی آواتار gholami146
    تاریخ عضویت
    آبان 1388
    محل زندگی
    مشهد مقدس
    پست
    374

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

    بدست آوردن اطلاعاتي در مورد حافظه

    procedure TForm1.Button1Click(Sender: TObject);
    var
    MyStatus: TMemoryStatus;
    begin
    MyStatus.dwLength:=SizeOf(MyStatus);
    GlobalmemoryStatus(MyStatus);
    with Memo1.Lines do
    begin
    Add(FloatToStr(MyStatus.dwMemoryLoad)+'% memory in use');
    Add(FloatToStr(MyStatus.dwTotalPhys/1024)+' Kb of physical memory');
    Add(
    FloatToStr(MyStatus.dwAvailPhys/1024)+
    ' Kb of available physical memory');
    Add(
    FloatToStr(MyStatus.dwTotalPageFile/1024)+
    ' Kb that can be stored in the paging file');
    Add(
    FloatToStr(MyStatus.dwAvailPageFile/1024)+
    ' Kb available in the paging file');
    end;
    end;

  22. #422
    کاربر دائمی آواتار gholami146
    تاریخ عضویت
    آبان 1388
    محل زندگی
    مشهد مقدس
    پست
    374

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

    بدست آوردن اطلاعاتي درباره سيستم

    procedure TForm1.Button1Click(Sender: TObject);
    var
    MySystem: TSystemInfo;
    begin
    GetSystemInfo(MySystem);
    with Memo1.Lines do
    begin
    if (MySystem.wProcessorArchitecture=0) then
    Add('Intel architecture');
    Add(FloatToStr(MySystem.dwPageSize)+' Kb page size');
    Add(
    Format('Lowest memory address accessible to applications and DLL - %p',
    [MySystem.lpMinimumApplicationAddress]));
    Add(
    Format('Highest memory address accessible to applications and DLL - %p',
    [MySystem.lpMaximumApplicationAddress]));
    Add(IntToStr(MySystem.dwNumberOfProcessors)+' - number of processors');
    Add(
    FloatToStr(MySystem.dwAllocationGranularity/1024)+
    ' Kb - granularity with which virtual memory is allocated');
    case MySystem.wProcessorLevel of
    3: Add('Intel 80386 processor level');
    4: Add('Intel 80486 processor level');
    5: Add('Intel Pentium processor level');
    end;
    end;
    end;

  23. #423
    کاربر دائمی آواتار gholami146
    تاریخ عضویت
    آبان 1388
    محل زندگی
    مشهد مقدس
    پست
    374

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

    بدست آوردن پروسسهاي فعال شبكه

    unit PerfInfo;

    interface

    uses
    Windows, SysUtils, Classes;

    type
    TPerfCounter = record
    Counter: Integer;
    Value: TLargeInteger;
    end;

    TPerfCounters = Array of TPerfCounter;

    TPerfInstance = class
    private
    FName: string;
    FCounters: TPerfCounters;
    public
    property Name: string read FName;
    property Counters: TPerfCounters read FCounters;
    end;

    TPerfObject = class
    private
    FList: TList;
    FObjectID: DWORD;
    FMachine: string;
    function GetCount: Integer;
    function GetInstance(Index: Integer): TPerfInstance;
    procedure ReadInstances;
    public
    property ObjectID: DWORD read FObjectID;
    property Item[Index: Integer]: TPerfInstance
    read GetInstance; default;
    property Count: Integer read GetCount;
    constructor Create(const AMachine: string; AObjectID: DWORD);
    destructor Destroy; override;
    end;

    procedure GetProcesses(const Machine: string; List: TStrings);

    implementation

    type
    PPerfDataBlock = ^TPerfDataBlock;
    TPerfDataBlock = record
    Signature: array[0..3] of WCHAR;
    LittleEndian: DWORD;
    Version: DWORD;
    Revision: DWORD;
    TotalByteLength: DWORD;
    HeaderLength: DWORD;
    NumObjectTypes: DWORD;
    DefaultObject: Longint;
    SystemTime: TSystemTime;
    PerfTime: TLargeInteger;
    PerfFreq: TLargeInteger;
    PerfTime100nSec: TLargeInteger;
    SystemNameLength: DWORD;
    SystemNameOffset: DWORD;
    end;

    PPerfObjectType = ^TPerfObjectType;
    TPerfObjectType = record
    TotalByteLength: DWORD;
    DefinitionLength: DWORD;
    HeaderLength: DWORD;
    ObjectNameTitleIndex: DWORD;
    ObjectNameTitle: LPWSTR;
    ObjectHelpTitleIndex: DWORD;
    ObjectHelpTitle: LPWSTR;
    DetailLevel: DWORD;
    NumCounters: DWORD;
    DefaultCounter: Longint;
    NumInstances: Longint;
    CodePage: DWORD;
    PerfTime: TLargeInteger;
    PerfFreq: TLargeInteger;
    end;

    PPerfCounterDefinition = ^TPerfCounterDefinition;
    TPerfCounterDefinition = record
    ByteLength: DWORD;
    CounterNameTitleIndex: DWORD;
    CounterNameTitle: LPWSTR;
    CounterHelpTitleIndex: DWORD;
    CounterHelpTitle: LPWSTR;
    DefaultScale: Longint;
    DetailLevel: DWORD;
    CounterType: DWORD;
    CounterSize: DWORD;
    CounterOffset: DWORD;
    end;

    PPerfInstanceDefinition = ^TPerfInstanceDefinition;
    TPerfInstanceDefinition = record
    ByteLength: DWORD;
    ParentObjectTitleIndex: DWORD;
    ParentObjectInstance: DWORD;
    UniqueID: Longint;
    NameOffset: DWORD;
    NameLength: DWORD;
    end;

    PPerfCounterBlock = ^TPerfCounterBlock;
    TPerfCounterBlock = record
    ByteLength: DWORD;
    end;


    {Navigation helpers}

    function FirstObject(PerfData: PPerfDataBlock): PPerfObjectType;
    begin
    Result := PPerfObjectType(DWORD(PerfData) + PerfData.HeaderLength);
    end;


    function NextObject(PerfObj: PPerfObjectType): PPerfObjectType;
    begin
    Result := PPerfObjectType(DWORD(PerfObj) + PerfObj.TotalByteLength);
    end;


    function FirstInstance(PerfObj: PPerfObjectType): PPerfInstanceDefinition;
    begin
    Result := PPerfInstanceDefinition(DWORD(PerfObj) + PerfObj.DefinitionLength);
    end;


    function NextInstance(PerfInst: PPerfInstanceDefinition): PPerfInstanceDefinition;
    var
    PerfCntrBlk: PPerfCounterBlock;
    begin
    PerfCntrBlk := PPerfCounterBlock(DWORD(PerfInst) + PerfInst.ByteLength);
    Result := PPerfInstanceDefinition(DWORD(PerfCntrBlk) + PerfCntrBlk.ByteLength);
    end;


    function FirstCounter(PerfObj: PPerfObjectType): PPerfCounterDefinition;
    begin
    Result := PPerfCounterDefinition(DWORD(PerfObj) + PerfObj.HeaderLength);
    end;


    function NextCounter(PerfCntr: PPerfCounterDefinition): PPerfCounterDefinition;
    begin
    Result := PPerfCounterDefinition(DWORD(PerfCntr) + PerfCntr.ByteLength);
    end;


    {Registry helpers}

    function GetPerformanceKey(const Machine: string): HKey;
    var
    s: string;
    begin
    Result := 0;
    if Length(Machine) = 0 then
    Result := HKEY_PERFORMANCE_DATA
    else
    begin
    s := Machine;
    if Pos('\\', s) &lt;> 1 then
    s := '\\' + s;
    if RegConnectRegistry(PChar(s), HKEY_PERFORMANCE_DATA, Result) &lt;> ERROR_SUCCESS then
    Result := 0;
    end;
    end;


    {TPerfObject}

    constructor TPerfObject.Create(const AMachine: string; AObjectID: DWORD);
    begin
    inherited Create;
    FList := TList.Create;
    FMachine := AMachine;
    FObjectID := AObjectID;
    ReadInstances;
    end;


    destructor TPerfObject.Destroy;
    var
    i: Integer;
    begin
    for i := 0 to FList.Count - 1 do
    TPerfInstance(FList[i]).Free;
    FList.Free;
    inherited Destroy;
    end;


    function TPerfObject.GetCount: Integer;
    begin
    Result := FList.Count;
    end;


    function TPerfObject.GetInstance(Index: Integer): TPerfInstance;
    begin
    Result := FList[Index];
    end;


    procedure TPerfObject.ReadInstances;
    var
    PerfData: PPerfDataBlock;
    PerfObj: PPerfObjectType;
    PerfInst: PPerfInstanceDefinition;
    PerfCntr, CurCntr: PPerfCounterDefinition;
    PtrToCntr: PPerfCounterBlock;
    BufferSize: Integer;
    i, j, k: Integer;
    pData: PLargeInteger;
    Key: HKey;
    CurInstance: TPerfInstance;
    begin
    for i := 0 to FList.Count - 1 do
    TPerfInstance(FList[i]).Free;
    FList.Clear;
    Key := GetPerformanceKey(FMachine);
    if Key = 0 then Exit;
    PerfData := nil;
    try
    {Allocate initial buffer for object information}
    BufferSize := 65536;
    GetMem(PerfData, BufferSize);
    {retrieve data}
    while RegQueryValueEx(Key,
    PChar(IntToStr(FObjectID)), {Object name}
    nil, nil, Pointer(PerfData), @BufferSize) = ERROR_MORE_DATA do
    begin
    {buffer is too small}
    Inc(BufferSize, 1024);
    ReallocMem(PerfData, BufferSize);
    end;
    RegCloseKey(HKEY_PERFORMANCE_DATA);
    {Get the first object type}
    PerfObj := FirstObject(PerfData);
    {Process all objects}
    for i := 0 to PerfData.NumObjectTypes - 1 do
    begin
    {Check for requested object}
    if PerfObj.ObjectNameTitleIndex = FObjectID then
    begin
    {Get the first counter}
    PerfCntr := FirstCounter(PerfObj);
    if PerfObj.NumInstances > 0 then
    begin
    {Get the first instance}
    PerfInst := FirstInstance(PerfObj);
    {Retrieve all instances}
    for k := 0 to PerfObj.NumInstances - 1 do
    begin
    {Create entry for instance}
    CurInstance := TPerfInstance.Create;
    CurInstance.FName := WideCharToString(PWideChar(DWORD(PerfInst) +
    PerfInst.NameOffset));
    FList.Add(CurInstance);
    CurCntr := PerfCntr;
    {Retrieve all counters}
    SetLength(CurInstance.FCounters, PerfObj.NumCounters);
    for j := 0 to PerfObj.NumCounters - 1 do
    begin
    PtrToCntr := PPerfCounterBlock(DWORD(PerfInst) + PerfInst.ByteLength);
    pData := Pointer(DWORD(PtrToCntr) + CurCntr.CounterOffset);
    {Add counter to array}
    CurInstance.FCounters[j].Counter := CurCntr.CounterNameTitleIndex;
    CurInstance.FCounters[j].Value := pData^;
    {Get the next counter}
    CurCntr := NextCounter(CurCntr);
    end;
    {Get the next instance.}
    PerfInst := NextInstance(PerfInst);
    end;
    end;
    end;
    {Get the next object type}
    PerfObj := NextObject(PerfObj);
    end;
    finally
    {Release buffer}
    FreeMem(PerfData);
    {Close remote registry handle}
    if Key &lt;> HKEY_PERFORMANCE_DATA then
    RegCloseKey(Key);
    end;
    end;


    procedure GetProcesses(const Machine: string; List: TStrings);
    var
    Processes: TPerfObject;
    i, j: Integer;
    ProcessID: DWORD;
    begin
    Processes := nil;
    List.Clear;
    try
    Processes := TPerfObject.Create(Machine, 230); {230 = Process}
    for i := 0 to Processes.Count - 1 do
    {Find process ID}
    for j := 0 to Length(Processes[i].Counters) - 1 do
    if (Processes[i].Counters[j].Counter = 784) then
    begin
    ProcessID := Processes[i].Counters[j].Value;
    if ProcessID &lt;> 0 then
    List.AddObject(Processes[i].Name, Pointer(ProcessID));
    Break;
    end;
    finally
    Processes.Free;
    end;
    end;

    end.

  24. #424
    کاربر دائمی آواتار gholami146
    تاریخ عضویت
    آبان 1388
    محل زندگی
    مشهد مقدس
    پست
    374

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

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

    uses Printers;
    ...
    procedure TForm1.Button1Click(Sender: TObject);
    begin
    Memo1.Lines.Assign(Printer.Printers);
    end;

  25. #425
    کاربر دائمی آواتار gholami146
    تاریخ عضویت
    آبان 1388
    محل زندگی
    مشهد مقدس
    پست
    374

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

    بدست آوردن جداول يك بانك با استفاده از ADO

    unit dbTables;

    interface

    uses ADODb;

    type
    TTableType = (ttTable, ttView, ttSynonym, ttSystemTable, ttAccessTable);

    type
    TTableTypes = set of TTableType;

    type
    TTableItem = record
    ItemName: string;
    ItemType: string;
    end;

    type
    TTableItems = array of TTableItem;
    function addFilter(string1, string2: string): string;
    function ADODbTables(ADOConnection: TADOConnection; types: TTableTypes): TTableItems;

    implementation

    function addFilter(string1, string2: string): string;
    begin
    if string1 <> '' then
    Result := string1 + ' or ' + string2
    else
    Result := string2;
    end;

    function ADODbTables(ADOConnection: TADOConnection; types: TTableTypes): TTableItems;
    var
    ADODataSet: TADODataSet;
    i: integer;
    begin
    ADODataSet := TADODataSet.Create(nil);
    ADODataSet.Connection := ADOConnection;
    ADOConnection.OpenSchema(siTables, EmptyParam, EmptyParam, ADODataSet);

    if (ttTable in types) then
    ADODataSet.Filter := addFilter(ADODataSet.Filter, '(TABLE_TYPE = ''TABLE'')');

    if (ttView in types) then
    ADODataSet.Filter := addFilter(ADODataSet.Filter, '(TABLE_TYPE = ''VIEW'')');

    if (ttSynonym in types) then
    ADODataSet.Filter := addFilter(ADODataSet.Filter, '(TABLE_TYPE = ''SYNONYM'')');

    if (ttSystemTable in types) then
    ADODataSet.Filter := addFilter(ADODataSet.Filter, '(TABLE_TYPE = ''SYSTEM TABLE'')');

    if (ttAccessTable in types) then
    ADODataSet.Filter := addFilter(ADODataSet.Filter, '(TABLE_TYPE = ''ACCESS TABLE'')');

    ADODataSet.Filtered := True;

    SetLength(Result, ADODataSet.RecordCount);

    i := 0;
    with ADODataSet do
    begin
    First;
    while not EOF do
    begin
    with Result[i] do
    begin
    ItemName := FieldByName('TABLE_NAME').AsString;
    ItemType := FieldByName('TABLE_TYPE').AsString;
    end;
    Inc(i);
    Next;
    end;
    end;
    ADODataSet.Free;
    end;

    end.

    {
    Example: create a new project and add a TADOConnection (ADOConnection1),
    a TButton (Button1) and a TMemo (Memo1); assign a ConnectionString to the
    TADOConnection component and set "ADOConnection1.Active := True"
    }

    procedure TForm1.Button1Click(Sender: TObject);
    var
    output: ttableitems;
    i: integer;
    begin
    output := ADODbTables(ADOConnection1, [ttTable, ttView, ttSynonym]);
    // output := ADODbTables(ADOConnection1, [ttSystemTable, ttAccessTable]);
    for i := Low(output) to High(output) do
    begin
    Memo1.Lines.Add(output[i].ItemName + '---' + output[i].ItemType);
    end;
    output := nil;
    end;

  26. #426
    کاربر دائمی آواتار gholami146
    تاریخ عضویت
    آبان 1388
    محل زندگی
    مشهد مقدس
    پست
    374

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

    بدست آوردن خط جاري در Memo

    procedure TForm1.Memo1KeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
    var LineNum: LongInt;
    begin
    if (Key=VK_UP)or(Key=VK_DOWN) then
    begin
    LineNum:=Memo1.Perform(EM_LINEFROMCHAR, Memo1.SelStart, 0);
    Label1.Caption:='Line - '+IntToStr(LineNum+1);
    end;
    end;

  27. #427
    کاربر دائمی آواتار gholami146
    تاریخ عضویت
    آبان 1388
    محل زندگی
    مشهد مقدس
    پست
    374

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

    بدست آوردن پسورد فايلهاي اکسس 97

    Procedure GetMDB97PassWord;

    Const
    XorArr : Array[0..12] of Byte =
    ($86,$FB,$EC,$37,$5D,$44,$9C,$FA,$C6,$5E,$28,$E6,$ 13);

    Var
    I : Integer;
    S1 : String;
    FI : File of Byte;
    By : Byte;
    Access97 : Boolean;
    FileError : Boolean;

    Begin
    // Init
    FileError := False;
    Access97 := True;

    // Open *.mbd file
    AssignFile(FI,Filename);
    Reset(FI);

    // Read file
    I := 0;
    Repeat
    If not Eof(FI) then
    Begin
    Read(FI,By);
    Inc(I);
    End;
    Until (I = $42) or Eof(FI);
    If Eof(FI) then
    FileError := True;

    // Read password string
    S1 := '';
    For I := 0 to 12 do
    If not Eof(FI) then
    Begin
    Read(f,By);
    S1 := S1 + Chr(By);
    End;

    If Eof(FI) then
    FileError := True;

    //Close file
    CloseFile(FI);

    // Is nul string?
    If S1 = #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 then
    Access97 := False;

    // Decode string
    For I := 0 to 12 do
    S1[I + 1] := Chr(Ord(S[I + 1]) xor XORArr[i]);

    // Find end of string
    I := Pos(#0,S1);
    If I = 1 then
    S1 := '';
    If I > 1 then
    S1 := Copy(S1,1,I);

    If Access97 then
    Begin
    If Length(S1) > 0 then
    ShowMessage := ('The password is: "' + S1 + '".')
    else
    ShowMessage ('The file is NOT password protected.');
    End
    else
    ShowMessage('The file is not an Access 97 file.');

    If FileError then
    ShowMessage('File error');

    End;

  28. #428
    کاربر دائمی آواتار gholami146
    تاریخ عضویت
    آبان 1388
    محل زندگی
    مشهد مقدس
    پست
    374

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

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

    procedure TForm1.Button1Click(Sender: TObject);
    var
    PWindowsDir: array [0..255] of Char;
    begin
    GetWindowsDirectory(PWindowsDir,255);
    Label1.Caption:=StrPas(PWindowsDir);
    end;

  29. #429

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

    توابع تبدیل تاریخ با دقت 5000 سال
    پذیرش پروژه، کامپوننت، آموزش برنامه نویسی (دلفی، اس کیو ال، ..) -> 09123780840

    دوستای گلم حمایت کنید : https://cafebazaar.ir/app/com.nikanmehr.marmarxword/


    نرم افزار پخش مویرگی

  30. #430

    تعریف ثابتی از نوع آرایه ای از رکورد

    برای دیدن روش کار به لینک زیر مراجعه کنید:
    https://barnamenevis.org/showthread.php?420040

  31. #431
    مدیر بخش آواتار Mask
    تاریخ عضویت
    شهریور 1387
    محل زندگی
    اصفهان
    پست
    3,379

    حلقه For کاهشی یا افزایشی

    گاهی اوقات نیاز میشود که حلقه ای برعکس شرایط عادی ، یعنی کاهشی بنویسم.
    برای مشخص نمودن افزایشی یا کاهشی بودن for از دو کلمه ی کلیدی to برای افزایشی کردن حلقه و downto برای کاهشی کردن حلقه استفاده می گردد.

    توضیح: حلقه ی افزایشی به حلقه ای گفته می شود که در آن مقدار اندیس حلقه در هر بار تکرار حلقه افزایش می یابد ولی حلقه ی کاهشی در هر تکرار حلقه مقدار اندیس حلقه را کاهش می دهد.
    افزایشی
    for variable := start to finish do

    // code

    مثال :
    for i := 0 to  10 do
    Memo1.Lines.Append(IntToStr(i));

    کاهشی :
    for variable := start downto  finish do

    // code

    مثال :
    for i := 10 downto  0 do
    Memo1.Lines.Append(IntToStr(i));
    آموزش خصوصی برنامه نویسی بزبان دلفی در اصفهان و تهران.
    با ما تماس بگیرید.


صفحه 11 از 11 اولاول ... 91011

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

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

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