# Native Code > برنامه نویسی در Delphi >  هدیه به دوستان برنامه نویس

## maisam57

با سلام  و عرض خسته نباشید به مدیران و دوستان برنامه نویس
امیدوارم که مجموعه زیر بدرد بخوره
با تشکر
میثم ثوامری
*******************
یه کد برای autosize کردن ستونهای dbgrid

procedure SetGridColumnWidths(Grid: Tdbgrid);
const
  DEFBORDER = 10;
var
  temp, n: Integer;
  lmax: array [0..30] of Integer;
begin
  with Grid do
  begin
    Canvas.Font := Font;
    for n := 0 to Columns.Count - 1 do
      //if columns[n].visible then
      lmax[n] := Canvas.TextWidth(Fields[n].FieldName) + DEFBORDER;
    grid.DataSource.DataSet.First;
    while not grid.DataSource.DataSet.EOF do 
    begin
      for n := 0 to Columns.Count - 1 do 
      begin
        //if columns[n].visible then begin
        temp := Canvas.TextWidth(trim(Columns[n].Field.DisplayText)) + DEFBORDER;
        if temp > lmax[n] then lmax[n] := temp;
        //end; { if }
      end; {for}
      grid.DataSource.DataSet.Next;
    end; { while }
    grid.DataSource.DataSet.First;
    for n := 0 to Columns.Count - 1 do
      if lmax[n] > 0 then
        Columns[n].Width := lmax[n];
  end; { With }
end; {SetGridColumnWidths  }

procedure TForm1.Button1Click(Sender: TObject);
begin
  SetGridColumnWidths(dbgrid3);
end;

--------------------
convert یه query به table

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics,
  Controls, Forms,
  Dialogs, StdCtrls, Grids, DBGrids, DB, DBTables;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Query1: TQuery;
    DataSource1: TDataSource;
    DBGrid1: TDBGrid;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
  InitQuery: TQuery;
  InitTable: TTable;
  InitBatch: TBatchMove;
begin
  InitQuery := TQuery.Create(Application);
  with InitQuery do
  begin
    DatabaseName := 'DBDEMOS';
    Close;
    SQL.Clear;
    SQL.Add('SELECT * ');
    SQL.Add('FROM customer.db');
    SQL.Add('WHERE Country="US"');
    SQL.SaveToFile('mgrInit.sql');
    try
      Open;
      try // Send the SQL result to c:\temp\INIT.DB
        InitTable := TTable.Create(Application);
        with InitTable do 
        begin 
          DatabaseName := 'c:\temp';
          TableName    := 'INIT';
        end;
        InitBatch := TBatchMove.Create(Application);
        with InitBatch do 
        begin
          Destination := InitTable;
          Source      := InitQuery;
          Mode        := batCopy;
          Execute;
        end;
      finally
        InitTable.Free;
        InitBatch.Free;
      end;
    except
      Free;
      Abort;
    end;
    Free;
  end;
end;

end.

--------------------
ایجاد بانک اکسس

uses
  ComObj;

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

--------------------
ایجاد یه adoconnection

uses OleDB, ComObj, ActiveX;

function ADOConnectionString(ParentHandle: THandle; InitialString: WideString;
  out NewString: string): Boolean;
var
  DataInit: IDataInitialize;
  DBPrompt: IDBPromptInitialize;
  DataSource: IUnknown;
  InitStr: PWideChar;
begin
  Result   := False;
  DataInit := CreateComObject(CLSID_DataLinks) as IDataInitialize;
  if InitialString <> '' then
    DataInit.GetDataSource(nil, CLSCTX_INPROC_SERVER, PWideChar(InitialString),
      IUnknown, DataSource);
  DBPrompt := CreateComObject(CLSID_DataLinks) as IDBPromptInitialize;
  if Succeeded(DBPrompt.PromptDataSource(nil, ParentHandle,
    DBPROMPTOPTIONS_PROPERTYSHEET, 0, nil, nil, IUnknown, DataSource)) then 
  begin
    InitStr := nil;
    DataInit.GetInitializationString(DataSource, True, InitStr);
    NewString := InitStr;
    Result    := True;
  end;
end;

--------------------
چند تا آیکن xp

----------


## maisam57

export یه dataset به xml

unit DS2XML;

interface

uses
  Classes, DB;

procedure DatasetToXML(Dataset: TDataSet; FileName: string);

implementation

uses
  SysUtils;

var
  SourceBuffer: PChar;

procedure WriteString(Stream: TFileStream; s: string);
begin
  StrPCopy(SourceBuffer, s);
  Stream.Write(SourceBuffer[0], StrLen(SourceBuffer));
end;

procedure WriteFileBegin(Stream: TFileStream; Dataset: TDataSet);

  function XMLFieldType(fld: TField): string;
  begin
    case fld.DataType of
      ftString: Result   := '"string" WIDTH="' + IntToStr(fld.Size) + '"';
      ftSmallint: Result := '"i4"'; //??
      ftInteger: Result  := '"i4"';
      ftWord: Result     := '"i4"'; //??
      ftBoolean: Result  := '"boolean"';
      ftAutoInc: Result  := '"i4" SUBTYPE="Autoinc"';
      ftFloat: Result    := '"r8"';
      ftCurrency: Result := '"r8" SUBTYPE="Money"';
      ftBCD: Result      := '"r8"'; //??
      ftDate: Result     := '"date"';
      ftTime: Result     := '"time"'; //??
      ftDateTime: Result := '"datetime"';
      else
    end;
    if fld.Required then
      Result := Result + ' required="true"';
    if fld.ReadOnly then
      Result := Result + ' readonly="true"';
  end;
