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

[gholami146]

ايجاد 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;

[gholami146]

ايجاد خروجي از 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.

[gholami146]

ايجاد سايه براي 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.                 

[gholami146]

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

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;

[gholami146]

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

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;

[gholami146]

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

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;

[gholami146]

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

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}

[gholami146]

ايجاد يك 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;

[gholami146]

ايجاد يك اتصال 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;

[gholami146]

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

uses

ComObj;



procedure TForm1.Button1Click(Sender: TObject);

var

AccessApp: Variant;

begin

AccessApp := CreateOleObject('Access.Application');

AccessApp.NewCurrentDatabase('c:\111.mdb');

AccessApp := Unassigned;

end;

[gholami146]

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

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; 

[gholami146]

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

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;

      

[gholami146]

با اين کد مي توانيد عنوان دکمه برنامه خودتون رو در 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; 

[gholami146]

با کد زير مي توانيد يک 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;

[gholami146]

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

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;  

[gholami146]

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

procedure TForm1.Button1Click(Sender: TObject);

begin

  SendMessage(Handle, WM_SYSCOMMAND, SC_TASKLIST, 1);

end;  

[gholami146]

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

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;

[gholami146]

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

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;

[gholami146]

بازگرداندن بزرگترين 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

     

[gholami146]

بدست آوردن آيپي اينترنت 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;

[gholami146]

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

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;

[gholami146]

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

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;

[gholami146]

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

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) <> 1 then 

      s := '\\' + s; 

    if RegConnectRegistry(PChar(s), HKEY_PERFORMANCE_DATA, Result) <> 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 <> 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 <> 0 then 

            List.AddObject(Processes[i].Name, Pointer(ProcessID)); 

          Break; 

        end; 

  finally 

    Processes.Free; 

  end; 

end; 



end.

[gholami146]

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

uses Printers;

...

procedure TForm1.Button1Click(Sender: TObject);

begin

  Memo1.Lines.Assign(Printer.Printers);

end;

[gholami146]

بدست آوردن جداول يك بانك با استفاده از 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;

[gholami146]

بدست آوردن خط جاري در 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;

[gholami146]

بدست آوردن پسورد فايلهاي اکسس 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;

[gholami146]

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

procedure TForm1.Button1Click(Sender: TObject);

var

  PWindowsDir: array [0..255] of Char;

begin

  GetWindowsDirectory(PWindowsDir,255);

  Label1.Caption:=StrPas(PWindowsDir);

end;  

[یوسف زالی]

ست شدن اندازه ی Memo با محتویات درون آن

[BORHAN TEC]

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

[Mask]

گاهی اوقات نیاز میشود که حلقه ای برعکس شرایط عادی ، یعنی کاهشی بنویسم.
برای مشخص نمودن افزایشی یا کاهشی بودن 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));

[mbshareat]

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

من در تعریف نوع خسیس بازی در میارم. در یک برنامه از نوع داده Word استفاده کرده بودم . از این کد برای Draw استفاده می کردم اما گاهی چیزی رسم نمیشد. بعد دیدم عدد منفی به 65535 و .. تبدیل میشد!
یه اشکال عجیب دیگه هم این بود که یک آرایه تعریف کرده بودم که تعداد سطرهای نمایشی یک فایل متن رو 2000 داده بودم.
تعداد سطرها بیشتر میشد، برنامه میرفت مقدار رو توی یک متغیر دیگه میریخت.گاهی در خوندن کارکتر بعد از پایان رشته هم مشکل پیش میاد مثل وقتی که در یک حلقه میگیم تا آخر رشته بررسی کن که کارکتر بعدی چیه و اگر فلان کارکتر بعد از کارکتر خاصی بود..(از نحوه ذخیره آرایه و استفاده برنامه از حافظه چیز زیادی نمی دونم)
وقتی یک رشته مقداردهی می کنیم که وسطش کارکتر 0# هست، (حد اقل در دلفی نسخه خودم) بقیه رشته خونده نمیشه.

