هدیه به دوستان برنامه نویس

[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