var
  i: Integer;
begin
  WriteString(Stream, '<?xml version="1.0" standalone="yes"?><!-- Generated by SMExport -->  ' +
    '<DATAPACKET Version="2.0">');
  WriteString(Stream, '<METADATA><FIELDS>');

  {write th metadata}
  with Dataset do
    for i := 0 to FieldCount - 1 do
    begin
      WriteString(Stream, '<FIELD attrname="' +
        Fields[i].FieldName +
        '" fieldtype=' +
        XMLFieldType(Fields[i]) +
        '/>');
    end;
  WriteString(Stream, '</FIELDS>');
  WriteString(Stream, '<PARAMS DEFAULT_ORDER="1" PRIMARY_KEY="1" LCID="1033"/>');
  WriteString(Stream, '</METADATA><ROWDATA>');
end;

procedure WriteFileEnd(Stream: TFileStream);
begin
  WriteString(Stream, '</ROWDATA></DATAPACKET>');
end;

procedure WriteRowStart(Stream: TFileStream; IsAddedTitle: Boolean);
begin
  if not IsAddedTitle then
    WriteString(Stream, '<ROW');
end;

procedure WriteRowEnd(Stream: TFileStream; IsAddedTitle: Boolean);
begin
  if not IsAddedTitle then
    WriteString(Stream, '/>');
end;

procedure WriteData(Stream: TFileStream; fld: TField; AString: ShortString);
begin
  if Assigned(fld) and (AString <> '') then
    WriteString(Stream, ' ' + fld.FieldName + '="' + AString + '"');
end;

function GetFieldStr(Field: TField): string;

  function GetDig(i, j: Word): string;
  begin
    Result := IntToStr(i);
    while (Length(Result) < j) do
      Result := '0' + Result;
  end;
var 
  Hour, Min, Sec, MSec: Word;
begin
  case Field.DataType of
    ftBoolean: Result := UpperCase(Field.AsString);
    ftDate: Result    := FormatDateTime('yyyymmdd', Field.AsDateTime);
    ftTime: Result    := FormatDateTime('hhnnss', Field.AsDateTime);
    ftDateTime: 
      begin
        Result := FormatDateTime('yyyymmdd', Field.AsDateTime);
        DecodeTime(Field.AsDateTime, Hour, Min, Sec, MSec);
        if (Hour <> 0) or (Min <> 0) or (Sec <> 0) or (MSec <> 0) then
          Result := Result + 'T' + GetDig(Hour, 2) + ':' + GetDig(Min,
            2) + ':' + GetDig(Sec, 2) + GetDig(MSec, 3);
      end;
    else
      Result := Field.AsString;
  end;
end;

procedure DatasetToXML(Dataset: TDataSet; FileName: string);
var
  Stream: TFileStream;
  bkmark: TBookmark;
  i: Integer;
begin
  Stream       := TFileStream.Create(FileName, fmCreate);
  SourceBuffer := StrAlloc(1024);
  WriteFileBegin(Stream, Dataset);

  with DataSet do
  begin
    DisableControls;
    bkmark := GetBookmark;
    First;

    {write a title row}
    WriteRowStart(Stream, True);
    for i := 0 to FieldCount - 1 do
      WriteData(Stream, nil, Fields[i].DisplayLabel);
    {write the end of row}
    WriteRowEnd(Stream, True);

    while (not EOF) do
    begin
      WriteRowStart(Stream, False);
      for i := 0 to FieldCount - 1 do
        WriteData(Stream, Fields[i], GetFieldStr(Fields[i]));
      {write the end of row}
      WriteRowEnd(Stream, False);

      Next;
    end;

    GotoBookmark(bkmark);
    EnableControls;
  end;

  WriteFileEnd(Stream);
  Stream.Free;
  StrDispose(SourceBuffer);
end;

end.


//Beispiel, Example:


uses DS2XML;

procedure TForm1.Button1Click(Sender: TObject);
  begin  DatasetToXML(Table1, 'test.xml');
  end;

--------------------
export یه table در excel بدون استفاده از OLE

  1)Project->Import Type Library:
  2)Select "Microsoft ADO Ext. for DDL and Security"
  3)Uncheck "Generate component wrapper" at the bottom
  4)Rename the class names (TTable, TColumn, TIndex, TKey, TGroup, TUser, TCatalog) in
    (TXTable, TXColumn, TXIndex, TXKey, TXGroup, TXUser, TXCatalog)
    in order to avoid conflicts with the already present TTable component.
  5)Select the Unit dir name and press "Create Unit".
    It will be created a file named AOX_TLB.
    Include ADOX_TLB in the "uses" directive inside the file in which you want
    to use ADOX functionality.

  That is all. Let's go now with the implementation:
}

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.


--------------------
تعمیر و فشرده کردن یه بانک اکسس

uses
  ComObj;

function CompactAndRepair(DB: string): Boolean; {DB = Path to Access Database}
var 
  v: OLEvariant;