* چند تا نکته گرافیکی هم بگم:

وقتی میخوایم یک خط ترسیم کنیم، سریعترین راه استفاده از PolyLine هست.(راه دیگه استفاده از MoveTo ,LineTo هست)
LineTo آخرین نقطه خط رو رسم نمی کنه
چنین کدی مربع 2*2 رسم می کنه:

R:=Rect(11,11,13,13);

canvas.Rectangle(R);

Stretch میتونه برای ذره بین استفاده بشه. و تنظیمش طول و عرض بیت مپ رو تغییر نمیده اما در MouseMove روی TImage مختصات X,Y طبق محل زیر ماوس هست نه نقطه در بیت مپ.
انتساب یک بت مپ به دیگری با =: معادل assign نیست. اولی فقط باعث بشه دو بیت مپ یک حافظه داشته باشند. بنابر این اگر داشته باشیم:

B:=B2;

با تغییر نقاط رنگی بیت مپ B2، پیکسلهای B هم تغییر می کنند.
اگر در یک پروسیجر بخوایم پیکسلها رو به صورت عمودی ببرسی کنیم؛ مثلا حلقه بررسی عمودی پیکسلها درون حلقه بررسی افقی پیکسلها باشه،(به طور مثال برای بررسی رنگ پیکسل مجاور که راه بهتری هم داره) بهتره به جای اینکه برای هر پیکسل از scanline استفاده کنیم، یک ارایه از مقدار برگردونده شده توسط scanline داشته باشیم. چون scanline نیاز به محاسبه داره و فقط مثل اشارهگر به محل ذخیره اولین بایت از اولین پیکسل از یک خط پیکسل هست.نتیجه اختلاف سرعت در بیت مپ بزرگ معلوم میشه.

[یوسف زالی]

نوع word فقط اعداد مثبت رو ساپورت می کنه، اعداد منفی بیت علامت دارند که اولین بیت از سمت چپ یک متغیره و کامپایلر ازش می فهمه منفی هست یا مثبت، این بیت برای اعداد مثبت صفر و برای اعداد منفی یک هست، اگر سعی کنید در متغیر ورد یک عدد منفی بریزید یعنی در اولین بیتش از سمت چپ دارید یک می ریزید و چون متغیر از نوع ورد هست طبعا باید کامپایلر اون رو مثبت تفسیر کنه و می شه اونی که گفتی.
در خصوص آرایه ها و غیره گاهی پیش میاد که از حد تعریف شده بصورت غیر مجاز بزنید بالاتر، وقتایی که شدنیه خود کامپایلر جلوتون رو می گیره ولی گاهی به هر دلیلی نمی تونه، تعریف متغیر ها هم بسته به سایزی که دارن معمولا پشت سر هم روی حافظه اتفاق می افته برای همین از یکی بزنید بیرون می ریزه تو بعدی! این داستان خوشبختانه در دلفی خیلی خیلی کمتره، اگر برنامه نویسی سی کرده باشید خیلی این موضوع براتون غریبه نیست.
در خصوص 0 در رشته، خود صفر که کدش 48 هست، اگر عدد 0 رو داخل رشته بریزید نال در نظر گرفته می شه، رشته ها در دلفی معمولا بایت اولشون طولشون هست، یعنی وقتی می گید رشته ده تایی، کامپایلر 11 بایت رزرو می کنه، وقتی هم هیچی نمی گید 255 تا رزرو می کنه نه 256 تا، چرا؟ چون یه دونه می ذاره برا طول. اصلا دلیل این که ماکزیمم طول نمی تونه بالاتر از 255 بره (در این نوع رشته) اینه که از این عدد بیشتر نمی تونید تو یک بایت که برای طول در نظر گرفته شده بریزید.
انواع دیگه رشته هم هستند که از همین نال برای تشخیص پایان رشته استفاده می کنند، مهم ترینشون هم PChar هست.
احتمال زیادی داره که کامپایلر در توابعتون نال رو تفسیر به پایان رشته کرده باشه.