begin
  Result := True;
  try
    v := CreateOLEObject('JRO.JetEngine');
    try
      V.CompactDatabase('Provider=Microsoft.Jet.OLEDB.4.  0;Data Source='+DB,
                        'Provider=Microsoft.Jet.OLEDB.4.0;Data Source='+DB+'x;Jet OLEDB:Engine Type=5');
      DeleteFile(DB);
      RenameFile(DB+'x',DB);
    finally
      V := Unassigned;
    end;
  except
    Result := False;
  end;
end;

--------------------
تعریف user در sqlserver2000

procedure TForm1.Button1Click(Sender: TObject);
begin
  ADOConnection1.Connected := True;
  ADOCommand1.CommandText  := 'Exec SP_AddLogin ' + QuotedStr('UserName') +
    ',' + QuotedStr('Password') + ',' + QuotedStr('Database Name') + ',' +
    QuotedStr('English') + ';';
  ADOCommand1.Execute;
end;

--------------------
انتخاب همه رکوردها در dbgrid

function GridSelectAll(Grid: TDBGrid): Longint;
begin
  Result := 0;
  Grid.SelectedRows.Clear;
  with Grid.DataSource.DataSet do
  begin
    First;
    DisableControls;
    try
      while not EOF do
      begin
        Grid.SelectedRows.CurrentRowSelected := True;
        Inc(Result);
        Next;
      end;
    finally
      EnableControls;
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  GridSelectAll(DBGrid1);
end;

--------------------
انتخاب یک رکورد تصادفی

procedure TForm1.FormCreate(Sender: TObject);
begin
  Randomize;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Table1.First;
  Table1.MoveBy(Random(Table1.RecordCount));
end;

----------


## maisam57

ایحاد یک بانک مجازی در حافضه

unit Inmem;

interface

uses DBTables, WinTypes, WinProcs, DBITypes, DBIProcs, DB, SysUtils;

type
  TInMemoryTable = class(TTable)
  private
    hCursor: hDBICur;
    procedure EncodeFieldDesc(var FieldDesc: FLDDesc;
      const Name: string; DataType: TFieldType; Size: Word);
    function CreateHandle: HDBICur; override;
  public
    procedure CreateTable;
  end;

implementation

{
  Luckely this function is virtual - so I could override it. In the
  original VCL code for TTable this function actually opens the table -
  but since we already have the handle to the table - we just return it
}

function TInMemoryTable.CreateHandle;
begin
  Result := hCursor;
end;

{
  This function is cut-and-pasted from the VCL source code. I had to do
  this because it is declared private in the TTable component so I had no
  access to it from here.
}

procedure TInMemoryTable.EncodeFieldDesc(var FieldDesc: FLDDesc;
  const Name: string; DataType: TFieldType; Size: Word);
const
  TypeMap: array[TFieldType] of Byte = (fldUNKNOWN, fldZSTRING, fldINT16,
    fldINT32, fldUINT16, fldBOOL,
    fldFLOAT, fldFLOAT, fldBCD, fldDATE, fldTIME, fldTIMESTAMP, fldBYTES,
    fldVARBYTES, fldBLOB, fldBLOB, fldBLOB);
begin
  with FieldDesc do
  begin
    AnsiToNative(Locale, Name, szName, SizeOf(szName) - 1);
    iFldType := TypeMap[DataType];
    case DataType of
      ftString, ftBytes, ftVarBytes, ftBlob, ftMemo, ftGraphic:
        iUnits1 := Size;
      ftBCD:
        begin
          iUnits1 := 32;
          iUnits2 := Size;
        end;
    end;
    case DataType of
      ftCurrency:
        iSubType := fldstMONEY;
      ftBlob:
        iSubType := fldstBINARY;
      ftMemo:
        iSubType := fldstMEMO;
      ftGraphic:
        iSubType := fldstGRAPHIC;
    end;
  end;
end;

{
  This is where all the fun happens. I copied this function from the VCL
  source and then changed it to use DbiCreateInMemoryTable instead of
  DbiCreateTable.

  Since InMemory tables do not support Indexes - I took all of the
  index-related things out
}

procedure TInMemoryTable.CreateTable;
var
  I: Integer;
  pFieldDesc: pFLDDesc;
  szTblName: DBITBLNAME;
  iFields: Word;
  Dogs: pfldDesc;
begin
  CheckInactive;
  if FieldDefs.Count = 0 then
    for I := 0 to FieldCount - 1 do
      with Fields[I] do
        if not Calculated then
          FieldDefs.Add(FieldName, DataType, Size, Required);
  pFieldDesc := nil;
  SetDBFlag(dbfTable, True);
  try
    AnsiToNative(Locale, TableName, szTblName, SizeOf(szTblName) - 1);
    iFields := FieldDefs.Count;
    pFieldDesc := AllocMem(iFields * SizeOf(FLDDesc));
    for I := 0 to FieldDefs.Count - 1 do
      with FieldDefs[I] do
      begin
        EncodeFieldDesc(PFieldDescList(pFieldDesc)^[I], Name,
          DataType, Size);
      end;
    { the driver type is nil = logical fields }
    Check(DbiTranslateRecordStructure(nil, iFields, pFieldDesc,
      nil, nil, pFieldDesc));
    { here we go - this is where hCursor gets its value }
    Check(DbiCreateInMemTable(DBHandle, szTblName, iFields, pFieldDesc, hCursor));
  finally
    if pFieldDesc <> nil then FreeMem(pFieldDesc, iFields * SizeOf(FLDDesc));
    SetDBFlag(dbfTable, False);
  end;
end;

end.

--------------------
جابجایی ستونهای یه dbgrid

type
  THackAccess = class(TCustomGrid);

{
  THackAccess Is needed because TCustomGrid.MoveColumn is
  protected and you can't access it directly.

  THackAccess Braucht man, da TCustomGrid.MoveColumn in der
  Protected-Sektion steht und nicht direkt darauf zugegriffen werden kann.
}

// In the implementation-Section:

procedure MoveDBGridColumns(DBGrid: TDBGrid; FromColumn, ToColumn: Integer);
begin
  THackAccess(DBGrid).MoveColumn(FromColumn, ToColumn);
end;


{Example/ Beispiel}

procedure TForm1.Button1Click(Sender: TObject);
begin
  MoveDBGridColumns(DBGrid1, 1, 2)
end;

--------------------
شماره گذاری سطرهای dbgrid

...add a Row Number in your DBGrid? 
{+++++++++++++++++++++++++++++++++++++++++++++++++  ++++++++++++++++++++
  1. create new blank field in dbgrid
  2. rename the title with 'No'
  3. put this code in OnDrawColumncell
  4. Now your Grid has a row number
++++++++++++++++++++++++++++++++++++++++++++++++++  +++++++++++++++++++}

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;
  DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
  if DataSource1.DataSet.RecNo > 0 then
  begin
    if Column.Title.Caption = 'No' then
      DBGrid1.Canvas.TextOut(Rect.Left + 2, Rect.Top, IntToStr(DataSource1.DataSet.RecNo));
  end;
end;

----------


## maisam57

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

----------


## maisam57

چند تا avi باحال

----------


## maisam57

یه سورس xml برای دوستانی که میخوان دیکشنری بنویسن

----------


## maisam57

نرم افزار برا کشیدن ایکن و عکس از دل dll و exe

----------


## maisam57

چند تا آیکون ناقابل

----------


## maisam57

اینم چند تاآیکون xp

----------


## maisam57

چند تا bmp باحال برای bitbtn

----------


## maisam57

چند تا bmp مخصوص bitbtn با اندازه های مختلف از نوع ویستا

----------


## maisam57

اینم چند تا دیگه مجبور شدم تو دو قسمت باشه

----------


## maisam57

چند تا آیکون ویستا خیلی خیلی باحال

----------


## maisam57

چند تا دیگه آیکون ویستا با سایز مختلف

----------


## maisam57

یه کامپوننت باحال برا compress کردن

----------


## maisam57

یه application با حال برای دوستانی که میخوان برنامه نویسی رو زیبا انجام بدن
فایل mdf رو براتون گزاشتم اول restore کنید
بعد با 
user=کاربر
password=123
برنامه رو اجرا کنید

----------


## maisam57

نحوه ایجاد منوی install با کد تازه unistall هم انجام میده

----------


## maisam57

سورس ایجاد fade

----------


## maisam57

یه پروژه برای دوستانی که میخوان کار با resource رو یاد بگیرن

----------


## maisam57

ایجاد فرم نمایش properties چندین فایل

uses ActiveX, ShlObj, ComObj;

function SHMultiFileProperties(pDataObj: IDataObject; Flag: DWORD): HRESULT;
  stdcall; external 'shell32.dll';

function GetFileListDataObject(Files: TStrings): IDataObject;
type
  PArrayOfPItemIDList = ^TArrayOfPItemIDList;
  TArrayOfPItemIDList = array[0..0] of PItemIDList;
var
  Malloc: IMalloc;
  Root: IShellFolder;
  p: PArrayOfPItemIDList;
  chEaten, dwAttributes: ULONG;
  i, FileCount: Integer;
begin
  Result := nil;
  FileCount := Files.Count;
  if FileCount = 0 then Exit;

  OleCheck(SHGetMalloc(Malloc));
  OleCheck(SHGetDesktopFolder(Root));
  p := AllocMem(SizeOf(PItemIDList) * FileCount);
  try
    for i := 0 to FileCount - 1 do
      try
        if not (DirectoryExists(Files[i]) or FileExists(Files[i])) then Continue;
        OleCheck(Root.ParseDisplayName(GetActiveWindow,
          nil,
          PWideChar(WideString(Files[i])),
          chEaten,
          p^[i],
          dwAttributes));
      except
      end;
    OleCheck(Root.GetUIObjectOf(GetActiveWindow,
      FileCount,
      p^[0],
      IDataObject,
      nil,
      Pointer(Result)));
  finally
    for i := 0 to FileCount - 1 do
    begin
      if p^[i] <> nil then Malloc.Free(p^[i]);
    end;
    FreeMem(p);
  end;
end;

procedure ShowFileProperties(Files: TStrings; aWnd: HWND);
type
  PArrayOfPItemIDList = ^TArrayOfPItemIDList;
  TArrayOfPItemIDList = array[0..0] of PItemIDList;
var
  Data: IDataObject;
begin
  if Files.Count = 0 then Exit;
  Data := GetFileListDataObject(Files);
  SHMultiFileProperties(Data, 0);
end;


// Example:
// Beispiel:

procedure TForm1.Button1Click(Sender: TObject);
begin
  if OpenDialog1.Execute then
    Memo1.Lines.AddStrings(OpenDialog1.Files);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  ShowFileProperties(Memo1.Lines, 0);
end;

--------------------
چک کردن اینکه پوشه خالی است یا نه

function DirectoryIsEmpty(Directory: string): Boolean;
var
  SR: TSearchRec;
  i: Integer;
begin
  Result := False;
  FindFirst(IncludeTrailingPathDelimiter(Directory) + '*', faAnyFile, SR);
  for i := 1 to 2 do
    if (SR.Name = '.') or (SR.Name = '..') then
      Result := FindNext(SR) <> 0;
  FindClose(SR);
end;


// Beispiel:
// Example:

procedure TForm1.Button1Click(Sender: TObject);
begin
  if DirectoryIsEmpty('C:\test') then
    Label1.Caption := 'empty'
  else
    Label1.Caption := 'not empty';
end;

--------------------
خوندن فایلهای pdf

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    OpenDialog1: TOpenDialog;
    GroupBox1: TGroupBox;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    procedure Button1Click(Sender: TObject);
  private
    { Private-Deklarationen }
  public
    { Public-Deklarationen }
  end;


var
  Form1: TForm1;

implementation

uses ComObj;

{$R *.dfm}
{$TYPEDADDRESS OFF} //muss so sein (this have to be)
var
  PDDoc: Acrobat_TLB.CAcroPDDoc;
  PDPage: Variant;
  PDHili: Variant;
  PDTextS: Variant;
  acrobat: Variant;
  Result: Boolean;
  NTL, i, j, Pagecount: Integer;
  zeilen: string;
  stichwortcounter: Integer;
  Size: Integer;
  gesamtstring: AnsiString;
  zwreal: Real;

procedure TForm1.Button1Click(Sender: TObject);
  function removecrlf(workstring: string): string;
  var 
    i: Integer;
  begin
    removecrlf := '';
    for i := 0 to Length(workstring) do
    begin
      if workstring[i] = #13 then
        workstring[i] := ' ';
      if workstring[i] = #10 then
        workstring[i] := ' ';
    end;

    removecrlf := workstring;
  end;
begin
  if not opendialog1.Execute then Exit;

  memo1.Clear;

  gesamtstring := '';
  stichwortcounter := 0;
  Size := 0;
  try

    //Object erstellen
    acrobat := CreateOleObject('AcroExch.pdDoc');

    //PDF Datei in Object &ouml;ffnen
    Result := acrobat.Open(opendialog1.FileName);


    if Result = False then
    begin
      messagedlg('Kann Datei nicht &ouml;ffnen', mtWarning, [mbOK], 0);
      Exit;
    end;

    for j := 0 to acrobat.GetNumPages - 1 do
    begin
      memo1.Lines.Add('----------------------------------------------');
      //Erste Seite des Dokuments aktiv setzen  (first page)
      PDPage := acrobat.acquirePage(j);

      //Ein Highlight Object mit 2000 Elementen erzeugen
      PDHili := CreateOleObject('AcroExch.HiliteList');
      Result := PDHili.Add(0, 4096);

      //Erzeuge eine Markierung über den ganzen Text
      PDTextS := PDPage.CreatePageHilite(PDHili);

      ntl := PDTextS.GetNumText;

      for i := 0 to ntl - 1 do
      begin
        zeilen := PDTextS.GetText(i);
        if (Length(zeilen) > 0) and (zeilen <> '') then
          memo1.Lines.Add(removecrlf(zeilen));
        gesamtstring := gesamtstring + removecrlf(zeilen);
        //nur für statistik
        Size := Size + SizeOf(zeilen);
        Inc(stichwortcounter);

        Application.ProcessMessages;
      end;

      //Wieder freigeben
      pdhili         := Unassigned;
      pdtextS        := Unassigned;
      pdpage         := Unassigned;
      label2.Caption := IntToStr(stichwortcounter);
      label4.Caption := IntToStr(Size);
      label2.Refresh;
      label4.Refresh;
    end; //for i to pagecount


  except 
    on e: Exception do
    begin
      messagedlg('Fehler: ' + e.Message, mtError, [mbOK], 0);
      Exit;
    end;
  end;
  if Size > 1024 then
  begin
    zwreal := Size / 1024;
    str(zwreal: 2: 1,zeilen);
    label4.Caption := zeilen;
    label5.Caption := 'KB';
  end;
  memo1.Lines.SaveToFile(Extractfilepath(Application  .exename) + '\debug.txt');
end;

end.

----------


## maisam57

drag and drop فایل از application به explorer

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs,
  StdCtrls, FileCtrl, ActiveX, ShlObj, ComObj;