موفق باشید.


---------

اضافات:

در مورد انتساب اشیا، اگر متغیری از نوع یک شی رو مساوی یک متغیر شی دیگه قرار بدید، در حقیقت دارید می گید که این اشاره گر به یک شی به همونجایی اشاره کنه که اون یکی داره اشاره می کنه، برای این که این دو تا از هم جدا باشند، باید حتما اونها رو جداگانه Create یا Assign کنید.
این ها کاملا منطقی و جزو اساس برنامه نویسی شی گراست، در حقیقت یک پله هم قبل از شی گراییه، به طور خلاصه، هر متغیری از نوع شی باشه یک پوینتر محسوب می شه و معمولا 4 بایته! مهم جاییه که داره بهش اشاره می کنه.

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

[mbshareat]

سلام بر دوستان
دو تا نکته در مورد چک باکس یادم اومد. چون خودم درگیرش شده بودم گفتم شاید بد نیست اینجا بذارم:
1.وقتی در رویداد MouseDown کد میذاریم، هنوز وضعیت Checked عوض نشده
2.کد Click چک باکس با تنظیم Checked اجرا میشه. به همین دلیل اگر در Create این خصوصیت(Checked ) رو تنظیم می کنیم، ممکنه دچار Access Violation یا مشکل فوکوس به پنجره نامرئی بشیم.من برای حل این مشکل از بررسی متغیر FirstRun که در ابتدای اجرای برنامه True می کنم، در رویداد Click استفاده می کنم.(بررسی Visible هم معمولا جواب میده!)

در مورد لیست باکس:
اگر لیست بلندی داریم مثل برنامه متنی خودم که نمایش و آماده سازی متن با انتساب به Items.Text خیلی طول میکشه میتونیم برای هر سطر یک فاصله اضافه کنیم (با چیزی مثل DupeString(' '+#10,N)) و هر آیتم از لیست باکس رو در آرایه بریزیم. و بعد برای ترسیم هر سطر لیست باکس در OnDrawItem با بررسی عنصر مرتبط در آرایه، اقدام کنیم( تفصیلش رو خودتون بررسی کنید)

[mbshareat]

سلام خدمت دوستان
تعدادی اشکال هست که ممکنه برنامه رو بررسی کنیم ولی متوجهشون نشیم. بعضیهاشون اصالتاً اشکال برنامه نویسی نیستند و میتونند هنگام صحبت هم پیش بیاند.چند تاشون رو لیست می کنم.بد نیست اگر سر در نیوردیم مشکل برنامه چیه، دنبال چنین اشکالاتی بگردیم:
(ممکنه قبلا هم چنین پستی با اختصار گذاشته باشم و یادم رفته باشه!!)

* جابجايي سطرهای کد: گاهی فقط باید یک سطر کد رو قبل یا بعد از موقعیت فعلیش بذاریم

* کمبود پرانتز در عبارت عددی یا ترکیب And و Or:عبارت 1+2-3 با (1+2)-3 برابر نیست

* فراموش کردن مقداردهي اوليه اعداد:فرض کنید میخوایم N رو در حلقه با یک شرطی یکی اضافه کنیم. قبل از شروع حلقه باید N رو صفر کنیم وگرنه معلوم نیست چی پیش بیاد.

* الصاق کد بدون تغيير موارد ضروری: گاهی کد دو پروسیجر شبیه هم هستند یا از اینترنت گرفتیم و چیزی شبیهش نیاز داریم ؛ کپی و الصاق می کنیم اما یادمون میره که کمی هم متفاوت هستند.

* متغير مشابه: بارها شده X , X2 یا حتی I,J در حلقه رو با هم قاطی کردم.مخصوصا هنگام کپی و الصاق پیش میاد.

* نام مبهم براي متغير يا پروسيجر. بعد از مدتی از نوشتن برنامه، اسم گویا برای متغیر و پروسیجر مهم میشه،چون یادمون میره کارش چی بود و شاید فکر کنیم در قسمتی از کد بهش نیاز نداریم یا کارکردش چیز دیگه ای هست.

* فراموشی خروج از حلقه: بارها شده فراموش کردم Break استفاده کنم.
نکته:گاهی لازم هست یک شرط رو با بعد از چند خط کد محاسباتی بررسی کنیم. در این صورت میتونیم اگر شرایط برقرار نبود داخل بلاک جرای حلقه، از Continue استفاده کنیم که از اون بار اجرای کد صرف نظر بشه.

* استفاده نادرست از نوع داده کوچک يا بي علامت : این اشکال برنامه نویسی گاهی میتونه باعث به دست آمدن عدد نادرست و عمل نادرست بشه.

* تعریف آرایه با تعداد اندیسهای کم یا ارسال آرایه شروع شده از غیر صفر به پروسیجر: در پروسیجر اولین مورد، مورد اندیس صفر محسوب میشه و مثلا اگر در پروسیجر بگیم مورد دارای اندیس یک رو تغییر بده، برنامه، مورد دوم از آرایه شروع شده با یک رو در نظر میگیره!

* Else بعد از دو شرط:این کد رو ملاحظه کنید:

  If X=1 then

    If Y=2 then

      A:=0

  Else

    N:=3;

Else استثنا از شرط دوم هست. برای اینکه استثنا از شرط اول بشه بهتر هست از Begin..end برای شرط اول استفاده کنیم. گاهی هم میشه دو شرط رو با And ادغام کرد.

* استفاده از قسمتی از رشته بعد از حذف آن. بعضی وقتها میشه قسمتی از رشته رو گرفتم و درمتغیر ریختم و حذف کردم اما باز هم انتظار دارم اون قسمت از متن هنوز سر جاش باشه!!

* استفاده از حلقه افزایشی به جای کاهشی، هنگام دستکاری متن: مثلا میخوایم در صورت برقرار بودن شرطی، یک متن کوتاه در محل جاری از متن اصلی درج کنیم، بهتره در حلقه از انتها به سمت ابتدای رشته اصلی بررسی کنیم. (روش دیگه استفاده از While به جای For هست)
گاهی هم که چند فایل رو میخونیم و هر فایل رو به پروسیجر میدیم که کاری انجام بده، اگراز یک متغیر غیر وابسته به فایل خاص استفاده کنیم، رعایت نکردن ترتیب معکوس برای خوندن فایلها مشکل ساز میشه. من برای بررسی عناوین تکراری یک کتاب، حواسم نبود، فایلها رو از اول به آخر خوندم . درحالیکه هرفایل رو از آخر به اول بررسی می کردم و از یک متغیر عمومی هم استفاده می کردم که نشون میداد عنوان بعدی (که ممکن بود درفایل بعد باشه) چی بوده، به این مشکل برخوردم.

چند نقص که خطای برنامه نویسی نیستند اما مهم هستند:

* رعايت نکردن تو رفتگي: بدون رعایتIndent گاهی درک کد مشکل میشه و موجب اشتباه در کد نویسی میشه.(گاهی Begin رو در سطر، بعد از then ، میذارند و گیج میشم!)

* کمبود کامنت: در برنامه های بزرگ که یک پروسیجر میتونه تعداد زیادی پروسیجر یا انتساب داشته باشه، مهم هست که کامنت کافی برای بعد داشته باشیم. ممکنه فردای نوشتن کد هم یادمون بره بعد از آزمون و خطا چه کار کردیم.
من خودم برای کامنتهای مهمتر از (**) استفاده می کنم و در بالا یا کنار کد از // و وسط کد از {} استفاده می کنم