type
  TForm1 = class(TForm, IDropSource)
    FileListBox1: TFileListBox;
    DirectoryListBox1: TDirectoryListBox;
    procedure FileListBox1MouseDown(Sender: TObject; Button:
      TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FileListBox1MouseMove(Sender: TObject; Shift: TShiftState;
      X,
      Y: Integer);
  private
    FDragStartPos: TPoint;
    function QueryContinueDrag(fEscapePressed: BOOL;
      grfKeyState: Longint): HResult; stdcall;
    function GiveFeedback(dwEffect: Longint): HResult; stdcall;
  public
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

function GetFileListDataObject(const Directory: string; Files:
  TStrings):
  IDataObject;
type
  PArrayOfPItemIDList = ^TArrayOfPItemIDList;
  TArrayOfPItemIDList = array[0..0] of PItemIDList;
var
  Malloc: IMalloc;
  Root: IShellFolder;
  FolderPidl: PItemIDList;
  Folder: IShellFolder;
  p: PArrayOfPItemIDList;
  chEaten: ULONG;
  dwAttributes: ULONG;
  FileCount: Integer;
  i: Integer;
begin
  Result := nil;
  if Files.Count = 0 then
    Exit;
  OleCheck(SHGetMalloc(Malloc));
  OleCheck(SHGetDesktopFolder(Root));
  OleCheck(Root.ParseDisplayName(0, nil,
    PWideChar(WideString(Directory)),
    chEaten, FolderPidl, dwAttributes));
  try
    OleCheck(Root.BindToObject(FolderPidl, nil, IShellFolder,
      Pointer(Folder)));
    FileCount := Files.Count;
    p := AllocMem(SizeOf(PItemIDList) * FileCount);
    try
      for i := 0 to FileCount - 1 do
      begin
        OleCheck(Folder.ParseDisplayName(0, nil,
          PWideChar(WideString(Files[i])), chEaten, p^[i],
          dwAttributes));
      end;
      OleCheck(Folder.GetUIObjectOf(0, FileCount, p^[0], IDataObject,
        nil,
        Pointer(Result)));
    finally
      for i := 0 to FileCount - 1 do begin
        if p^[i] <> nil then Malloc.Free(p^[i]);
      end;
      FreeMem(p);
    end;
  finally
    Malloc.Free(FolderPidl);
  end;
end;

function TForm1.QueryContinueDrag(fEscapePressed: BOOL;
  grfKeyState: Longint): HResult; stdcall;
begin
  if fEscapePressed or (grfKeyState and MK_RBUTTON = MK_RBUTTON) then
  begin
    Result := DRAGDROP_S_CANCEL
  end else if grfKeyState and MK_LBUTTON = 0 then
  begin
    Result := DRAGDROP_S_DROP
  end else
  begin
    Result := S_OK;
  end;
end;

function TForm1.GiveFeedback(dwEffect: Longint): HResult; stdcall;
begin
  Result := DRAGDROP_S_USEDEFAULTCURSORS;
end;

procedure TForm1.FileListBox1MouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbLeft then
  begin
    FDragStartPos.x := X;
    FDragStartPos.y := Y;
  end;
end;

procedure TForm1.FileListBox1MouseMove(Sender: TObject; Shift:
  TShiftState;
  X, Y: Integer);
const
  Threshold = 5;
var
  SelFileList: TStrings;
  i: Integer;
  DataObject: IDataObject;
  Effect: DWORD;
begin
  with Sender as TFileListBox do
  begin
    if (SelCount > 0) and (csLButtonDown in ControlState)
      and ((Abs(X - FDragStartPos.x) >= Threshold)
      or (Abs(Y - FDragStartPos.y) >= Threshold)) then
      begin
      Perform(WM_LBUTTONUP, 0, MakeLong(X, Y));
      SelFileList := TStringList.Create;
      try
        SelFileList.Capacity := SelCount;
        for i := 0 to Items.Count - 1 do
          if Selected[i] then SelFileList.Add(Items[i]);
        DataObject := GetFileListDataObject(Directory, SelFileList);
      finally
        SelFileList.Free;
      end;
      Effect := DROPEFFECT_NONE;
      DoDragDrop(DataObject, Self, DROPEFFECT_COPY, Effect);
    end;
  end;
end;

initialization
  OleInitialize(nil);
finalization
  OleUninitialize;
end.

--------------------
تبدیل تاریخ و ساعت داس

procedure TForm1.Button1Click(Sender: TObject);
var
  OutFile: file;
  OutFileName: string;
  FileDateTime: TDateTime;
begin
  //File which date & time stamp are to change...
  OutFileName := 'c:\Test.txt';
  AssignFile(OutFile, OutFileName);
  Reset(OutFile);
  //Get file's current date & time stamp...
  FileDateTime := FileDateToDateTime(FileAge(OutFileName));
  //Set file's date one day ahead!
  FileSetDate(TFileRec(OutFile).Handle, DateTimeToFileDate(FileDateTime + 1));
end;

--------------------
پروژه تعین اینکه یک فایل txt یا bin است

function IsTextFile(const sFile: TFileName): boolean;
//Created By Marcelo Castro - from Brazil

var
 oIn: TFileStream;
 iRead: Integer;
 iMaxRead: Integer;
 iData: Byte;
 dummy:string;
begin
 result:=true;
 dummy :='';
 oIn := TFileStream.Create(sFile, fmOpenRead or fmShareDenyNone);
 try
   iMaxRead := 1000;  //only text the first 1000 bytes
   if iMaxRead > oIn.Size then
     iMaxRead := oIn.Size;
   for iRead := 1 to iMaxRead do
   begin
     oIn.Read(iData, 1);
     if (idata) > 127 then result:=false;
   end;
 finally
   FreeAndNil(oIn);
 end;
end;

(* ----- Sample call ----- *)

procedure TForm1.Button1Click(Sender: TObject);
begin
  if OpenDialog1.Execute then
  begin
  if IsTextFile(OpenDialog1.FileName) then
  showmessage('is ascii')
  else showmessage('is BinaryFile')
  end;

end;

----------


## maisam57

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

procedure ListFileDir(Path: string; FileList: TStrings);
var
  SR: TSearchRec;
begin
  if FindFirst(Path + '*.*', faAnyFile, SR) = 0 then
  begin
    repeat
      if (SR.Attr <> faDirectory) then
      begin
        FileList.Add(SR.Name);
      end;
    until FindNext(SR) <> 0;
    FindClose(SR);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ListFileDir('C:\WINDOWS\', ListBox1.Items);
end;

--------------------
تعیین اندازه فایلهای png و gif و jpg

unit ImgSize;

interface

uses Classes;


procedure GetJPGSize(const sFile: string; var wWidth, wHeight: Word);
procedure GetPNGSize(const sFile: string; var wWidth, wHeight: Word);
procedure GetGIFSize(const sGIFFile: string; var wWidth, wHeight: Word);


implementation

uses SysUtils;

function ReadMWord(f: TFileStream): Word;
type
  TMotorolaWord = record
    case Byte of
      0: (Value: Word);
      1: (Byte1, Byte2: Byte);
  end;
var
  MW: TMotorolaWord;
begin
  { It would probably be better to just read these two bytes in normally }
  { and then do a small ASM routine to swap them.  But we aren't talking }
  { about reading entire files, so I doubt the performance gain would be }
  { worth the trouble. }
  f.read(MW.Byte2, SizeOf(Byte));
  f.read(MW.Byte1, SizeOf(Byte));
  Result := MW.Value;
end;

procedure GetJPGSize(const sFile: string; var wWidth, wHeight: Word);
const
  ValidSig: array[0..1] of Byte = ($FF, $D8);
  Parameterless = [$01, $D0, $D1, $D2, $D3, $D4, $D5, $D6, $D7];
var
  Sig: array[0..1] of byte;
  f: TFileStream;
  x: integer;
  Seg: byte;
  Dummy: array[0..15] of byte;
  Len: word;
  ReadLen: LongInt;
begin
  FillChar(Sig, SizeOf(Sig), #0);
  f := TFileStream.Create(sFile, fmOpenRead);
  try
    ReadLen := f.read(Sig[0], SizeOf(Sig));

    for x := Low(Sig) to High(Sig) do
      if Sig[x] <> ValidSig[x] then ReadLen := 0;

    if ReadLen > 0 then
    begin
      ReadLen := f.read(Seg, 1);
      while (Seg = $FF) and (ReadLen > 0) do
      begin
        ReadLen := f.read(Seg, 1);
        if Seg <> $FF then
        begin
          if (Seg = $C0) or (Seg = $C1) then
          begin
            ReadLen := f.read(Dummy[0], 3); { don't need these bytes }
            wHeight := ReadMWord(f);
            wWidth  := ReadMWord(f);
          end 
          else 
          begin
            if not (Seg in Parameterless) then
            begin
              Len := ReadMWord(f);
              f.Seek(Len - 2, 1);
              f.read(Seg, 1);
            end 
            else
              Seg := $FF; { Fake it to keep looping. }
          end;
        end;
      end;
    end;
  finally
    f.Free;
  end;
end;

procedure GetPNGSize(const sFile: string; var wWidth, wHeight: Word);
type
  TPNGSig = array[0..7] of Byte;
const
  ValidSig: TPNGSig = (137,80,78,71,13,10,26,10);
var
  Sig: TPNGSig;
  f: tFileStream;
  x: integer;
begin
  FillChar(Sig, SizeOf(Sig), #0);
  f := TFileStream.Create(sFile, fmOpenRead);
  try
    f.read(Sig[0], SizeOf(Sig));
    for x := Low(Sig) to High(Sig) do
      if Sig[x] <> ValidSig[x] then Exit;
    f.Seek(18, 0);
    wWidth := ReadMWord(f);
    f.Seek(22, 0);
    wHeight := ReadMWord(f);
  finally
    f.Free;
  end;
end;


procedure GetGIFSize(const sGIFFile: string; var wWidth, wHeight: Word);
type
  TGIFHeader = record
    Sig: array[0..5] of char;
    ScreenWidth, ScreenHeight: Word;
    Flags, Background, Aspect: Byte;
  end;

  TGIFImageBlock = record
    Left, Top, Width, Height: Word;
    Flags: Byte;
  end;
var
  f: file;
  Header: TGifHeader;
  ImageBlock: TGifImageBlock;
  nResult: integer;
  x: integer;
  c: char;
  DimensionsFound: boolean;
begin
  wWidth  := 0;
  wHeight := 0;

  if sGifFile = '' then
    Exit;

  {$I-}
  FileMode := 0;   { read-only }
  AssignFile(f, sGifFile);
  reset(f, 1);
  if IOResult <> 0 then
    { Could not open file }
    Exit;

  { Read header and ensure valid file. }
  BlockRead(f, Header, SizeOf(TGifHeader), nResult);
  if (nResult <> SizeOf(TGifHeader)) or (IOResult <> 0) or
    (StrLComp('GIF', Header.Sig, 3) <> 0) then
  begin
    { Image file invalid }
    Close(f);
    Exit;
  end;

  { Skip color map, if there is one }
  if (Header.Flags and $80) > 0 then
  begin
    x := 3 * (1 shl ((Header.Flags and 7) + 1));
    Seek(f, x);
    if IOResult <> 0 then
    begin
      { Color map thrashed }
      Close(f);
      Exit;
    end;
  end;

  DimensionsFound := False;
  FillChar(ImageBlock, SizeOf(TGIFImageBlock), #0);
  { Step through blocks. }
  BlockRead(f, c, 1, nResult);
  while (not EOF(f)) and (not DimensionsFound) do
  begin
    case c of
      ',': { Found image }
        begin
          BlockRead(f, ImageBlock, SizeOf(TGIFImageBlock), nResult);
          if nResult <> SizeOf(TGIFImageBlock) then 
          begin
            { Invalid image block encountered }
            Close(f);
            Exit;
          end;
          wWidth := ImageBlock.Width;
          wHeight := ImageBlock.Height;
          DimensionsFound := True;
        end;
      '&yuml;': { Skip }
        begin
          { NOP }
        end;
      { nothing else.  just ignore }
    end;
    BlockRead(f, c, 1, nResult);
  end;
  Close(f);
  {$I+}
end;

end.

----------


## maisam57

نصب کامپوننت

uses ToolsApi;

{....}


var
  a, i: Integer;
begin
  with (BorlandIDEServices as IOTAPackageServices) do
  begin
    for a := 0 to GetPackageCount - 1 do
    begin
      for i := 0 to GetComponentCount(a) - 1 do
      begin
        {get each component name with GetComponentName(a, i);}
      end;
    end;
  end;
end;

--------------------
ایجاد maimenu

uses ToolsApi, Menus;

{....}

var
  item: TMenuItem;
begin
  {get reference to delphi's mainmenu. You can handle it like a common TMainMenu}
  with (BorlandIDEServices as INTAServices).GetMainMenu do
  begin
    item := TMenuItem.Create(nil);
    item.Caption := 'A Mewn caption';
    Items.Add(item);
  end;
end;

----------


## babak869

> یه application با حال برای دوستانی که میخوان برنامه نویسی رو زیبا انجام بدن
> فایل mdf رو براتون گزاشتم اول restore کنید
> بعد با 
> user=کاربر
> password=123
> برنامه رو اجرا کنید


دوست عزیز :
دیتابیسهایی که بر مبنای SQL Server 2000  یا 2005  هستند شامل دو فایل هستند با پسوند های زیر :
1-  mdf. : فایل با این پسوند حاوی اطلاعات موجود در دیتابیس است و مخفف عبارت زیر است :
Main Database File
2- ldf. : فایل با این پسوند شامل گزارشات و اتفاقاتی است که هنگام کار با فایل اصلی رخ داده و در این فایل ذخیره میشود و مخفف عبارت زیر است :
Log Database File

حالا شما برای اینکه یه دیتابیس  SQL Server  رو به جایی منتقل کنی یا اونو مثل اینجا در سایت آپلود کنی حتما باید هر دو فایل رو ضمیمه کنی وگرنه برنامه شما قابل اجرا نخواهد بود. !
موفق باشید

----------


## maisam57

دوست عزیز من backup رو براتون گذاشتم به اسم bimeh و اینکارو کردم که وقتی که شما restore میکنی به اسم بیمه restore کنی

----------


## tabassom_saadat

بینهایت از مطالب شما سپاسگذارم .امیدوارم باز از این کارها بکنید تا دیگران استفاده کنند و دعاتون کنند

----------


## ali_abbasi22145

سلام
انتخاب همه رکوردها در dbgrid

کد:
function GridSelectAll(Grid: TDBGrid): Longint;
begin
  Result := 0;
  Grid.SelectedRows.Clear;
  with Grid.DataSource.DataSet do
  begin
    First;
    DisableControls;
    try
      while not EOF do
      begin
        Grid.SelectedRows.CurrentRowSelected := True;
        Inc(Result);
        Next;
      end;
    finally
      EnableControls;
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  GridSelectAll(DBGrid1);
end;
سلام
من متاسفانه  نتوانستم تابع را در public تعریف کنم که هر وقت صدا زدم کار خود را انجام دهد.
و این error هنگام صدازدن تابع در هنگام استفاد را نشان می دهد:

[Error] Unit1.pas(1271): Undeclared identifier: 'GridSelectAll'

----------


## MNosouhi

> من متاسفانه نتوانستم تابع را در public تعریف کنم که هر وقت صدا زدم کار خود را انجام دهد.
> و این error هنگام صدازدن تابع در هنگام استفاد را نشان می دهد:
> 
> [Error] Unit1.pas(1271): Undeclared identifier: 'GridSelectAll'


دوست عزیز این یک مطلب آموزشی است یا سوال؟

----------


## ali_abbasi22145

> دوست عزیز این یک مطلب آموزشی است یا سوال؟


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

----------


## MNosouhi

> من متاسفانه نتوانستم تابع را در public تعریف کنم که هر وقت صدا زدم کار خود را انجام دهد.


من که گذاشتم و هیچ مشکلی هم نداشت . براتون آپلود کردم تا ببینید کجای کار اشتباه می کرده اید.

----------


## ali_abbasi22145

سلام
مرسی تست می کنم.

----------


## ali_abbasi22145

سلام
متشکرم مشکلم حل شد رفیق.

----------


## maisam57

افکت fade همراه با نمایش صحیح splahfrom

----------

