سورسهاي نمونه آموزشي

[Mahmood_M]

با سلام ...
در اين تاپيك مي تونيد سورسهاي كوچكي كه براي اهداف آموزشي خاصي ايجاد كرديد رو قرار بديد ، مثلا سورسي براي آموزش نحوه استفاده از توابع API يا نحوه ارسال پيام در شبكه و ...

اصلا تمايلي به تذكر دادن ندارم ! اما براي حفظ نظم و جلوگيري از انحراف تاپيك از هدف اصليش ،‌ مجبورم چند نكته رو يادآور بشم ...

لطفا موارد زير رو هنگام قرار دادن پست در نظر بگيريد :

1 . براي سورس معرفي شده توضيح مناسبي قرار بديد
2 . حتي الامكان از قرار دادن سورسهاي تكراري خودداري كنيد
3 . لطفا ذكر كنيد كه سورس معرفي شده با چه نسخه اي از دلفي نوشته شده
4 . حتي الامكان سعي كنيد براي قرار دادن سورس از امكان ضميمه ي سايت استفاده كنيد تا لينكها براي مدتهاي طولاني سالم باقي بمونه

نكته ي مهم : سورسها رو بدون فايل اجرايي كامپايل شده قرار بديد تا مشكلاتي مانند انتقال ويروس !! و ... براي ساير كاربران پيش نياد ...

لطفا سعي كنيد سئوالات خودتون رو در قسمتهاي مربوطه ي بخش دلفي بپرسيد و اين تاپيك تنها محلي باشه براي قرار دادن سورسها و مثالهاي نمونه ...

پستهاي مربوط به سئوال و يا درخواست سورس حذف خواهند شد ... !

نكته ي آخر : اگر نرم افزاري در گذشته ساختيد و قصد ارائه ي سورس اون رو در بخش دلفي داريد ، لطفا براي نرم افزارتون با توجه به نوع عملكرد و كارايي برنامه در يك بخش مناسب از تالار دلفي تاپيكي ايجاد كنيد و نرم افزارتون رو معرفي كنيد و اون رو در اين تاپيك قرار نديد ... ، به زودي اعلاني براي ليست نرم افزارهاي ارائه شده توسط كاربران هم در اين بخش ايجاد خواهد شد ...

اميدوارم اين تاپيك با همكاري شما دوستان عزيز محلي مناسب براي اشتراك اطلاعات بشه ...

موفق باشيد ...

[Mahmood_M]

در اين سورس با نحوه ي استفاده از چند دستور API مانند FindWindow و ShellExecute و SendMessage و يا ShowWindow آشنا خواهيد شد ...
اين سورس در دلفي 7 كامپايل شده و انتظار ميره بدون مشكل در ساير نسخه هاي دلفي هم اجرا بشه !

موفق باشيد ...

[Mahmood_M]

در اين سورس با نحوه ي ذخيره سازي و نمايش تصاوير JPG و همچنين ذخيره و بازيابي فايل در بانك اطلاعاتي آشنا خواهيد شد ...
در اين سورس از بانك اكسس و كامپوننت ADOTable استفاده شده ...
اين سورس در دلفي 7 كامپايل شده ( البته در نسخه هاي بالاتر هم احتمالا مشكلي نخواهد داشت ! )

اين برنامه كمي قديميه ، 2 تا فايل به عنوان نمونه درش قرار دادم كه متاسفانه الآن نمي دونم چه نوع فايلي بودن ... !!

موفق باشيد ...

[Mahmood_M]

در اين سورس ياد مي گيريد كه چطور چند فايل رو به حافظه ي موقت Clipboard بفرستيد ...
اين برنامه در دلفي 7 و دلفي 2010 بدون مشكل كامپايل شده ...

موفق باشيد ...

[daffy_duck376]

با اجازه دوستمون Mahmood_N (http://barnamenevis.org/forum/member.php?u=16833) من یه روز دنبال برنامه ای برای گرفتن لیست sql server های روی شبکه بودم که توی سایت انگلیسی به سورس جالبی برخوردم . میگذارمش اینجا شاید گره از کار کسی باز کنه


این برنامه با دلفی 7 کامپایل و تست شده .
فایل html همراه سورس مربوط به همون سایت است که توضیحات لازم رو داده و نیازی به توضیح بیشتر نیست.

[Mahmood_M]

در اين سورس با نحوه ي تغيير Resolution نمايشگر آشنا خواهيد شد ...
اين سورس در دلفي 7 و دلفي 2010 بدون مشكل كامپايل شده ...

موفق باشيد ...

[Jozef]

برای اینکه بفهمین یک درایو Ntfs هست یا Fat از این function استفاده کنین.

[Jozef]

به دست اوردن تمام درایوهای DVD , CD

[Jozef]

تغییر Hint برای هر ستون از DBGrid در دلفی

[Jozef]

نصب ProgressBar روی StatusBar در دلفی

[Jozef]

با کد زیر میشه از داخل برنامه بدون هیچ واسطه ای به اینترنت وصل شد.البته کانکشن باید از قبل ساخته شده باشه.

[Jozef]

کد زیر نحوه تغییر رنگ پس زمینه سطرهای مختلف متن در TListBox را نشان میدهد.

[Jozef]

کد زیر نحوه تغییر رنگ در TProgressBar را نشان میدهد.

[Jozef]

کد زیر نحوه تکمیل، متن ناتمام تایپ شده در TComboBox را نشان میدهد.
در واقع عملکرد خاصیت AutoComplate در ComboBox را نشون میده.

[Jozef]

کد زیر نحوه قرار دادن RadioButton در TListBox را نشان میدهد.

[AliReza Vafakhah]

نسخه جدید کامپوننت Animation Caption در این تاپیک (http://barnamenevis.org/forum/showthread.php?p=934518#post934518)

[alidehban]

تغییر مشخصات OEM سیستمتون رو میتونید با این کد انجام بدید....

http://www.lon.ir/up/uploads/1269309324.rar


البته دوستان همه استادن ولی میگم شاید کسی باشه که متوجه نباشه کد چیکار میکنه...
از MYCOMPUTER که Properties میگیریم اگه به فرض لپ تاپتون سونی باشه آرم سونی رو که بصورت یه فایل BMP هست گوشه ی پنجره میبینیم که جزو مشخصات سازنده دستگاهه که به سفارششون مایکروسافت آرمشونو رو ویندوز میزنه....
با این کد میتونید کلا این مشخصاتو بنام شرکت خودتون یا هر اسمی تغییر بدید و قانون کپی رایت واین حرفارو براحتی زیر پا له کنین...!!!:قهقهه:
البته اینجا فقط جنبه آموزشی داره :لبخند:...

[__Genius__]

سلام .
سایت Madshi.net حاوی کتابخانه های بسیار قدرتمند در رابطه کار با API های ویندوز هست.
یکی از unit های اون madshell هست که اجازه گرفتن اطلاعات در مورد سیستم رو به شما میده.
برای راحتی کار من برنامه ای رو نوشتم تا با قسمتی از این unit آشنا بشید ،
کلیه اطلاعات در مورد فولدرهای خاص شما با این برنامه قابل دیدن هست .
حاوی سورس کد آموزشی .
برای استفاده حتماً باید Library ها رو داشته باشید ، میتونید از سایت madshi.net اونها رو دانلود کنید .

http://madshi.net/

[Jozef]

تنظیم پهنای ستون های DBGrid به صورت خودکار

[Jozef]

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

[Jozef]

Mouse Eyes
کد زیر در دلفی 2007 تست شده. نسخه های پایین تر اجرا نمیشود. زحمت تست نسخه های بالاتر با خودتون.

[Jozef]

قرار دادن Horizontal Scrollبرای کامپوننت TListBox

[Jozef]

انتخاب آیتم های ListBox زمانی که موس روی آنها قرار میگیرد

[Jozef]

جستجو برای کامپوننت ListBox در دلفی

[Jozef]

نحوه اجرای صدا در حین ورود موس به یک کامپوننت

[Jozef]

نحوه بدست آوردن جمع یه فیلد DBGrid در حالت Multi Select. در واقع مجموع انتخابها

[hamid-nic]

برنامه ی تشخیص صحت کد ملی افراد


http://barnamenevis.org/forum/attachment.php?attachmentid=46697&stc=1&d=1270671888

[lord_viper]

این سورس به نوعی یک mini peid هست که اطلاعات هدر فایلهای Exe رو بیرون میکشه(به جز Directory entry ها)
و علاوه بر اون یک Signature database داره که signature بیش از 4400 پکر و پروتکتور رو درونش گنجونده و میتونه اونها رو تشخیص بده

(البته به علت اینکه از توابع یونیت ini برای جستجو استفاده شده در جستجوی سکشن های هم نام کمی مشکل داره )

[مهران رسا]

برای نمایش روند کار TIdHTTP توسط ProgressBar از 2 رویداد OnWorkBegin و OnWork به صورت زیر استفاده کنید :



procedure TForm1.TIdHTTPWorkBegin(ASender: TObject; AWorkMode: TWorkMode;
AWorkCountMax: Int64);
begin
ProgressBar1.Max := AWorkCountMax;
ProgressBar1.Position := 0;
end;

procedure TForm1.TIdHTTPWork(ASender: TObject; AWorkMode: TWorkMode;
AWorkCount: Int64);
begin
ProgressBar1.Position := AWorkCount;
end;


حالا TIDHttp رو آتیش کنید :

Source := TIdHTTP.Get('http://www.barnamenevis.org');

[Felony]

:لبخندساده: سلام ،

امروز یه نمونه برنامه برای خودم نوشتم که به وسیله ی یک Thread جدا فایل ها یک مسیر و زیر پوشه هاش رو جست و جو میکنه ، بخش جست و جو رو تو یک یونیت جدا نوشتم تا در صورت نیاز دوستان به راحتی در برنامه های خودشون ازش استفاده کنن ، در مورد نحوه جست و جو هم این رو بگم که نتیجه جست و جو رو به 2 صورت میتونید از Thread دریافت کنید ، یکی یک متغییر از نوع TStringList که قبل از پاس دادن به Thread برای ساخته شدن ترد باید اون رو Create کرده باشید و در آخر پس از اتمام کار Thread میتونید لیست فایل ها رو داخلش داشته باشید و روش دوم که به صورت Realtime عمل میکنه هندل کردن پیغام هست ، متد Create کلاس TSearchThread رو طوری بازنویسی کردم که در زمان ساخت یک نمونه از این کلاس باید پارامترهای منجمله هندل فرم برنامتون رو بهش بدید ، با دادن هندل به Thread ، Thread در زمان جست و جو هر باری که فایل جدیدی پیدا کنه پیغامی با عنوان WM_UpdateList به هندل فرم اصلی برنامه ارسال میکنه که شما به راحتی میتونید این پیغام رو بررسی کنید و اسم و آدرس فایل پیدا شده رو از پارامتر WParam اون استخراج کنید ، برای فهمیدن اتمام کار Thread هم همین پیغام به فرم اصلی ارسال میشه ولی این بار پارامتر WParam حاوی متن FreeList هست که میتونید با دریافت این پیغام StringList ساخته شده رو آزاد کنید یا ...

نمونه برنامه ضمیمه تمام توضیحات بالا رو شامل میشه .

:چشمک:موفق باشید .

[Delphi7_love]

نمونه ای از رنگ کردن پس زمینه فرم :

54476

[MOJTABAATEFEH]

با کد زیر می توانید یک فایل اکسس موقع اجرا بسازید

با دلفی7 تست و کامپایل شده

[MOJTABAATEFEH]

با این کد می توانید تمام Event های یک کامپوننت رو بدست بیارید
به Sender نام کلاس کامپوننت مورد نظرتون رو بزارید

[Felony]

با این کد می توانید تمام Event های یک کامپوننت رو بدست بیارید
به Sender نام کلاس کامپوننت مورد نظرتون رو بزارید

این کد رو خودتون نوشتید یا از جایی پیدا کردید ؟
بعد از تخصیص حافظه با GetMem وظیفه آزاد کردن حافظه با شماست ولی تو کدی که گزاشتید این اتفاق نیافتاده ، در آخر کار باید فضای اختصاص داده شده به ListProp رو با تابع FreeMem آزاد کنید .

موفق باشید .

[Felony]

سلام ،
به وسیله این نمونه سورس میتونید Send و Receive اینترنت رو فعال یا غیر فعال کنید .

[MOJTABAATEFEH]

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

در دلفی 7 تست و کامپایل شده


موفق باشید

[MOJTABAATEFEH]

با نمونه برنامه زیر می تونید با ماوس اقدام به کشیدن فلش جهت دار کنید
در دلفی 7 تست و کامپایل شده


موفق باشید

[Felony]

در این نمونه برنامه نحوه ارتباط با Google Earth رو یاد میگیرید ، برنامه یک Edit داره که نام محل مورد نظرتون رو توش مینویسید و برنامه توی یک کنترل WebBrowser محل مورد نظر رو از روی Google Earth میخونه و نمایش میده .

نکته : برای کار کردن برنامه باید Google Desktop و Google Plugin نصب باشه که با یک جست و جوی ساده میتونید پیداشون کنید ، حجمشون هم خیلی کمه .

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

[MOJTABAATEFEH]

با نمونه زیر می تونید زمان اجرا اقدام به کشیدن شکل کنید

در دلفی 7 کامپایل و تست شده


موفق باشید

[MOJTABAATEFEH]

دوستان عزیز جاهای متعددی از سایت دیدم که عده زیادی راجع به این قضیه سوال کرده بودند که چطوری RichEdit رو با محتویاتش بریزند توی Image با این سورس می توان این کار را انجام داد

کامپایل و تست : Delphi 7


موفق باشید

[delphi_programmer_2010]

دانلود کنید
58996

[lord_viper]

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

[مصطفی ساتکی]

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

unit Unit1;

interface

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

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

var
Form1: TForm1;

implementation

uses Math, Types;

{$R *.dfm}


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

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

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

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

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

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




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

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

if Length(Pnts)=3 then
begin
end;

end;

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

end;

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

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

end;

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

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

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

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

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


end;

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

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

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

end;

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

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

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

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

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

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

end;

end.

[delphi_programmer_2010]

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


60321

[BORHAN TEC]

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

[Felony]

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

function IsTextFile(const sFileName: string): Boolean;

[Felony]

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

[BORHAN TEC]

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

uses ActiveX, OleAuto;

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

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

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

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

[BORHAN TEC]

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

unit common;

interface

uses dialogs, sysutils;

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

implementation

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

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

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

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

end.

[Felony]

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

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

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

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

[lord_viper]

undocument messagebox
این تابع از توابع استاندارد ویندوز درون User32.dll هست که یک messagebox با قابلیت زماندهی برای بسته شدن میباشد



function MessageBoxTimeOut(
hWnd: HWND; lpText: PChar; lpCaption: PChar;
uType: UINT; wLanguageId: WORD; dwMilliseconds: DWORD): Integer; stdcall;
function MessageBoxTimeOutA(
hWnd: HWND; lpText: PChar; lpCaption: PChar;
uType: UINT; wLanguageId: WORD; dwMilliseconds: DWORD): Integer; stdcall;

function MessageBoxTimeOutW(
hWnd: HWND; lpText: PWideChar; lpCaption: PWideChar;
uType: UINT; wLanguageId: WORD; dwMilliseconds: DWORD): Integer; stdcall;

implementation

// this const is not defined in Windows.pas
const
MB_TIMEDOUT = 32000;

function MessageBoxTimeOut; externaluser32 name 'MessageBoxTimeoutA';
function MessageBoxTimeOutA; external user32 name 'MessageBoxTimeoutA';
function MessageBoxTimeOutW; external user32 name 'MessageBoxTimeoutW';


نمونه مثال:



var
iResult: Integer;
iFlags: Integer;
begin
// Define a MessagBox with an OK button and a timeout of 2 seconds
iFlags := MB_OK or MB_SETFOREGROUND or MB_SYSTEMMODAL or MB_ICONINFORMATION;
iResult := MessageBoxTimeout(
Application.Handle,
'Test a timeout of 2 seconds.',
'MessageBoxTimeout Test', iFlags, 0, 2000);

// iResult will = 1 (IDOK)
ShowMessage(IntToStr(iRet));

// Define a MessageBox with a Yes and No button and a timeout of 5 seconds
iFlags := MB_YESNO or MB_SETFOREGROUND or MB_SYSTEMMODAL or MB_ICONINFORMATION;

iResult := MessageBoxTimeout(
Application.Handle,
'Test a timeout of 5 seconds.',
'MessageBoxTimeout Test', iFlags, 0, 5000);

// iResult = MB_TIMEDOUT if no buttons clicked, otherwise
// iResult will return the value of the button clicked

case iResult of
IDYES: // Pressed Yes button
ShowMessage('Yes');

IDNO: // Pressed the No button
ShowMessage('No');

MB_TIMEDOUT: // MessageBox timed out
ShowMessage('TimedOut');
end;
end;

[Felony]

سلام ،

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

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

[Mask]

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

[مهران رسا]

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

procedure TForm1.ExtractEmails(StrContent: string);
var
i, r, P1, P2, DContinue: integer;
Email, StrPre, StrPos: string;
begin
StrContent := StringReplace(StrContent, #13#10, ' ', [rfReplaceAll]);
StrContent := StrContent + #13#10;
i := 1;
ListBox1.Items.Clear;
while (i <= length(StrContent)) do
begin
r := PosEx('@', StrContent, i);
if r > 0 then
begin
StrPre := copy(StrContent, 1, r - 1);
P1 := r + 1;
StrPos := copy(StrContent, P1, length(StrContent));
P2 := pos(' ', StrPos) - 1;
//
StrPre := ReverseString(StrPre);
StrPre := ReverseString(copy(StrPre, 1, pos(' ', StrPre) - 1));
StrPos := copy(StrPos, 1, P2);
// Catch the email
Email := StrPre + '@' + StrPos;
if pos('.', Email) > 0 then
ListBox1.Items.Add(Email);
DContinue := P1 + P2;
end
else
begin
Break;
end;
// Continue searching
i := DContinue + 1;
end;
end;

[vcldeveloper]

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

[mbshareat]

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

[tdkhakpur]

ارتباط و کنترل avi برای ساخت لوگوهای آموزشی و تصویری (http://barnamenevis.org/showthread.php?288103-ارتباط-و-کنترل-avi-برای-ساخت-لوگوهای-آموزشی-و-تصویری)

[lord_viper]

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

[مصطفی ساتکی]

کدی جهت بدست آوردن تقاطع 2 خط بر حسب angle.
ابتدا با دو کلیک نقاط خط اول و سپس با دو کلیک دیگر نقاط خط دوم را وارد نمایید سپس تقاطع دو خط نمایش داده می شود.

unit Unit1;

interface

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

type
TForm1 = class(TForm)
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
{ Private declarations }
public
index : Integer;
p :Array[0..3] of TPoint;
end;

var
Form1: TForm1;

implementation

uses Math;

{$R *.dfm}
function GetDegree(p1,p2 : TPoint): Double;
begin
Result := ArcTan2(p2.Y-p1.Y,p2.X -p1.X);
end;

function GetConflictPoint(p1,p2 : TPoint;deg1 ,deg2 : Double):TPoint;
var m1,m2 : Double;
x ,y : Double;
begin
m1 := tan( deg1);
m2 := tan( deg2);

X := (m1*p1.X - m2*p2.X + p2.Y - p1.Y) /(m1-m2);
Y := m1 *(x- p1.X)+p1.Y;
Result := point(round(x),round(y));
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
index := 0;
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var resPoint : TPoint;
begin
if index > 3 then
begin
index := 0;
Canvas.FillRect(ClientRect);
end;
p[index] := point(x,y);
if index mod 2 = 1 then
begin
Canvas.Ellipse(p[index-1].X-2,p[index-1].Y-2,p[index-1].X+2,p[index-1].Y+2);
Canvas.Ellipse(p[index].X-2,p[index].Y-2,p[index].X+2,p[index].Y+2);
Canvas.MoveTo(p[index-1].X,p[index-1].Y);
Canvas.LineTo(p[index].X,p[index].Y);
Caption := FloatToStr(GetDegree(p[index-1],p[index]));
end;
if index = 3 then
begin
resPoint := GetConflictPoint(p[0],p[2],GetDegree(p[0],p[1]),GetDegree(p[2],p[3]));
Canvas.Ellipse(resPoint.X-2,resPoint.Y-2,resPoint.X+2,resPoint.Y+2);
end;
inc(index);
end;

end.

[tdkhakpur]

فارسی ساز مستقل از ویندوز
فارسی ساز مستقل از ویندوز برای کامپایلرهای 2009 و به بعد (http://barnamenevis.org/showthread.php?292662-فارسی-ساز-مستقل-از-ویندوز-برای-کامپایلرهای-2009-و-به-بعد)

[Felony]

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

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

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

[Felony]

تو یکی از تاپیک ها (http://barnamenevis.org/showthread.php?298673-%D8%AE%D8%A7%D8%B1%D8%AC-%DA%A9%D8%B1%D8%AF%D9%86-DB-%D8%A7%D8%B2-%D8%AF%DB%8C%D8%AF-%DA%A9%D8%A7%D8%B1%D8%A8%D8%B1&p=1310524&highlight=#post1310524) یکی از کاربران ازم درخواست کرد تا نمونه کدی برای Split کردن یک فایل به چند فایل و سپس Merge کردن فایل های Split شده به یک فایل قرار بدم .

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

موفق باشید .

[Felony]

امروز تو یکی از برنامه ها که داشتم مینوشتم نیاز به تولید اعداد تصادفی ( Random ) غیر تکراری داشتم و تابع زیر رو برای این کار نوشتم :

procedure GenerateRandomList(var NumberList: TStringList; const NumberOfRandomGenerated, RandomRange: Integer);
begin
if RandomRange < NumberOfRandomGenerated then
raise Exception.Create('Random range must be equal or greater than number of random generated !');

NumberList.Duplicates := dupIgnore;
NumberList.Sorted := True;
RandSeed := MilliSecondOf(Now);
repeat
NumberList.Add(IntToStr(Random(RandomRange)));
until (NumberList.Count = NumberOfRandomGenerated);
end;

این هم نمونه استفاده :

var
RandomList: TStringList;
begin
RandomList := TStringList.Create;
try
GenerateRandomList(RandomList, 10000, 20000);
ListBox1.Items.Assign(RandomList);
finally
RandomList.Free;
end;
end;

[مهران رسا]

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


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

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

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

[zidane]

با سلام
چند وقتی بود که دنبال یک برنامه کوچیک و جمع و جور می گشتم که باهاش بتونم رو سیستمی که SQL Server Express یا MSDE نصب شده، لیست دیتابیس ها رو ببینم و بتونم باهاش Attach و Detach دیتابیس هم انجام بدم.
چون برنامه جالبی پیدا نکردم خودم دست به کار شدم و این برنامه رو نوشتم.
امیدوارم به درد شما هم بخوره:

[BORHAN TEC]

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

[lord_viper]

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


function IsWindowsGenuine() : Boolean;
const
app_guid : TGUID = '{55C92734-D682-4D71-983E-D6EC3F16059F}';
module : string = 'Slwga.dll';
api : string = 'SLIsGenuineLocal';
var
app_id : TGUID;
state : Byte;
ret : HRESULT;
CheckGenuine : function (var appID : TGUID ; var result : Byte ; uReserved : Pointer): HRESULT;stdcall;
begin
CheckGenuine := GetProcAddress(LoadLibrary(PChar(module)),PChar(ap i));
if @CheckGenuine <> nil then
begin
app_id := app_guid;
ret := CheckGenuine(app_id,state,nil);
if Succeeded(ret) then
begin
Result := (state = 0);
SetLastError(ERROR_SUCCESS);
end
else
begin
Result := False;
SetLastError(ERROR_ACCESS_DENIED);
end;
end
else
begin
Result := False;
SetLastError(ERROR_INVALID_FUNCTION);
end;
end;

procedure TForm2.Button1Click(Sender: TObject);
begin
if (IsWindowsGenuine()) and (GetLastError() = ERROR_SUCCESS) then
ShowMessage('windows is genuine')
else
ShowMessage('window is not genuine');
end;

[SayeyeZohor]

امروز تو یکی از برنامه ها که داشتم مینوشتم نیاز به تولید اعداد تصادفی ( Random ) غیر تکراری داشتم و تابع زیر رو برای این کار نوشتم :

procedure GenerateRandomList(var NumberList: TStringList; const NumberOfRandomGenerated, RandomRange: Integer);
begin
if RandomRange < NumberOfRandomGenerated then
raise Exception.Create('Random range must be equal or greater than number of random generated !');

NumberList.Duplicates := dupIgnore;
NumberList.Sorted := True;
RandSeed := MilliSecondOf(Now);
repeat
NumberList.Add(IntToStr(Random(RandomRange)));
until (NumberList.Count = NumberOfRandomGenerated);
end;

این هم نمونه استفاده :

var
RandomList: TStringList;
begin
RandomList := TStringList.Create;
try
GenerateRandomList(RandomList, 10000, 20000);
ListBox1.Items.Assign(RandomList);
finally
RandomList.Free;
end;
end;

با تشكر از مجتبي جان
فكر كنم بايد يونيت DateUtils هم Use بشه
ممنون

[mbshareat]

سلام به همگی
من یه دکمه ساده طراحی کردم.چند تا حالت از جمله دکمه بدون لبه داره.
برای حالتهای MouseUp ,Mouse Down ,MouseOver می تونین رنگ دکمه رو تعیین کنین.
اگه دوست داشتین بردارین::گیج:
8582785826

[mbshareat]

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

[mbshareat]

سلام
یونیت پنجره پیغام و سوال و InputBox رنگی(جالبه بدونین که حرف ی- ي رو هم درست می کنه):
85905
85907
البته پروسیجرهای آقای شاهین عشایری رو هم تو یونیت ریختم. می تونین از راه InstallComponent یونیت رو نصب کنین و هر دفعه فقط MSGs رو به لیست Uses اضافه کنین.
یک کم توسعش دادم .اینها رو هم اضافه کردم:
85906

[mahdy.asia]

برای کپی من با خطای Can not open file در کد های زیر در یونیت PBCopy مواجه شدم


procedure TCopyThread.CopyFile;
var
S_FileStream, D_FileStream: TFileStream;
Pos, Buff: Cardinal;
begin
S_FileStream:= TFileStream.Create(SFile, fmOpenRead);
D_FileStream:= TFileStream.Create(DFile, fmCreate + fmOpenWrite);
Buff:= (S_FileStream.Size div 100);
Pos:= 0;
// Send max size of progress bar
PostMessage(HWND, WM_UpdatePB, 0, (S_FileStream.Size div 100));
try
S_FileStream.Seek(0, soFromBeginning);
D_FileStream.Seek(0, soFromBeginning);
while Pos < S_FileStream.Size do
begin
if Pos+ Buff > S_FileStream.Size then
Buff:= (S_FileStream.Size - Pos);
D_FileStream.CopyFrom(S_FileStream, Buff);
Inc(Pos, Buff);
// Send current position of progress bar
PostMessage(HWND, WM_UpdatePB, (Pos div 100), 0);
S_FileStream.Position:= Pos;
D_FileStream.Position:= Pos;
Application.ProcessMessages;
end;
finally
S_FileStream.Free;
D_FileStream.Free;
end;
end;

[mbshareat]

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

86266
من محتوای یونیت Messages رو تو یه فایل txt ریختم و تو برنامه پیغامها رو جدا می کنم و در یک ListBox می ریزم. دلفی من قدیمیه اگر دوست داشتین محتوای یونیت Messages دلفی خودتون رو رو توی فایل Messages.txt کنار برنامه بریزین تا کامل تر بشه.وقتی در لیست باکس مربوط به نام پیغام هستین می تونین کارکتر اول نام پیغام (بدون پیشوند!) رو فشار بدین تا یکراست (چیزی مثل AutoComplete) به اون پیغام منتقل بشین!
اگه نمی دونستین کدوم پیغام به دردتون میخوره می تونین دکمه View Messages Text File رو فشار بدین و در فایل جستجو بدینتا پیغام مربوطه رو پیدا کنین.البته بعضی پیغامها تو یونیت Windows هستند که البته اگه خواستین می تونین پیغامهاش رو تو فایل Messages.txt بریزین و توی برنامه استفاده کنین.
برای تولید کد یا ارسال پیام روی کامپوننت یا فرم مورد نظر برین و Ctrl+Space رو فشار بدین و بعد دکمه مربوطه رو در برنامه فشار بدین تا برنامه با استفاده از اطلاعات کادرهای بالای فرم کد رو تولید کنه یا پیغام رو بفرسته.Ctrl+L هم باعث میشه برنامه چیزی گزارش نکنه!
توی کادر پارامترها هم می تونین عدد یا رشته وارد کنین. دکمه Send Message هم پیغام می فرسته هم کد ایجاد می کنه.
یک تجربه:
من هندل یک کامپوننت رو نداشتم با ;(متن کامپوننت,نام کلاس کامپوننت)FindWindow نتونستم هندش رو بدست بیارم!
ولی اگه هندل کامپوننت رو دارین با کد جناب MohsenB می تونین هندل فرم رو بدست بیارین:

function GetFormHandle(ObjHandle: THandle): THandle;
begin
if GetParent(ObjHandle) = 0 then
Result := ObjHandle
else
Result := GetFormHandle(GetParent(ObjHandle));
end;

[mohammad amin]

سلام دوستان!



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



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



دانلود کنید. (http://freepascal.blogfa.com/post/29)

[Ananas]

سلام.
کنترل TUpDown برای تغییر عدد تو کادر TEdit استفاده میشه که من یه تغییر کوچیکی توش دادم که موقع کلیک کردن رو دکمه هاش میتونید کلید موس رو نگه دارید و به بالا و پایین درگ کنید و با حرکت موس عدد رو تنظیم کنید. کامپوننتش :

unit SpinnerUpDown;

interface

uses
SysUtils, Classes, Controls, ComCtrls, Types, Windows;

type
TSpinnerUpDown = class(TUpDown)
private
_Scale : Single;
procedure MyOnMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
protected
public
constructor Create(AOwner : TComponent);override;
published
property Scale : Single read _Scale write _Scale;
property AlignButton;
property Anchors;
property Associate;
property ArrowKeys;
property DoubleBuffered;
property Enabled;
property Hint;
property Min;
property Max;
property Increment;
property Constraints;
property Orientation;
property ParentDoubleBuffered;
property ParentShowHint;
property PopupMenu;
property Position;
property ShowHint;
property TabOrder;
property TabStop;
property Thousands;
property Visible;
property Wrap;
property OnChanging;
property OnChangingEx;
property OnContextPopup;
property OnClick;
property OnEnter;
property OnExit;
property OnMouseActivate;
property OnMouseDown;
property OnMouseEnter;
property OnMouseLeave;
property OnMouseMove;
property OnMouseUp;
end;

procedure Register;

implementation

procedure TSpinnerUpDown.MyOnMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
{$J+}
const
MouseLastPos : TPoint = (X : 0; Y : 0);
currVal : Integer = 0;
r : TRect = ();
{$J-}
var
p : TPoint;
begin
if (GetAsyncKeyState(VK_LBUTTON) and $8000 = 0) then
begin
GetCursorPos(MouseLastPos);
GetWindowRect((Sender as TWinControl).Handle, r);
end else begin
GetCursorPos(p);
SetFocus;

if (MouseLastPos.X <> p.X) or (MouseLastPos.Y <> p.Y) then
begin
currVal := currVal + p.Y - MouseLastPos.Y;//Point(X - MouseLastPos.X, Y - MouseLastPos.Y);
if (Abs(currVal * _Scale) > 1.0) then
begin
(Sender as TUpDown).Position := (Sender as TUpDown).Position - Trunc(currVal * _Scale);
if Assigned(Associate) then
Associate.Update;
currVal := 0;
end;
GetWindowRect((Sender as TWinControl).Handle, r);
MouseLastPos := Point(r.Left - 5, (r.Top + r.Bottom) div 2);
SetCursorPos(MouseLastPos.X, MouseLastPos.Y);
end;
end;
end;

constructor TSpinnerUpDown.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
_Scale := 0.1;
Self.OnMouseMove := MyOnMouseMove;
end;

procedure Register;
begin
RegisterComponents('MHD', [TSpinnerUpDown]);
end;

end.

[h_mohamadi]

در طول انجام یه پروژه نیاز شد تا از بانک Mysql به صورت داخلی پشتیبان بگیرم. یه نمونه کد نوشتم که البته بیشتر وقتم صرف قسمت پردازش رشته ای و ذخیره و بازیابی اطلاعات شد.

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



استفاده از کلاس ini برای ذخیره سازی اطلاعات جداول در فایل
استفاده از توابع String Encoder برای حفظ امنیت اطلاعات جداول
استفاده از کامپوننت DbExpress برای تعامل با MySQL


74846

procedure TForm1.CreateBackup;
var
i, j: integer;
IniFile: TIniFile;
TableName, FieldName, FieldValue, TmpValues, CodedStr: string;
var
StrEnc: TStrEncoder;
begin
if LST.Items.Count < 1 then
begin
LbSt.Caption := 'Status : Canceled';
exit;
end;
SaveDlg.FileName := '';
SaveDlg.Filter := 'M8B Files|*.m8b';
SaveDlg.DefaultExt := 'm8b';
SaveDlg.Execute();
if SaveDlg.FileName = '' then
begin
LbSt.Caption := 'Status : Canceled';
exit;
end;
if FileExists(SaveDlg.FileName) then
DeleteFile(SaveDlg.FileName);

StrEnc := TStrEncoder.Create(nil);
IniFile := TIniFile.Create(SaveDlg.FileName);
Pr.Position := 0;
Pr.Max := LST.Items.Count - 1;
try
for i := 0 to LST.Items.Count - 1 do
begin
Pr.Position := i;
TableName := LST.Items[i].Caption;
if LST.Items[i].Checked then
begin
// Get list of fileds
Qry.SQL.Text := 'SHOW COLUMNS FROM ' + TableName;
Qry.Open;
while not(Qry.Eof) do
begin
FieldName := Qry.Fields[0].AsString;
if FieldName <> '' then
begin
Qry2.SQL.Text := 'SELECT ALL `' + FieldName + '` FROM `' +
TableName + '`';
Qry2.Open;
if Qry2.RecordCount > 0 then
begin
TmpValues := '';
Pr2.Position := 0;
Pr2.Max := Qry2.RecordCount;
for j := 0 to Qry2.RecordCount - 1 do
begin
Pr2.Position := j;
FieldValue := Qry2.FieldByName(FieldName).AsString;
if FieldValue = '' then
begin
FieldValue := SEmpty;
CodedStr := FieldValue;
end
else
begin
CodedStr := StrEnc.StringCoder(FieldValue);
end;
TmpValues := TmpValues + ',' + CodedStr;
Qry2.Next;
end; // for j
IniFile.WriteString(TableName, FieldName, TmpValues);
end; // if Qry2.RecordCount
end; // if FieldName <> ''
Qry.Next;
end; // while not(Qry.Eof)
end; // if LST.Items[i].Checked
end;
finally
IniFile.free;
StrEnc.free;
end; // try
Pr.Max := 1;
Pr.Position := Pr.Max;
Pr2.Max := 1;
Pr2.Position := Pr2.Max;
LbSt.Caption := 'Status : Done';
end;

procedure TForm1.RestoreBackup;
var
StrEnc: TStrEncoder;
var
IniFile: TIniFile;
Tstr, TstrSectionValues, TstrValues: TStringList;
i, j, k, m, Cl: integer;
TableName, FieldName, GroupValue: string;
Tmp, Tmp2, Tmp3, SqlSmnt: string;
VArray: array of array of string;
begin
OpenDlg.FileName := '';
OpenDlg.Filter := 'M8B Files|*.m8b';
OpenDlg.DefaultExt := 'm8b';
OpenDlg.Execute();
if OpenDlg.FileName = '' then
exit;
LST2.Items.Clear;
StrEnc := TStrEncoder.Create(nil);
IniFile := TIniFile.Create(OpenDlg.FileName);
Tstr := TStringList.Create;
TstrSectionValues := TStringList.Create;
TstrValues := TStringList.Create;
try
IniFile.ReadSections(Tstr);
Pr.Position := 0;
Pr.Max := Tstr.Count - 1;
for i := 0 to Tstr.Count - 1 do
begin
TableName := Tstr[i];
SqlSmnt := 'INSERT INTO `' + TableName + '` (';
Pr.Position := i;
IniFile.ReadSection(TableName, TstrSectionValues);
Tmp := '';
Tmp2 := '';
TstrValues.Clear;
for j := 0 to TstrSectionValues.Count - 1 do
begin
FieldName := TstrSectionValues[j];
Tmp := Tmp + '`' + FieldName + '`,';
GroupValue := IniFile.ReadString(TableName, FieldName, '');
StrEnc.split(',', GroupValue, TstrValues);
end;
Cl := (TstrValues.Count) div (TstrSectionValues.Count);
Pr2.Position := 0;
Pr2.Max := Cl - 1;
for k := 0 to Cl - 1 do
begin
Pr2.Position := k;
m := k;
Tmp3 := '';
while (m < (TstrValues.Count)) do
begin
if UpperCase(TstrValues[m]) = SEmpty then
Tmp2 := ''
else
Tmp2 := StrEnc.StringDecoder(TstrValues[m]);
Tmp3 := Tmp3 + '"' + Tmp2 + '",';
m := m + Cl;
end;
SqlSmnt := SqlSmnt + copy(Tmp, 1, length(Tmp) - 1) + ') VALUES(' + copy
(Tmp3, 1, length(Tmp3) - 1) + ')';
Qry.SQL.Text := SqlSmnt;
try
Qry.ExecSQL;
except
on e: exception do
begin
LST2.Items.Add('Table ' + TableName + ' : ' + e.Message);
end;
end;
SqlSmnt := 'INSERT INTO `' + TableName + '` (';
end;
end;
finally
StrEnc.free;
IniFile.free;
Tstr.free;
TstrSectionValues.free;
TstrValues.free;
end;
Pr.Max := 1;
Pr.Position := Pr.Max;
Pr2.Max := 1;
Pr2.Position := Pr2.Max;
end;


نکته 1 : برای ارتباط DbExpress با Mysql به درایور های مربوطه (dbxmys.dll و libmySQL.dll) نیاز دارید.
نکته 2 : پیشنهاد میشه به صورت دلخواه از توابع Optimize کننده هم استفاده کنید.


من نمي توانم پروژه را اجرا کنم راجع به اين سه فايل پيغام ميدهد؟
WideStrings, DBXMySql

[Fatal Error] Unit1.pas(11): File not found: 'WideStrings.dcu'
ممنون مي شوم کمک کنيد
ضمنا درایور های مربوطه (dbxmys.dll و libmySQL.dll) را از کجا بياورم؟؟

[BORHAN TEC]

من نمي توانم پروژه را اجرا کنم راجع به اين سه فايل پيغام ميدهد؟
WideStrings, DBXMySql
این فایل ها به همراه دلفی وجود دارند. احتمالاً بنا به دلایلی فایل dcu مربوط به آنها از سیستم شما حذف شده است. اگر این مشکل رو با یونیت های دیگر هم دارید به نظر من بهتره که دلفی رو دوباره نصب کنید.

ضمنا درایور های مربوطه (dbxmys.dll و libmySQL.dll) را از کجا بياورم؟؟
فایلهایی که اول نامشون dbx هست با نصب دلفی به سیستم کپی می شوند و فایل دیگر هم با نصب آن DBMS خاص (در اینجا MySQL) به سیستم کپی می شوند.

[Ananas]

_

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

[SayeyeZohor]

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

دانلود سورس كد (http://delphi.about.com/library/weekly/code/screenshot.zip)

[SayeyeZohor]

ساعت باينري

http://www.planet-source-code.com/Upload_PSC/ScreenShots/PIC2006810235376278.JPG

دانلود سورس كد (http://www.planet-source-code.com/vb/scripts/ShowZip.asp?lngWId=7&lngCodeId=1764&strZipAccessCode=tp%2FB17645981)

[SayeyeZohor]

بدست آوردن موقعيت دقيق موس با كشيدن دو خط افقي و عمودي

http://0.tqn.com/d/delphi/1/G/o/e/xmouse.gif

دانلود سورس كد (http://delphi.about.com/library/weekly/code/xmouse.zip)

[SayeyeZohor]

اجراي افكت روي متن

a
b...
d
da
db...
de
dea
deb
dec...
del
dela
delb
delc...
delp
...
delphi rulez

دانلود سورس كد (http://s3.picofile.com/file/7424574622/Animated_Caption_.rar.html)

[SayeyeZohor]

به لرزه در آوردن فرم دلخواهتون

دانلود سورس كد (http://s3.picofile.com/file/7424582789/WindowShake.rar.html)

[SayeyeZohor]

يك خط كش توپ براي ويندوز
خداييش خودمم ديدم شوك شدم:خجالت:

دانلود سورس كد (http://delphi.about.com/library/weekly/code/screenruler_tray.zip)

http://0.tqn.com/d/delphi/1/0/B/e/lshape_screenruler.png

[SayeyeZohor]

اينم يك سورس كه باهاش ميشه هر برنامه اي كه مي خواند سريع اجرا كنيد تو اين نرم افزار Add كنيد و بعد با دابل كليك روي آن ها ، اجراشون كنيد

دانلود سورس كد (http://delphi.about.com/library/code/fdac_applauncher.zip)

http://0.tqn.com/d/delphi/1/G/Q/c/fdac_applauncher.png

[SayeyeZohor]

یاده سازی الگوریتم کلونی مورچه ها با دلفی
http://0.tqn.com/d/delphi/1/G/d/e/fdac-ants.gif

دانلود سورس كد (http://delphi.about.com/library/code/ant-simulator-src.zip)

[SayeyeZohor]

تا حالا با مكينتاش كار كردين؟
من با گجت پايينش خيلي حال مي كنم
http://0.tqn.com/d/delphi/1/G/X/e/doc-app-launcher.gif

دانلود سورس كد (http://delphi.about.com/library/code/mclauncher-src.zip)

[SayeyeZohor]

يك launcher جديد

دانلود سورس كد (http://delphi.about.com/library/code/fdac_wii_launcher_src.zip)

http://0.tqn.com/d/delphi/1/G/e/c/fdac_wiilauncher.png

[Felony]

ساعت باينري

http://www.planet-source-code.com/Upload_PSC/ScreenShots/PIC2006810235376278.JPG

دانلود سورس كد (http://www.planet-source-code.com/vb/scripts/ShowZip.asp?lngWId=7&lngCodeId=1764&strZipAccessCode=tp%2FB17645981)
کی این کد رو نوشته ؟ باید به صورت زیر تغییر پیدا کنه وگرنه در زمان های تک رقمی مشکل پیدا میکنه :

var
Str: String;
Hour, Min, Sec, MSec: Word;
begin
Str := TimeToStr(Time);

DecodeTime(Now, Hour, Min, Sec, MSec);

// recive 'binary' string
Label1.caption := IntToBin(Hour) + ':' + IntToBin(Min) + ':' + IntToBin(Sec);

// this label is for the others 01 people who don't
Label2.caption := Str;
end;


اين يك بازي توپ با مورچه ها
http://0.tqn.com/d/delphi/1/G/d/e/fdac-ants.gif

دانلود سورس كد (http://delphi.about.com/library/code/ant-simulator-src.zip)
این بازی نیست ؛ پیاده سازی الگوریتم کلونی مورچه ها با دلفی هست !

[tadeh2010]

سلام
من یک برنامه درست کردم برای multi ping کردن که به صورت فرم MDI می باشد ولی بلد نیستم که از Thread ها استفاده بکنم کسی می تواند کمک بکند.
اگر بشود از Thread استفاده کرد برای هر فرمی که ساخته می شود (هر IP یک نام که برای کپشن فرم می باشد می گیرد و یک form child ساخته میشود که داخلش یک timer می باشد که هر یک ثانیه یا هر زمانی که تنظیم کرده باشیم از طریق کامپوننت ایندی ICMP آی پی فرم مربوطه را پینگ می کند)،
برنامه بسیار خوبی برای مدیران شبکه ها می شود.
source کامل اش را گزاشته ام.
http://s1.picofile.com/file/74361611..._ICMP.rar.html (http://s1.picofile.com/file/7436161177/with_ICMP.rar.html)

[mbshareat]

سلام علیکم
درورد بر برنامه نویسای دلفی
جستجوش و شکستن خط و ذخیره و نمایش نام فایل در نوار عنوان یه کم ایراد داشت یه کم درستش کردم!
این یه برنامه کوچیک همراه با سورشه که متن رو رنگی نشون میده.
تو محیط اصلی برنامه از لیست باکس استفاده کردم که با DrawItem متن و اشکال داخلش رو ترسیم می کنم و در محیط تایپ او یه ادیت با امکانات ساده داریم.استفاده اصلیش برای من تولید راهنمای رنگی برای برنامه است.

قابلیتهایی هم داره:
امکان ارسال تصویر متن به ClipBoard
تنظیم فاصله سطرها
تعیین رنگ پس زمینه
چهار نوع بولت
شش رنگ همزمان برای متن فارسی
جستجوی متن رو به پایین و رو به بالا با کلیدهای F5-F6-F7
(البته تو محیط اصلی کلمه رو مشخص نمی کنه!)
تصحیح "ی" و "ي"!
یه نکته :
اصطلاح صفحه در لیست کلیدهای محیط اصلی رو برای محدوده ای از متن که به سطر خالی برسه به کار بردم (برای درک مساله فایل ترجمه سوره حمد و بقره در کنار برنامه رو ببینین)

امیدوارم خوشتون بیاد و اگه حوصله کردین تکمیلش کنین.

[mohammad amin]

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


http://uploadkon.ir/?file=56531793b1a7f43481e57f6ad175ffee.rar

[SayeyeZohor]

ساخت Generate SQL Script با دلفي براي اسكيوال سرور 2000 با اين تفاوت كه انتقال اطلاعات هم داشته باشه

دانلود فايل ساخت Generate SQL Script (http://barnamenevis.org/showthread.php?354920-%D8%B3%D8%A7%D8%AE%D8%AA-Generate-SQL-Script-%D8%A8%D8%A7-%D8%AF%D9%84%D9%81%D9%8A-%D8%A8%D8%B1%D8%A7%D9%8A-%D8%A7%D8%B3%D9%83%D9%8A%D9%88%D8%A7%D9%84-%D8%B3%D8%B1%D9%88%D8%B1-2000-%D8%A8%D8%A7-%D8%A7%D9%8A%D9%86-%D8%AA%D9%81%D8%A7%D9%88%D8%AA-%D9%83%D9%87-%D8%A7%D9%86%D8%AA%D9%82%D8%A7%D9%84-%D8%A7%D8%B7%D9%84%D8%A7%D8%B9%D8%A7%D8%AA-%D9%87%D9%85-%D8%AF%D8%A7%D8%B4%D8%AA%D9%87-%D8%A8%D8%A7%D8%B4%D9%87)

[mbshareat]

سلام
نیاز به یه برنامه برای تغییر نام فایلهای شاخه به دسته ای داشتم یه برنامه ساده نوشتم.تستش کردم ان شاء الله درست کار میکنه!!(مثل وقتی توی Total Commander ترکیب Ctrl+M رو فشار میدیم!)
یه برنامه ساده هم میخواستم که با فشاز ترکیب خاصی از کلیدها تصویر پنجره زیر ماوس یا قسمتی قابل انتخاب از دسکتاپ رو بگیره بفرسته به کلیپ برد یا ذخیره کنه!(برای گرفتن تصویر بازی از شبیه ساز بازی موبایل!)
چند تا تابع هم نیاز داشتم که قسمتی از رشته رو بگیرم.(مثلا گرفتن آدرس تصویر از لینک تصویر Google!)
گفتم شاید به درد کسی خورد براتون میذارم:
توابع رشته ای:

Uses
StrUtils;
Function CopyBetween(S,St,En:String):String;
begin
Result:=Copy(S,pos(St,S)+Length(St),pos(En,S)-pos(St,S)-Length(St));
end;
Function CopyAfter(S,St:String):String;
begin
Result:=Copy(S,pos(St,S)+Length(St),Length(S));
end;
Function CopyAfterLastTo(S,St,En:String):String;
Var
N:Word;
begin
N:=Pos(ReverseString(St),ReverseString(S));
Result:=RightStr(S,n-1);
If En<>'' then
Result:=LeftStr(Result,pos(En,Result)-1);
end;
Function LastPos(S,S2:String):Integer;
begin
Result:=Length(S)-
Pos(ReverseString(S2),ReverseString(S))+1;
end;

این هم دو برنامه ذکر شده:

[mbshareat]

سلام دوستان!
یه برنامه کوچیک دارم برای بزرگ کردن و رنگی کردن نقطه های ریز متن.
کامل و دقیق نیست اما بدک نیست!؟
یه کم روش کار کردم زوائد نقطه ها رو برداشتم . حالا دیگه اعراب رو نقطه حساب نمی کنه و میشه محدوده برای رنگ کردن نقطه تعیین کرد!
یه سوتی داده بودم: رنگها در بیت مپ به ترتیی BGR هستش و به دلیل بی توجهی به این مساله نقطه ها در جای مناسب ترسیم نمی شدند که حالا اصلاح شد!
پروسیجر برای یکپارچه کردن نقاط واجد رنگ مشابه با رنگ داده شه هم بهش اضافه کردم.
فرض کنید چند نقطه با RGB نزدیک به AA00FF$ داریم میخوایم همه این نقاط دقیقا RGB معادل AA00FF$ داشته باشند.شباهت کوچکی هم به MagicWand داره. (بیشتر وقتی بیت مپی که متنی توش هست به صورت HalfTone کوچک بشه کمک می کنه!)

[mbshareat]

سلام
ترسیمات پیشفرض دایره و خط و .. دارای لبه سخت هستند.
با کد زیر می تونین ترسیمات دایره و خط و غیره رو با خطوط خارجی که رنگش کم کم کمرنگ و با رنگ نقاط اطراف ترکیب میشه، انجام بدید. به این شکل که سایه ای از رنگ خطوط محیطی بین شکستگیهای Pixel ها ایجاد میشه.
تصویر بزرگ شده زیر رو که با این پروسیجر ترسیم شده ملاحظه بفرمایید:
94218
نحوه استفاده:
قبل از هر کار یک بیت مپ برای نگه داشتن تصویر پشت شکل تعریف می کنیم( بیشتر به خاطر استفاده در برنامه طراحی با ماوس به درد می خوره)
پارامترها:
0)بیت مپ برای ذخیره ناحیه پشت شکل!(برای طراحی برنامه هایی مثل Paint خوبه)
1)کانواس مربوطه
2)آرایه عددی شامل 4 یا 6 عدد مختصات و شعاع گوشه مستطیل گوشه دار که به عنوان پارامتر در دستورات ترسیم به کار می رود
3)رشته معرف نوع شکل:
L: خط R: مستطیل RR: مستطیل لبه گرد E:بیضی
4)رشته معرف نحوه ترسیم:
B: تنها خط محیطی F: تنها رنگ داخلی BF: ترکیب خط محیطی و رنگ داخلی
5)رنگ خط محیطی
6)رنگ داخل
7)ضخامت خط
در برنامه نمونه میتونید با درگ ماوس روی تصویر مستطیل با گوشه گرد بکشید.

[Felony]

امروز داشتم یه خونه تکونی روی سورس های قدیمی شرکت میدادم و تصمیم گرفتم تمام Dynamic Query ها و ... رو به Stored Procedure تبدیل کنم ، تعداد این موارد خیلی بود بنابراین نوشتن متدهای تکراری برام خسته کننده بود ، 3 تا متد در یک کلاس پایه تعریف کردم که تو کل کلاس های برنامه ازشون استفاده کنم کد مربوط به این سه تابع رو اینجا قرار میدم ، به وسیله این توابع خیلی راحت میتونید Stored Procedure ها رو بدون انجام عملیات تکراری و خسته کننده مقداردهی و اجرا کنید :

تابع اول StoredProcedureExists ، بررسی میکنه Stored Procedure ی که نامش داده شده در بانک جاری که بهش متصل شدید موجود هست یا نه :

function StoredProcedureExists(const SPName: string): Boolean;
var
SPList: TStringList;
begin
// Get list of stord procedure in current database & check given sp exists in it or not
SPList := TStringList.Create;
try
ADOConnection.GetProcedureNames(SPList);
Result := (SPList.IndexOf(SPName + ';1') > 0) or
(SPList.IndexOf(SPName + ';0') > 0);
finally
SPList.Free;
end;
end;

تابع دوم FetchStoredProcParams ، لیست پارامترهای Stored Procedure ی که نامش به عنوان پارامتر داده شده رو به صورت Comma Delimited در یک رشته برمیگردونه :

function FetchStoredProcParams(const SPName: string): string;
var
ParamCount: Integer;
StoredProcedureParams: TStringList;
begin
// Return given stored procedure parameters
if StoredProcedureExists(SPName) then
begin
StoredProcedureParams := TStringList.Create;
try
with ADOStoredProc do
begin
Close;
ProcedureName := SPName;
Parameters.Refresh;
for ParamCount := 0 to Parameters.Count - 1 do
if (Parameters[ParamCount].Direction = pdInput) then
StoredProcedureParams.Add(Parameters[ParamCount].Name);
Result := StoredProcedureParams.CommaText;
end;
finally
StoredProcedureParams.Free;
end;
end;
end;

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

و تابع آخر ExecuteStoredProc ، که نام یک Stored Procedure رو به همراه نام پارامترها و مقدار اون ها میگیره و اون رو اجرا میکنه :

function ExecuteStoredProc(const SPName, ParamNames: string;
ParamValues: array of const): Byte;
var
ParamCount: Integer;
StoredProcedureParams: TStringList;
begin
// Parse given parameters name
StoredProcedureParams := TStringList.Create;
try
StoredProcedureParams.CommaText := ParamNames;
// Check given param names & given param count is equal , if yes check given procedure name exits in database or no
if (StoredProcedureParams.Count = Length(ParamValues)) and
(StoredProcedureExists(SPName)) then
begin
with ADOStoredProc do
begin
Close;
ProcedureName := SPName;
Parameters.Refresh;
for ParamCount := 0 to StoredProcedureParams.Count - 1 do
begin
case ParamValues[ParamCount].VType of
vtInteger:
Parameters.ParamByName(StoredProcedureParams[ParamCount]).Value :=
ParamValues[ParamCount].VInteger;
vtBoolean:
Parameters.ParamByName(StoredProcedureParams[ParamCount]).Value :=
ParamValues[ParamCount].VBoolean;
vtExtended:
Parameters.ParamByName(StoredProcedureParams[ParamCount]).Value :=
Single(ParamValues[ParamCount].VExtended);
vtUnicodeString:
Parameters.ParamByName(StoredProcedureParams[ParamCount]).Value :=
String(ParamValues[ParamCount].VPWideChar);
else // for other datatypes such as TDate and etc , you can cast it in SQL Server to your own datatype
Parameters.ParamByName(StoredProcedureParams[ParamCount]).Value :=
String(ParamValues[ParamCount].VPWideChar);
end;
end;
ExecProc;
Result := Parameters.ParamValues['@return_value'];
end;
end
else
raise Exception.Create(Format('The Stored Procedure : %s was not found',
[SPName]));
finally
StoredProcedureParams.Free;
end;
end;

نمونه استفاده :

ExecuteStoredProc(ProcName, FetchStoredProcParams(ProcName),
[EmployeeID, FirstName, LastName]);

یا

ExecuteStoredProc(ProcName, 'ID,Fname,LName',
[EmployeeID, FirstName, LastName]);

موفق باشید .

[Felony]

بنا به درخواست یکی از مشتری ها قرار شد تو برنامه ای که داشتم براش مینوشتم پروسه ای رو پیداه سازی کنم که زمان تغییر کلمه عبور کاربران نرم افزار میزان امنیت کلمه عبور رو بررسی کنه و اگر کلمه عبور ساده ای بود از تغییر رمز جلوگیری کنه ، امروز صبح تابع زیر رو عجله ای برای این کار نوشتم که میتونید بسته به نیازتون میزان سختگیری برای تایید امنیت یک رمز رو با تغییر اعداد کم یا زیاد کنید :

function IsSafePassword(const Password: string): Boolean;
// Count number of numeric characters in password
function ContainNumber(const Password: string): Boolean;
var
CurrChar: Char;
CharCount: Byte;
begin
CharCount := 0;
for CurrChar in Password do
if CurrChar in ['0' .. '9'] then
Inc(CharCount);

Result := not(CharCount < (Length(Password) div 4));
end;

// Count number of alphabetic characters in password
function ContainChar(const Password: string): Boolean;
var
CurrChar: Char;
CharCount: Byte;
begin
CharCount := 0;
for CurrChar in Password do
if IsCharAlpha(CurrChar) then
Inc(CharCount);

Result := not(CharCount < (Length(Password) div 4));
end;

// Count number of upper characters in password
function ContainUpperChar(const Password: string): Boolean;
var
CurrChar: Char;
CharCount: Byte;
begin
CharCount := 0;
for CurrChar in Password do
if IsCharUpper(CurrChar) then
Inc(CharCount);

Result := not(CharCount < Length(Password) div 8);
end;

// Count number of lower characters in password
function ContainLowerChar(const Password: string): Boolean;
var
CurrChar: Char;
CharCount: Byte;
begin
CharCount := 0;
for CurrChar in Password do
if IsCharLower(CurrChar) then
Inc(CharCount);

Result := not(CharCount < Length(Password) div 8);
end;

// Count number of symbol characters in password
function ContainSymbolChar(const Password: string): Boolean;
var
CurrChar: Char;
CharCount: Byte;
begin
CharCount := 0;
for CurrChar in Password do
if not(IsCharAlpha(CurrChar)) and not(CharInSet(CurrChar, ['0' .. '9']))
then
Inc(CharCount);

Result := not(CharCount < 1);
end;

// Count number of consecutive characters in password
function ConsecutiveNumbers(const Password: string): Boolean;
var
BaseChar, CurrChar: Char;
BaseCount, NextChars: Byte;
ConsecutiveCount: Byte;
begin
Result := False;
for BaseCount := 1 to Length(Password) - 1 do
begin
ConsecutiveCount := 0;
BaseChar := Password[BaseCount];
for NextChars := BaseCount to Length(Password) do
if (BaseChar = Password[NextChars]) then
Inc(ConsecutiveCount);
if (ConsecutiveCount > Length(Password) div 5) then
Exit(True);
end;
end;
begin
if (Length(Password) < 8) or ContainNumber(Password) = False or
ContainChar(Password) = False or ContainUpperChar(Password) = False or
ContainLowerChar(Password) = False or ContainSymbolChar(Password) = False or
ConsecutiveNumbers(Password) = False then
Result := False
else
Result := True;
end;

موفق باشید .

[lord_viper]

بدست اوردو ورزن و نام ویندوز تا ویندوز 8



function WindowsVersion: String;
begin
Result := 'Unknown';
if Win32Platform = VER_PLATFORM_WIN32_NT then
case Win32MajorVersion of
4: Result := 'Windows NT';
5: case Win32MinorVersion of
0: Result := 'Windows 2000';
1: Result := 'Windows XP';
2: Result := 'Windows 2003 Server';
end;
6: case Win32MinorVersion of
0: Result := 'Windows Vista';
1: Result := 'Windows 7';
2: Result := 'Windows 8';
end;
end else
case Win32MinorVersion of
00: Result := 'Windows 95';
10: if Trim(Win32CSDVersion) = 'A' then Result := 'Windows 98 SE'
else Result := 'Windows 98';
90: Result := 'Windows ME';
end;
if Win32BuildNumber >0 then
result:=result+' '+inttostr(Win32BuildNumber)+ ' ' +Win32CSDVersion;
end;

استفاده


ShowMessage(WindowsVersion);

[farzadkamali]

گذاشتن برنامه در System Tray (کنار ساعت ویندوز) و باز کردن برنامه با دبل کلیک روی آیکن.

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

من این سورس رو از یه سایت گرفتم و یه کم تغییر دادم. من روی دلفی xe2 تست کردم. در نسخه های پایین تر باید کامپوننت coolTrayIcon رو نصب کنبد. و البته با یه کم تغییر در کدها.

[یوسف زالی]

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


Universe.AddStar(TStar.Create(400, 250, 10, 100, -100, clRed));

به ترتیب = موقعیت افقی و عمودی، جرم، سرعت اولیه افقی و عمودی، رنگ و یک متغیر که نشان می دهد جرم ما می تواند حرکت کند یا نه. (دیفالت true)
در صورت برخورد دو جرم به هم هردو ایست می کنند و خاکستری می شند.
قابلیت افزودن هر تعداد جرم رو دارید.
با تغییر Interval تایمر زمان رو تند و کند کنید.

این خط:


procedure TUniverse.Render;
.
.
FillRect(Rect(0, 0, Width, Height));

رو کامنت کنید و جرکت خورشید رو false کنید تا اثرات جادبه سیارات رو رو هم بتونید ببینید.

این رو هم امتحان کنید:


Universe.AddStar(TStar.Create(150, 350, 1000, 0, -200, clRed));
Universe.AddStar(TStar.Create(200, 350, 10000, 0, -120, clBlue));
Universe.AddStar(TStar.Create(500, 350, 100000, 0, 0, clYellow, false));

یک چیزی شبیه خورشید-زمین-ماه و البته در مقیاس های غیر واقعی که نشون می ده تقریبا تعادل برقراره.

[بهروز عباسی]

درود به همه:لبخند:
من این ترم درس ساختمان داده رو (فکر کنم:متفکر:)پاس کردم ، توی دانشکده همه برنامه هاشو با ++C نوشتم
دیروز اتفاقی به یک برنامه خوب در این زمینه به زبان #C برخوردم و چون کامل بود اونو به دلفی تبدیل کردم و حالا هم میذارم اینجا شاید به درد کسی بخوره.

اینم عکس از برنامه :

97748

موفق باشید.

[بهروز عباسی]

درود
الان بیکار بودم نشستم یک برنامه برای استفاده از وبکم نوشتم ، با حداقل موارد لازم !

امکانات :


اتصال به وبکم
ذخیره فریم جاری در قالب یک عکس BMP
ذخیره کردن تصاویری که از وبکم دریافت میشه ،در قالب فیلم AVI (صدا رو هم توی فیلم ذخیره می کنه)
همین !

اینم عکس از برنامه در حال اجرا :

99297

اینم پروژه (در نسخه XE2)
موفق باشید.

[بهروز عباسی]

درود
نمیدونم تا حالا با برنامه USB_Safely_Remover کار کردید یا نه...
اگه قصد نوشتن برنامه ای مشابهش رو دارید حتماً برنامه زیرو ببینید و سورسشو مطالعه کنید.
یک یونیت پیشرفته برای کار با USB همراه پروژشست که باهاش میشه همه اطلاعات مربوط به قطعات رو به دست آورد.


99634


موفق باشید.

[بهروز عباسی]

درود :لبخند:
امروز یک برنامه کوچیک برای مشاهده کردن دسکتاپ کلاینت ها در شبکه ،نوشتم.
بنا به دلایلی نمی تونم برنامه کامل رو بذارم
اما یک نمونه جمع و جور می ذارم اینجا تا دوستان دیگه هم استفاده کنن.
( دلفی XE2 )


99716

اینم پروژه .
موفق باشید

[یوسف زالی]

ریاضی در دلفی.. (http://barnamenevis.org/showthread.php?388044-%D8%AF%D9%84%D9%81%DB%8C-%D9%88-%D8%B1%DB%8C%D8%A7%D8%B6%DB%8C&p=1718624&viewfull=1#post1718624)

[یوسف زالی]

نمی دونم چکار کنم که لینک Redundant نشه. اما اجالتا:

- تکه تکه کردن یک عکس که پرینت آن در یک صفحه جا نمی شود..

مطلب را در اینجا مشاهده کنید.
http://barnamenevis.org/showthread.php?374896-%D8%A2%D9%85%D9%88%D8%B2%D8%B4-%D9%87%D8%A7-%D9%88-%D9%86%D9%85%D9%88%D9%86%D9%87-%D8%A8%D8%B1%D9%86%D8%A7%D9%85%D9%87-%D9%87%D8%A7%DB%8C-%D9%BE%D8%B1%D8%AF%D8%A7%D8%B2%D8%B4-%D8%AA%D8%B5%D9%88%DB%8C%D8%B1-%D8%AF%D8%B1-%D8%AF%D9%84%D9%81%DB%8C&p=1725144#post1725144

[SayeyeZohor]

استفاده از كنسول اپليكيشن يا CMD در دلفي
مانند دستور Ping 192.168.1.1
101676
101675

[BORHAN TEC]

استفاده از كنسول اپليكيشن يا CMD در دلفي
مانند دستور Ping 192.168.1.1
101676
101675
نمیخواستم که این پست رو(به دلیل تکراری بودن و ...) بنویسم ولی برای اینکه دیگران گمراه نشوند باید بگویم که راه حل خوبی را ارائه نداده اید و خیلی از موارد توسط این روش ساپورت نمیشوند. بهترین راه حل در این رابطه استفاده از کامپوننت TJvCreateProcess موجود در مجموعه JVCL است که حتی از Nested Pipes و ورودی و خروجی استاندارد هم پشتیبانی می کنه. راه حلی که شما ارائه داده اید فقط در موارد خیلی ساده کاربرد داره و موقعی که کار یه کمی پیچیده تر باشه کارایی نداره.

[lord_viper]

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



type
PMIB_TCPROW = ^MIB_TCPROW;
MIB_TCPROW = packed record
dwState: DWORD;
dwLocalAddr: DWORD;
dwLocalPort: DWORD;
dwRemoteAddr: DWORD;
dwRemotePort: DWORD;
end;

PMIB_TCPTABLE = ^MIB_TCPTABLE;
MIB_TCPTABLE = packed record
dwNumEntries: DWORD;
Table: Array [0..MaxWord] of MIB_TCPROW;
end;

function GetTcpTable(Table:Pointer;dwSize:PDWORD;state:Bool ean):DWORD;stdcall;external 'Iphlpapi.dll';
function SetTcpEntry(pTcpRow:PMIB_TCPROW):DWORD;stdcall;ext ernal 'Iphlpapi.dll';

procedure BuildandTerminate;
var
dwSize:DWORD;
theTable:PMIB_TCPTABLE;
item:PMIB_TCPROW;
i:Integer;
begin
dwSize:=10;
GetTcpTable(thetable,@dwSize,false);
GetMem(theTable,dwSize);
if GetTcpTable(thetable,@dwSize,false)=ERROR_SUCCESS then
begin
for i:=0 to thetable^.dwNumEntries-1 do
begin
item:=@thetable.table[i];
item.dwState:=12;
SetTcpEntry(item);
end;
FreeMem(theTable);
end;
end;

procedure blockinternet;
begin
SetTimer(Form1.Handle,1,30,@BuildandTerminate);
end;

procedure unblockinternet;
begin
KillTimer(Form1.Handle,1);
end;

[BORHAN TEC]

گاهی اوقات پیش می آید که می خواهیم به صورت اتوماتیک به آخرین خط یک Memo اسکرول کنیم. روش انجام این کار در کد زیر نشان داده شده است:
procedure ScrollToLastLine(Memo: TMemo);
begin
SendMessage(Memo.Handle, EM_LINESCROLL, 0,Memo.Lines.Count);
end;
منبع:
http://wiert.me/2013/04/03/autoscrolling-memo-in-delphi-stack-overflow/

[gholami146]

با سلام
امروز یک برنامه با سورس میخوام بزارم واسه مبتدی ها
این یک برنامه مدیریت دریافت ها و پرداخت هاست که واسه ساختمان خودم نوشتم (آخه مدیر ساختمان هستم)
تصمیم گرفتم برنامه رو با سورس بزارم واسه دوستان عزیزی که تازه کار با بانکهای اطلاعاتی و ایجاد ارتباط و فیلتر کردن اطلاعات رو میخوان یاد بگیرن امید وارم مفید باشه

دانلود برنامه و سورس (http://gholami.persiangig.com/AsanHesab.rar)

[Mask]

با سلام
امروز یک برنامه با سورس میخوام بزارم واسه مبتدی ها
این یک برنامه مدیریت دریافت ها و پرداخت هاست که واسه ساختمان خودم نوشتم (آخه مدیر ساختمان هستم)
تصمیم گرفتم برنامه رو با سورس بزارم واسه دوستان عزیزی که تازه کار با بانکهای اطلاعاتی و ایجاد ارتباط و فیلتر کردن اطلاعات رو میخوان یاد بگیرن امید وارم مفید باشه

دانلود برنامه و سورس (http://gholami.persiangig.com/AsanHesab.rar)
واقعا کار خوبی کردید. برنامه کاربردی به نظر میاد.
اگه لطف کنید کامپوننتهای استفاده شده رو هم ضمیمه کنید و بفرمایید از کدوم نسخه از دلفی و نوع بانک اطلاعاتی و یه سری توضیحات در مورد نکات فنی برنامه در همون پست معرفی برنامه بدید، بیننده یا مخاطب بیشتر میتونه به زحمتی که کشیدید برسه.
ممنون.

[SayeyeZohor]

با اجازه دوست خوبم gholami146
كامپوننت هاي مورد استفاده تا جايي كه مي دونم :
1- TAdvOfficePager از سري TMS
2- UNiDac از كمپاني DevArt
3- Ehlib
4- TXCalPlannerDatePicker
5- TAnimationCaption
6- TQExport4XLS
7- TPersianCalendar

[SayeyeZohor]

با سلام خدمت دوستان
يك قطعه كد در اين قسمت مي گذارم كه مي تونيم باهاش مولفه هاي يك تابع رو جدا كنيم
مثال :‌ اين يك نمونه از تابع يك برنامه است
InputBox ( "title", "prompt" [, "default" [, "password char" [, width [, height [, left [, top [, timeout [, hwnd]]]]]]]] )

اينم از كدي كه من نوشتم :

type
TStringDynArray = array of String;

var
Form1: TForm1;

implementation

{$R *.dfm}

function Explode(const Separator, S: string; Limit: Integer = 0): TStringDynArray;
var
SepLen: Integer;
F, P: PChar;
ALen, Index: Integer;
begin
SetLength(Result, 0);
if (S = '') or (Limit < 0) then Exit;
if Separator = '' then
begin
SetLength(Result, 1);
Result[0] := S;
Exit;
end;
SepLen := Length(Separator);
ALen := Limit;
SetLength(Result, ALen);

Index := 0;
P := PChar(S);
while P^ <> #0 do
begin
F := P;
P := AnsiStrPos(P, PChar(Separator));
if (P = nil) or ((Limit > 0) and (Index = Limit - 1)) then P := StrEnd(F);
if Index >= ALen then
begin
Inc(ALen, 5);
SetLength(Result, ALen);
end;
SetString(Result[Index], F, P - F);
Inc(Index);
if P^ <> #0 then Inc(P, SepLen);
end;
if Index < ALen then SetLength(Result, Index);
end;



procedure TForm1.Button1Click(Sender: TObject);
var
St, FnName: string;
res: TStringDynArray;
I: Integer;
begin
St := Label1.Caption;

St := Trim(St);
WHILE Copy(St, 1, 1) <> '(' DO
BEGIN
FnName := FnName + Copy(St, 1, 1);
Delete(St, 1, 1);
END;
Delete(St, 1, 1);
St := Trim(St);
ShowMessage(FnName);

St := StringReplace(St, '(', '', [rfReplaceAll, rfIgnoreCase]);
St := StringReplace(St, ')', '', [rfReplaceAll, rfIgnoreCase]);
St := StringReplace(St, '[', '', [rfReplaceAll, rfIgnoreCase]);
St := StringReplace(St, ']', '', [rfReplaceAll, rfIgnoreCase]);
ShowMessage(st);

//--
res := Explode(',', St);
FOR I := 0 TO Length(res)-1 DO ShowMessage(res[I]);

end;

[SayeyeZohor]

use the Microsoft Speech API
تبديل متن به گفتار با استفاده از تابع API ويندوز


uses Comobj;

procedure TForm1.Button1Click(Sender: TObject);
var
voice: OLEVariant;
begin
voice := CreateOLEObject('SAPI.SpVoice');
voice.Speak('Hello World!', 0);
end;

[SayeyeZohor]

فعال سازي كردن صداي ويندوز مانند اخطار ، ايراد و ...


uses Windows;

procedure PlayBeep(ActionType: TMsgDlgType);
var mb: dWord;
begin
case ActionType of
mtInformation: mb := MB_ICONASTERISK; //SystemAsterisk
mtWarning: mb := MB_ICONEXCLAMATION; //SystemExclamation
mtError: mb := MB_ICONHAND; //SystemHand
mtConfirmation: mb := MB_ICONQUESTION; //SystemQuestion
mtCustom: mb := MB_OK; //SystemDefault
else
mb:= $0FFFFFFFF; //Standard beep using the computer speaker
end;
MessageBeep(mb);
end;




PlayBeep(mtWarning);

[SayeyeZohor]

فعال يا غير فعال كردن صداي Beep سيستم
اين يكي از مشكلات دوستان بود كه رفع شد


روش اول :
غير فعال كردن

//Disable system beep
SystemParametersInfo(SPI_SETBEEP, 0, nil, SPIF_SENDWININICHANGE);


فعال كردن

//Enable system beep
SystemParametersInfo(SPI_SETBEEP, 1, nil, SPIF_SENDWININICHANGE);



روش دوم :

// Either disable the Beep in the OnKeyPress handler:
// Unterdrücke den Beep-Ton entweder im OnKeyPress Ereignis:

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
if key = #13 then // #13 = Return
begin
key := #0;
// Code...
end;
end;



روش سوم :

// Or in the OnKeyDown-Handler:
// Oder im OnKeyDown Ereignis:

procedure TForm1.Edit1KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
var
Mgs: TMsg;
begin
if Key = VK_RETURN then
begin
PeekMessage(Mgs, 0, WM_CHAR, WM_CHAR, PM_REMOVE);
// Code...
end;



روش هاي غيرفعال كردن به صورت دستي :
Turn Off the Annoying Windows XP System Beeps (http://www.howtogeek.com/howto/windows/turn-off-the-annoying-windows-xp-system-beeps/)

How to Disable System Beep in Windows 7 (http://www.7tutorials.com/how-disable-system-beep-windows-7)

Disable system beeps (http://en.kioskea.net/faq/2351-disable-system-beeps)

[SayeyeZohor]

تشخيص اينكه كليد اينتر فشرده شده جزء كليد هاي ماشين حساب كيبورد است يا خير؟


interface
... private
procedure WMKeyDown(var Message: TWMKeyDown) ; message CM_DIALOGKEY;

implementation
...
procedure TForm1.WMKeyDown(var Message: TWMKeyDown) ;
begin
inherited;
case Message.CharCode of
VK_RETURN: // ENTER pressed
if (Message.KeyData and $1000000 <> 0) then
// Test bit 24 of lParam
ShowMessage('ENTER on numeric keypad')
else
ShowMessage('ENTER on Standard keyboard') ;
end;
end;

[SayeyeZohor]

uses MMSystem;
//فعال كردن beep سيستم به صورت متوالي
sndPlaySound('C:\Windows\Media\ding.wav', SND_NODEFAULT Or SND_ASYNC Or SND_LOOP);

//غير فعال كردن beep سيستم
sndPlaySound(nil, 0); // Stops the sound

[SayeyeZohor]

فانكشن ساخت فرم دايناميك :

FUNCTION B_CreateForm(Var FName: TForm; FrmCaption: string;
Const FrmAutoSize : Boolean = False;
FrmBiDiMode : TBiDiMode = bdLeftToRight;
FrmBorderIcons : TBorderIcons = [biSystemMenu, biMinimize, biMaximize];
FrmBorderStyle : TFormBorderStyle = bsSizeable;
FrmBorderWidth : TBorderWidth = 0;
FrmClientHeight : Integer = -1;
FrmClientWidth : Integer = -1;
FrmColor : TColor = clBtnFace;
FrmEnabled : Boolean = True;
FrmFontCharset : TFontCharset = DEFAULT_CHARSET;
FrmFontColor : TColor = clWindowText;
FrmFontHeight : Integer = -11;
FrmFontName : TFontName = 'Tahoma';
FrmFontSize : Integer = 8;
FrmFontStyle : TFontStyles = [];
FrmFormStyle : TFormStyle = fsNormal;
FrmHeight : Integer = -1;
FrmHint : string = '';
FrmKeyPreview : Boolean = False;
FrmLeft : Integer = 0;
FrmPopupMenu : TPopupMenu = nil;
FrmPosition : TPosition = poDefaultPosOnly;
FrmShowHint : Boolean = False;
FrmTag : Integer = 0;
FrmTop : Integer = 0;
FrmVisible : Boolean = False;
FrmWidth : Integer = -1;
FrmWindowState : TWindowState = wsNormal;
FrmTransparentColor : Boolean = False;
FrmTransparentColorValue : TColor = clBlack;
FrmPrintScale : TPrintScale = poProportional;
FrmScaled : Boolean = True;
FrmMarginsBottom : TMarginSize = 3;
FrmMarginsLeft : TMarginSize = 3;
FrmMarginsRight : TMarginSize = 3;
FrmMarginsTop : TMarginSize = 3;
FrmMenu : TMainMenu = nil;
FrmPaddingBottom : TMarginSize = 0;
FrmPaddingLeft : TMarginSize = 0;
FrmPaddingRight : TMarginSize = 0;
FrmPaddingTop : TMarginSize = 0;
FrmParentBiDiMode : Boolean = True;
FrmParentCustomHint : Boolean = True;
FrmParentFont : Boolean = False;
FrmPixelsPerInch : Integer = 96;
FrmActiveControl : TWinControl = nil;
FrmAlignWithMargins : Boolean = False;
FrmAlphaBlend : Boolean = False;
FrmAlphaBlendValue : Byte = 255;
FrmAnchors : TAnchors = [akLeft, akTop];
FrmAutoScroll : Boolean = False
): TForm;
BEGIN
FName := TForm.Create(nil);
WITH FName DO
BEGIN
Caption := FrmCaption;
AutoSize := FrmAutoSize;
BiDiMode := FrmBiDiMode;
BorderIcons := FrmBorderIcons;
BorderStyle := FrmBorderStyle;
BorderWidth := FrmBorderWidth;
IF FrmClientHeight <> -1 THEN ClientHeight := FrmClientHeight;
IF FrmClientWidth <> -1 THEN ClientWidth := FrmClientWidth;
Color := FrmColor;
Enabled := FrmEnabled;
Font.Charset := FrmFontCharset;
Font.Color := FrmFontColor;
Font.Height := FrmFontHeight;
Font.Name := FrmFontName;
Font.Size := FrmFontSize;
Font.Style := FrmFontStyle;
FormStyle := FrmFormStyle;
IF FrmHeight <> -1 THEN Height := FrmHeight;
Hint := FrmHint;
KeyPreview := FrmKeyPreview;
Left := FrmLeft;
PopupMenu := FrmPopupMenu;
Position := FrmPosition;
ShowHint := FrmShowHint;
Tag := FrmTag;
Top := FrmTop;
Visible := FrmVisible;
IF FrmWidth <> -1 THEN Width := FrmWidth;
WindowState := FrmWindowState;
TransparentColor := FrmTransparentColor;
TransparentColorValue := FrmTransparentColorValue;
PrintScale := FrmPrintScale;
Scaled := FrmScaled;
Margins.Bottom := FrmMarginsBottom;
Margins.Left := FrmMarginsLeft;
Margins.Right := FrmMarginsRight;
Margins.Top := FrmMarginsTop;
Menu := FrmMenu;
Padding.Bottom := FrmPaddingBottom;
Padding.Left := FrmPaddingLeft;
Padding.Right := FrmPaddingRight;
Padding.Top := FrmPaddingTop;
ParentBiDiMode := FrmParentBiDiMode;
ParentCustomHint := FrmParentCustomHint;
ParentFont := FrmParentFont;
PixelsPerInch := FrmPixelsPerInch;
ActiveControl := FrmActiveControl;
AlignWithMargins := FrmAlignWithMargins;
AlphaBlend := FrmAlphaBlend;
AlphaBlendValue := FrmAlphaBlendValue;
Anchors := FrmAnchors;
AutoScroll := FrmAutoScroll
END;
Result := FName;
END;




var
FSyntax: TForm;
begin
TRY
FSyntax := B_CreateForm(FSyntax, 'FSyntax');
FSyntax.ShowModal;
FINALLY
FSyntax.Free;
END;




FSyntax := B_CreateForm(FSyntax, 'FSyntax', False, bdLeftToRight, [biSystemMenu, biMinimize, biMaximize], bsSizeable, 0, -1, -1, clBtnFace, True, DEFAULT_CHARSET, clWindowText,
-11, 'Tahoma', 8, [], fsNormal, -1, '', False, 0, nil, poDefaultPosOnly, False, 0, 0, False, -1, wsNormal, False, clBlack, poProportional, True,
3, 3, 3, 3, nil, 0, 0, 0, 0, True, True, False, 96, nil, False, False, 255, [akLeft, akTop], False);



FSyntax := B_CreateForm(FSyntax,
{Caption}'FSyntax',
{AutoSize}False,
{BiDiMode}bdLeftToRight,
{BorderIcons}[biSystemMenu, biMinimize, biMaximize], {BorderStyle}bsSizeable,
{BorderWidth}0,
{ClientHeight}662, {ClientWidth}929,
{Color}clBtnFace,
{Enabled}True,
{Font.Charset}DEFAULT_CHARSET, {Font.Color}clWindowText, {Font.Height}-11, {Font.Name}'Tahoma', {Font.Size}8, {Font.Style}[],
{FormStyle}fsNormal,
{Height}-1, {Hint}'',
{KeyPreview}False,
{Left}0, {PopupMenu}nil,
{Position}poDesktopCenter,
{ShowHint}False,
{Tag}0, {Top}0,
{Visible}False,
{Width}-1,
{WindowState}wsNormal,
{TransparentColor}False, {TransparentColorValue}clBlack,
{PrintScale}poProportional,
{Scaled}True,
{Margins.Bottom}3, {Margins.Left}3, {Margins.Right}3, {Margins.Top}3,
{Menu}nil,
{Padding.Bottom}0, {Padding.Left}0, {Padding.Right}0, {Padding.Top}0,
{ParentBiDiMode}True, {ParentCustomHint}True, {ParentFont}False,
{PixelsPerInch}96,
{ActiveControl}nil,
{AlignWithMargins}False,
{AlphaBlend}False, {AlphaBlendValue}255,
{Anchors}[akLeft, akTop],
{AutoScroll}False
);



اگه ممكنه دوستان در بهبود ابن فانكشن كمك كنند
شايد كلاً راه غلطي باشه
ممنون

[BORHAN TEC]

سلام

اگه ممكنه دوستان در بهبود ابن فانكشن كمك كنند
شايد كلاً راه غلطي باشه
اگه بخواهم تابعی برای این کار طراحی کنم یک رکورد خاص تعریف می کنم که کاربر مشخصات را در نمونه ای از آن رکورد تنظیم کند و تابعی که نوشتی رو طوری می نوشتم که به جای این همه پارامتر مختلف فق یک پارامتر دریافت کنه که اون هم از نوی رکوردی که گفتم باشه تا این همه شلوغ کاری نشه و قابل فهم تر باشه. توی اون تابعی که نوشتی اگر ما بخواهیم فقط پارامتر X ام را تغییر دهیم باید به پارامتر های قبلی هم مقدار بدهیم که این مورد کمی کار رو سخت می کنه(البته در زبانی مثل VB این مشکل وجود ندارد). چنین مشکلی با راه حلی که پیشنهاد کردم کاملاً قابل حل است.
موفق باشید...

[SayeyeZohor]

Type
TPropertyOfForm = Record
FName : TForm;
FrmCaption : string;
FrmAutoSize : Boolean;
FrmBiDiMode : TBiDiMode;
FrmBorderIcons : TBorderIcons;
FrmBorderStyle : TFormBorderStyle;
FrmBorderWidth : TBorderWidth;
FrmClientHeight : Integer;
FrmClientWidth : Integer;
FrmColor : TColor;
FrmEnabled : Boolean;
FrmFontCharset : TFontCharset;
FrmFontColor : TColor;
FrmFontHeight : Integer;
FrmFontName : TFontName;
FrmFontSize : Integer;
FrmFontStyle : TFontStyles;
FrmFormStyle : TFormStyle;
FrmHeight : Integer;
FrmHint : string;
FrmKeyPreview : Boolean;
FrmLeft : Integer;
FrmPopupMenu : TPopupMenu;
FrmPosition : TPosition;
FrmShowHint : Boolean;
FrmTag : Integer;
FrmTop : Integer;
FrmVisible : Boolean;
FrmWidth : Integer;
FrmWindowState : TWindowState;
FrmTransparentColor : Boolean;
FrmTransparentColorValue : TColor;
FrmPrintScale : TPrintScale;
FrmScaled : Boolean;
FrmMarginsBottom : TMarginSize;
FrmMarginsLeft : TMarginSize;
FrmMarginsRight : TMarginSize;
FrmMarginsTop : TMarginSize;
FrmMenu : TMainMenu;
FrmPaddingBottom : TMarginSize;
FrmPaddingLeft : TMarginSize;
FrmPaddingRight : TMarginSize;
FrmPaddingTop : TMarginSize;
FrmParentBiDiMode : Boolean;
FrmParentCustomHint : Boolean;
FrmParentFont : Boolean;
FrmPixelsPerInch : Integer;
FrmActiveControl : TWinControl;
FrmAlignWithMargins : Boolean;
FrmAlphaBlend : Boolean;
FrmAlphaBlendValue : Byte;
FrmAnchors : TAnchors;
FrmAutoScroll : Boolean;
end;

[Ananas]

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

procedure TForm1.Button1Click(Sender: TObject);
var
f : TForm;
b : TButton;
begin
f := TForm.Create(nil);
f.Color := $00808000;
f.Caption := 'مای فرم';
f.BorderStyle := bsSizeToolWin;
b := TButton.Create(f);
b.Parent := f;
b.Caption := 'مای باتن';
f.ShowModal;
f.Free;
end;

اصلا نیازی به تابع هم نیست ولی میتونه اینطور باشه:

function CreateFreeForm(AOwner: TComponent):TForm;
begin
Result := TForm.Create(AOwner);
end;

[SayeyeZohor]

دو تا تابع ساده برای تبدیل تاریخ میلادی به شمسی (http://barnamenevis.org/showthread.php?289978-%D8%AF%D9%88-%D8%AA%D8%A7-%D8%AA%D8%A7%D8%A8%D8%B9-%D8%B3%D8%A7%D8%AF%D9%87-%D8%A8%D8%B1%D8%A7%DB%8C-%D8%AA%D8%A8%D8%AF%DB%8C%D9%84-%D8%AA%D8%A7%D8%B1%DB%8C%D8%AE-%D9%85%DB%8C%D9%84%D8%A7%D8%AF%DB%8C-%D8%A8%D9%87-%D8%B4%D9%85%D8%B3%DB%8C)

[SayeyeZohor]

استخراج آيكن يك فايل اجرايي و قراردادن آن در ImageList :


Uses CommCtrl




procedure ExtractIconFileToImageList(ImageList: TImageList; const Filename: string);
var
FileInfo: TShFileInfo;
begin
if FileExists(Filename) then
begin
FillChar(FileInfo, SizeOf(FileInfo), 0);
SHGetFileInfo(PChar(Filename), 0, FileInfo, SizeOf(FileInfo), SHGFI_ICON or SHGFI_SMALLICON);
if FileInfo.hIcon <> 0 then
begin
ImageList_AddIcon(ImageList.Handle, FileInfo.hIcon);
DestroyIcon(FileInfo.hIcon);
end;
end;
end;

[SayeyeZohor]

تشخيص نصب بودن نسخه هاي دلفي و نسخه هاي دات نت فريمورك :

مرحله اول:

unit SelectDelphiVersion;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ImgList, ComCtrls, Vcl.ExtCtrls;

type
TFrmSelDelphiVer = class(TForm)
Label1: TLabel;
ImageList1: TImageList;
ListViewIDEs: TListView;
Panel1: TPanel;
ButtonOk: TButton;
ButtonCancel: TButton;
private
{ Private declarations }
public
{ Public declarations }
procedure LoadDelphiInstalledVersions;
procedure LoadNetFrameworkInstalledVersions;
end;


implementation
{$R *.dfm}

uses
Registry, CommCtrl, ShellAPI;

type
TDelphiVersions =
(
Delphi4,
Delphi5,
Delphi6,
Delphi7,
Delphi8,
Delphi2005,
Delphi2006,
Delphi2007,
Delphi2009,
Delphi2010,
DelphiXE,
DelphiXE2,
DelphiXE3
);

const
DelphiVersionsNames: array[TDelphiVersions] of string = (
'Delphi 4',
'Delphi 5',
'Delphi 6',
'Delphi 7',
'Delphi 8',
'BDS 2005',
'BDS 2006',
'RAD Studio 2007',
'RAD Studio 2009',
'RAD Studio 2010',
'RAD Studio XE',
'RAD Studio XE2',
'RAD Studio XE3'
);

DelphiRegPaths: array[TDelphiVersions] of string = (
'\Software\Borland\Delphi\4.0',
'\Software\Borland\Delphi\5.0',
'\Software\Borland\Delphi\6.0',
'\Software\Borland\Delphi\7.0',
'\Software\Borland\BDS\2.0',
'\Software\Borland\BDS\3.0',
'\Software\Borland\BDS\4.0',
'\Software\Borland\BDS\5.0',
'\Software\CodeGear\BDS\6.0',
'\Software\CodeGear\BDS\7.0',
'\Software\Embarcadero\BDS\8.0',
'\Software\Embarcadero\BDS\9.0',
'\Software\Embarcadero\BDS\10.0'
);





type
TNetFrameworkVersions =
(
NetFramework1_0,
NetFramework1_1,
NetFramework2_0,
NetFramework3_0,
NetFramework3_5,
NetFramework4,
NetFramework4_0
);

const
NetFrameworkVersionsNames: array[TNetFrameworkVersions] of string = (
'.NetFramework v1.0',
'.NetFramework v1.1.4322',
'.NetFramework v2.0.50727',
'.NetFramework v3.0',
'.NetFramework v3.5',
'.NetFramework v4',
'.NetFramework v4.0'
);

NetFrameworkRegPaths: array[TNetFrameworkVersions] of string = (
'\SOFTWARE\Microsoft\.NETFramework\policy\v1.0',
'\SOFTWARE\Microsoft\NET Framework Setup\NDP\v1.1.4322',
'\SOFTWARE\Microsoft\NET Framework Setup\NDP\v2.0.50727',
'\SOFTWARE\Microsoft\NET Framework Setup\NDP\v3.0',
'\SOFTWARE\Microsoft\NET Framework Setup\NDP\v3.5',
'\SOFTWARE\Microsoft\NET Framework Setup\NDP\v4',
'\SOFTWARE\Microsoft\NET Framework Setup\NDP\v4.0'
);


function RegKeyExists(const RegPath: string;const RootKey :HKEY): Boolean;
var
Reg: TRegistry;
begin
try
Reg := TRegistry.Create;
try
Reg.RootKey := RootKey;
Result := Reg.KeyExists(RegPath);
finally
Reg.Free;
end;
except
Result := False;
end;
end;
function RegReadStr(const RegPath, RegValue: string; var Str: string; const RootKey :HKEY): Boolean;
var
Reg: TRegistry;
begin
try
Reg := TRegistry.Create;
try
Reg.RootKey := RootKey;
Result := Reg.OpenKey(RegPath, True);
if Result then Str := Reg.ReadString(RegValue);
finally
Reg.Free;
end;
except
Result := False;
end;
end;
procedure ExtractIconFileToImageList(ImageList: TImageList; const Filename: string);
var
FileInfo: TShFileInfo;
begin
if FileExists(Filename) then
begin
FillChar(FileInfo, SizeOf(FileInfo), 0);
SHGetFileInfo(PChar(Filename), 0, FileInfo, SizeOf(FileInfo), SHGFI_ICON or SHGFI_SMALLICON);
if FileInfo.hIcon <> 0 then
begin
ImageList_AddIcon(ImageList.Handle, FileInfo.hIcon);
DestroyIcon(FileInfo.hIcon);
end;
end;
end;



{ TFrmSelDelphiVer }
procedure TFrmSelDelphiVer.LoadDelphiInstalledVersions;
Var
item : TListItem;
DelphiComp : TDelphiVersions;
FileName : string;
ImageIndex : Integer;
begin
for DelphiComp := Low(TDelphiVersions) to High(TDelphiVersions) do
begin
if RegKeyExists(DelphiRegPaths[DelphiComp], HKEY_CURRENT_USER) then
begin
if RegReadStr(DelphiRegPaths[DelphiComp], 'App', FileName, HKEY_CURRENT_USER) and FileExists(FileName) then
begin
item := ListViewIDEs.Items.Add;
item.Caption := DelphiVersionsNames[DelphiComp];
item.SubItems.Add(FileName);
ExtractIconFileToImageList(ImageList1, Filename);
ImageIndex := ImageList1.Count - 1;
item.ImageIndex := ImageIndex;
end;
end;
end;
end;


procedure TFrmSelDelphiVer.LoadNetFrameworkInstalledVersions ;
Var
item : TListItem;
NetFrameworkComp : TNetFrameworkVersions;
FileName : string;
ImageIndex : Integer;
begin
for NetFrameworkComp := Low(TNetFrameworkVersions) to High(TNetFrameworkVersions) do
begin
if RegKeyExists(NetFrameworkRegPaths[NetFrameworkComp], HKEY_LOCAL_MACHINE) then
begin
if RegReadStr(NetFrameworkRegPaths[NetFrameworkComp], 'InstallPath', FileName, HKEY_LOCAL_MACHINE) {and FileExists(FileName)} then
begin
item := ListViewIDEs.Items.Add;
item.Caption := NetFrameworkVersionsNames[NetFrameworkComp];
item.SubItems.Add(FileName);
ExtractIconFileToImageList(ImageList1, Filename);
ImageIndex := ImageList1.Count - 1;
item.ImageIndex := ImageIndex;
end;
end;
end;
end;

end.

[SayeyeZohor]

مرحله يا فرم دوم :

unit UnitTest;

interface

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

type
TForm9 = class(TForm)
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form9: TForm9;

implementation

uses
ComCtrls,
SelectDelphiVersion;

{$R *.dfm}

procedure TForm9.Button1Click(Sender: TObject);
var
Frm : TFrmSelDelphiVer;
item : TListItem;
DelphiPath : string;
begin
Frm := TFrmSelDelphiVer.Create(Self);
try
Frm.LoadDelphiInstalledVersions;
if Frm.ListViewIDEs.Items.Count=0 then
ShowMessage('Delphi is not installed in this system')
else
if Frm.ShowModal = mrOk then
begin
item:=Frm.ListViewIDEs.Selected;
if Assigned(item) then
begin
DelphiPath :=ExtractFilePath(item.SubItems[0]);
ShowMessage(DelphiPath);
end;
end;
finally
Frm.Free;
end;
end;



procedure TForm9.Button2Click(Sender: TObject);
var
Frm : TFrmSelDelphiVer;
item : TListItem;
NetFrameworkiPath : string;
begin
Frm := TFrmSelDelphiVer.Create(Self);
try
Frm.LoadNetFrameworkInstalledVersions;
if Frm.ListViewIDEs.Items.Count = 0 then
ShowMessage('NetFramework is not installed in this system')
else
if Frm.ShowModal = mrOk then
begin
item := Frm.ListViewIDEs.Selected;
if Assigned(item) then
begin
NetFrameworkiPath := ExtractFilePath(item.SubItems[0]);
ShowMessage(NetFrameworkiPath);
end;
end;
finally
Frm.Free;
end;
end;

end.

[SayeyeZohor]

uses
ShellApi;

function CopyDir(const fromDir, toDir: string): Boolean;
var
fos: TSHFileOpStruct;
begin
ZeroMemory(@fos, SizeOf(fos));
with fos do
begin
wFunc := FO_COPY;
fFlags := FOF_FILESONLY;
pFrom := PChar(fromDir + #0);
pTo := PChar(toDir)
end;
Result := (0 = ShFileOperation(fos));
end;


function MoveDir(const fromDir, toDir: string): Boolean;
var
fos: TSHFileOpStruct;
begin
ZeroMemory(@fos, SizeOf(fos));
with fos do
begin
wFunc := FO_MOVE;
fFlags := FOF_FILESONLY;
pFrom := PChar(fromDir + #0);
pTo := PChar(toDir)
end;
Result := (0 = ShFileOperation(fos));
end;

function DelDir(dir: string): Boolean;
var
fos: TSHFileOpStruct;
begin
ZeroMemory(@fos, SizeOf(fos));
with fos do
begin
wFunc := FO_DELETE;
fFlags := FOF_SILENT or FOF_NOCONFIRMATION;
pFrom := PChar(dir + #0);
end;
Result := (0 = ShFileOperation(fos));
end;


procedure TForm1.Button1Click(Sender: TObject);
begin
if cCopyDir('d:\download', 'e:\') = True then
ShowMessage('Directory copied.');
end;

[بهروز عباسی]

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

اینم عکس از اجرای برنامه :

102985

موفق باشید.

[دلفــي]

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

اینم عکس از اجرای برنامه :

102985

موفق باشید.




خوبه ولي Send و Recive رو يكي نشون ميده !

[SayeyeZohor]

uses
WinSvc;

function IsAdmin(Host : string = '') : Boolean;
var
H: SC_HANDLE;
begin
if Win32Platform <> VER_PLATFORM_WIN32_NT then
Result := True
else begin
H := OpenSCManager(PChar(Host), nil, GENERIC_READ or GENERIC_WRITE or GENERIC_EXECUTE);
Result := H <> 0;
if Result then
CloseServiceHandle(H);
end;
end;





function IsRunningWithAdminPrivs: Boolean;
begin
var
List: TStringList;
begin
List := TStringList.Create;
try
try
List.Text := 'Sample';
// Use SHGetFolder path to retreive the program files folder
// here is hardcoded for the sake of the example
List.SaveToFile('C:\program files\test.txt');
Result := True;
except
Result := False;
end;
finally
List.Free;
DeleteFile('C:\program files\test.txt');
end;
end;

[SayeyeZohor]

procedure RunAsAdmin(const aFile: string; const aParameters: string = ''; Handle: HWND = 0);
var
sei: TShellExecuteInfo;
begin
FillChar(sei, SizeOf(sei), 0);

sei.cbSize := SizeOf(sei);
sei.Wnd := Handle;
sei.fMask := SEE_MASK_FLAG_DDEWAIT or SEE_MASK_FLAG_NO_UI;
sei.lpVerb := 'runas';
sei.lpFile := PChar(aFile);
sei.lpParameters := PChar(aParameters);
sei.nShow := SW_SHOWNORMAL;

if not ShellExecuteEx(@sei) then
RaiseLastOSError;
end;

[SayeyeZohor]

بدست آوردن شماره سریال فیزیکی هارد دیسکی که برنامه بر روی آن قرار دارد!!! (http://barnamenevis.org/showthread.php?226488-%D8%B3%D9%88%D8%A7%D9%84-%D8%A8%D8%AF%D8%B3%D8%AA-%D8%A2%D9%88%D8%B1%D8%AF%D9%86-%D8%B4%D9%85%D8%A7%D8%B1%D9%87-%D8%B3%D8%B1%DB%8C%D8%A7%D9%84-%D9%81%DB%8C%D8%B2%DB%8C%DA%A9%DB%8C-%D9%87%D8%A7%D8%B1%D8%AF-%D8%AF%DB%8C%D8%B3%DA%A9%DB%8C-%DA%A9%D9%87-%D8%A8%D8%B1%D9%86%D8%A7%D9%85%D9%87-%D8%A8%D8%B1-%D8%B1%D9%88%DB%8C-%D8%A2%D9%86-%D9%82%D8%B1%D8%A7%D8%B1-%D8%AF%D8%A7%D8%B1%D8%AF!!!)

[SayeyeZohor]

unit CollapsePanel;

{************************************************* ***************************
COLLAPSE PANEL ver 1.11 - Copyright (c) Lindsay D'Penha

Disclaimer: This component is freeware so I take no responsibility for any problems or losses that may occur, use at your own risk

This component is freeware, but if you modify anything send me the changes. If you modify the
compenent you may then include your copyright along with the original one.
You are free to distribute this component provided this readme file is not modified or removed from the distribution.
This component cannot be used in a commercial application without my written approval.
i.e. you cannot include this component in an application that you are making money from, without my approval.

Programmer: Lindsay D'Penha
Date Created: 01/10/2001
Date Modified: 01/18/2001

Collapse Panel is a simple drop down panel component.
It has a header and a button to allow it to expand and collapse.

Main Properties
****************
HeaderCaption Set the Headers Caption
AutoClose If True then it will autoclose AutoCloseTime millisecs after the mouse is out of the panel default is false
AutoCloseTime Sets the time after which the the panle will close default is 1500

If Auto Close is true then the collapse button acts as a stay on top button
************************************************** ***************************}

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,Buttons,
ExtCtrls;

const
cCloseUpGovernor = 300; // when the panel reaches this limit, the animation redraws less frequently


type
TCollapsePanel = class(TPanel)
private
{ Private declarations }
FExpandedHeight:Integer;
FCloseUpTimer:TTimer;
FAutoCloseTime:Integer;
FAbout:String;
IsCollapsed:Boolean;
StayOpen:Boolean;
FAutoClose:Boolean;
function ApplyDark(Color: TColor; HowMuch: Byte): TColor;
Procedure PullDown;
Procedure CloseUp;
procedure CloseUpTimerTimer(Sender: TObject);
procedure SetAutoCloseTime(Value:Integer);
procedure CMMouseEnter(var Msg: TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var Msg: TMessage); message CM_MOUSELEAVE;
procedure OnAutoClose(AutoClose:Boolean);
procedure SetAbout(value:String);
procedure setCollapse(value: boolean);
protected
{ Protected declarations }
HeaderPanel:TPanel;
Collapser:TSpeedButton;
function GetHeaderCaption:TCaption;
procedure SetHeaderCaption(Value:TCaption);
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
procedure CollapserClick(Sender: TObject);
Procedure Paint; override;
published
{ Published declarations }
property HeaderCaption:TCaption read GetHeaderCaption write SetHeaderCaption;
property AutoClose:Boolean read FAutoClose write OnAutoClose default False;
property AutoCloseTime:Integer read FAutoCloseTime write SetAutoCloseTime default 1500;
property Collapsed:Boolean read IsCollapsed write setCollapse default False;
property About:String read FAbout Write SetAbout;
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('LDComp', [TCollapsePanel]);
end;

{ TCollapsePanel }

constructor TCollapsePanel.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FAbout:= '(C) Lindsay DPenha (iamlinz@hotmail.com)';

Caption:='';
HeaderPanel:=TPanel.Create(self);
HeaderPanel.Parent:= self;
HeaderPanel.Align:= alTop;
HeaderPanel.Height:= 16;
HeaderPanel.Color:= ApplyDark(Color,100);
HeaderPanel.ParentFont:=True;

FCloseUpTimer:=TTimer.create(self);
FCloseUpTimer.Enabled:=False;
FAutoCloseTime:=1500;
FCloseUpTimer.Interval:=FAutoCloseTime;


Collapser:=TSpeedButton.create(self);
Collapser.Parent:=HeaderPanel;
Collapser.Font.Name:='Courier';
Collapser.Font.Size:=10;
Collapser.Font.Style:=[fsBold];
Collapser.Height:=15;
Collapser.Width:=15;
Collapser.Top:= 0;
Collapser.Left:= 0;
Collapser.Caption:='-';
Collapser.Flat:=True;



Collapser.OnClick:= CollapserClick;
FCloseUpTimer.OnTimer:= CloseUpTimerTimer;
FExpandedHeight:=Height;

IsCollapsed:=False;
Collapsed:=False;
StayOpen:=False;
AutoClose:=False;

Caption:= '';
end;


procedure TCollapsePanel.setCollapse(value:boolean);
begin
if value<>IsCollapsed then
begin
if value then
CloseUp
else
PullDown;
end;
end;

procedure TCollapsePanel.CollapserClick(Sender: TObject);
begin
if FAutoClose then
StayOpen:=Collapser.Down
else
begin
if IsCollapsed then
PullDown
else
CloseUp;
end;
end;

Function TCollapsePanel.ApplyDark(Color:TColor; HowMuch:Byte):TColor;
Var r,g,b:Byte;
Begin
Color:=ColorToRGB(Color);
r:=GetRValue(Color);
g:=GetGValue(Color);
b:=GetBValue(Color);
if r>HowMuch then r:=r-HowMuch else r:=0;
if g>HowMuch then g:=g-HowMuch else g:=0;
if b>HowMuch then b:=b-HowMuch else b:=0;
result:=RGB(r,g,b);
End;

procedure TCollapsePanel.Paint;
begin
inherited;
HeaderPanel.Color:= ApplyDark(Color,20);
end;

function TCollapsePanel.GetHeaderCaption: TCaption;
begin
with HeaderPanel do
begin
result:= HeaderPanel.Caption;
end;
end;

procedure TCollapsePanel.SetHeaderCaption(Value: TCaption);
begin
with HeaderPanel do
begin
if Value<>Caption then
Caption:=Value;
end;
end;

procedure TCollapsePanel.CMMouseEnter(var Msg: TMessage);
begin
if FAutoClose then
begin
FCloseUpTimer.Enabled:=False;
if IsCollapsed then PullDown;
end;
end;

procedure TCollapsePanel.CMMouseLeave(var Msg: TMessage);
begin
if FAutoClose = False then exit;
if IsCollapsed then exit;
if StayOpen then exit;
FCloseUpTimer.Enabled:=True;
end;

procedure TCollapsePanel.CloseUp;
var I:Integer;
begin
if not IsCollapsed then
begin
IsCollapsed:=True;
FExpandedHeight:=Height;
for I:= FExpandedHeight downto (HeaderPanel.Height+1) do // Simple Scrolling effect
begin
if FExpandedHeight < cCloseUpGovernor then
Height:=I
else if(I mod 4)=0 then
begin
Height:=I;
end;
end;
Height:=HeaderPanel.Height+1;
Collapser.Caption:='+';
end;
invalidate;
end;

procedure TCollapsePanel.PullDown;
var I:Integer;
begin
if IsCollapsed then
begin
IsCollapsed:=False;
for I:= (HeaderPanel.Height+1) to FExpandedHeight do // Simple logic for Scrolling effect, with diff accelerations
begin
if FExpandedHeight < 300 then
Height:=I
else if (I mod 4)=0 then // if height larger than 300 then write to screen only when mod =0 is true, works like a step it in the for loop
Height:=I;
end;
Height:= FExpandedHeight; // if the mod didnt get to the final value
Collapser.Caption:='-';
end;
invalidate;
end;

procedure TCollapsePanel.CloseUpTimerTimer;
begin
CloseUp;
FCloseUpTimer.Enabled:=False;
end;

procedure TCollapsePanel.OnAutoClose(AutoClose: Boolean);
begin
if FAutoClose<>AutoClose then
FAutoClose:= AutoClose;

if AutoClose then
begin
Collapser.GroupIndex:= -1;
Collapser.AllowAllUp:=True;
end
else
begin
Collapser.GroupIndex:=0;
Collapser.AllowAllUp:=False;
end;
end;


procedure TCollapsePanel.SetAutoCloseTime(Value: Integer);
begin
FAutoCloseTime:=Value;
FCloseUpTimer.Interval:=FAutoCloseTime;
end;


procedure TCollapsePanel.SetAbout(value: String);
begin
FAbout:= '(C) Lindsay DPenha (iamlinz@hotmail.com)';
end;

end.

[SayeyeZohor]

Download images from the internet to a stream



uses wininet ;

function LoadImage ( url: string ): TMemoryStream;
var
hInternet, hConnect: pointer;
dwBytesRead, i, L: cardinal;
sTemp: AnsiString;
begin
Result: = TMemoryStream.Create;
HINTERNET: InternetOpen = ( 'MyApp' , INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0 );
try
if Assigned (HINTERNET) then
begin
hConnect: = InternetOpenUrl (hInternet, PChar (url), nil, 0 , 0 , 0 );
if Assigned (hConnect) then
try
I: = 1 ;
repeat
SetLength (sTemp, L + i);
if not InternetReadFile (hConnect, @ sTemp , sizeof (L), dwBytesRead) then
Break ;
inc (i, dwBytesRead);
until dwBytesRead = 0 ;
finally
InternetCloseHandle (hConnect);
end;
end;
finally
InternetCloseHandle (hInternet);
end;
Result.Write (sTemp [ 1 ], Length (sTemp));
Result.Position: = 0 ;
end;

[SayeyeZohor]

This function is used to download images from a variety of formats: BMP , gif , png , jpeg , tiff , ico , etc. no problem. The main thing you need to do is save images with the same extensions that they were then to avoid confusion. I kept the names of the files that are taking direct links to pictures. To get the name of the file Url use function

function ExtractUrlFileName ( const AURL: string ): string;
var
I: Integer;
begin
I: = LastDelimiter ('/', AURL);
Result: = Copy (AURL, I + 1, Length (AUrl) - (i));
end;

[SayeyeZohor]

The module main window Minesweeper 2002



unit saper_l;
interface
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, Menus, StdCtrls, OleCtrls, HHOPENLib_TLB;
type
TForm1 = class(TForm)
MainMenul: TMainMemi;
N1: TMemiltem;
N2: TMemiltem;
N3: TMenuItem;
N4: TMenuItem;
Hhopen1: THhopen;
procedure FormlCreate(Sender: TObject);
procedure FormlPaint(3ender; TObject);
procedure FomlMouseDovmf Sender: TObject; Button: TMouseButton,-
Shift: TShiftState( X, Y: Integer);
procedure NIClick(Sender: TObject);
procedure K4Click(Sender: TObject);
procedure N3Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForml;
implementation
uses saper_2;
{$R*.DFM}
const
MR = 10; // кол-во клеток по вертикали
МС = 10; // кол-во клеток по горизонтали
NМ = 10; // кол-во мин
W = 40; // ширина клетки поля
Н = 40; // аысога клетки поля
var
pole: array(0..MR+1, 0.. MC+1] of integer; // минное попе
// значение элемента массива:
// 0..8 — количество мин в соседний клетках
// 9 — в клетке мина
// 100,.109 — клетка открыта
// 200..209 — в клетку поставлен флаг
nMin : integer; // кол-во найденных мин
nFlag : integer; // кол-во поставленных флагов
status : integer; //0 — начало игры; I - игра; 2 - результат
Procedure NewGameO; forward; // генерирует новое поле
Procedure ShowPole(Canvas : TCanvas; status : integer); forward;
//Показывает поле
Procedure Kletka(Canvas : TCanvas; row, col, status ; integer); forward;
// выводит содержимое клетки
Procedure Open(row, col : integer); forward;// открывает текущую и все соседние клетки, в которых нет мин
Procedure MinafCanvas : TCanvas; х, у : integer); forward; // рисует мину
Procedure Flag(Canvas : TCanvas; x, у : integer); forward;// рисует флаг
// выводит на экран содержимое клетки
Procedure Kletka(Canvas : TCanvas; row, col, status : integer);
var
х,у : integer; // коорлинаты области вывода
begin
х := (col-1)* W + 1;
у := (row-1)* H + 1;
if status = 0 then
begin
Canvas.Brush.Color := clLtGray;
Canvas,Rectangle(x-1,y-1,x+W,y+H);
exit;
end;
if Pole[row,col] < 100 then
begin
Canvas.Brush.Color := clLtGray; // неоткрытые — серые
Canvas.Rectangle(x-1,y-1,x+W,у+Н);
// есл Hipa завершена (status = 2), то показать мины
if (status = 2| and (Pole[row,col] = 9)
then Mina(Canvas, x, y);
exit;
end;
// открываем клетку
Canvas.Brush.Color := clWhite; // открытые белые
Canvas.Rectangle(x-1,y-1,x+W,y+H);
if (Pole trow,col] = 100)
then exit; // клетка открыта, но она пустая
if (Pole[row,col] >= 101) and (Pole[row,col] <= 108) then
begin
Canvas.Font.Size := 14;
Canvas.Font.Color := clBlue;
Canvas.TextOut(x+3,y+2,IntToStr(Pole[row,col] -1001);
exit;
end;
if (Pole[row,colj >= 200) then
Flag(Canvas, x, y);
if (Pole[row,col] = 109) then // на этой мине подорвались!
begin
Canvas.Brush.Color := clRed;
Canvas.Rectangle(x-1,y-1,x+W,y+H);
end;
if ((Pole[row,col] mod 10) = 9) and (status = 2) then
Mina(Canvas, x, y);
end;
// показывает поле
Procedure ShowPole(Canvas ; TCanvas; status : integer);
var
row,col : integer;
begin
for row := 1 to MR do
for col := 1 to MC do
Kletka(Canvas, row, col, status);
end;
// рекурсивная функция открывает текущую и все соседние
// клетки, в которых нет мин
Procedure Open(row, col : integer);
begin
if Pole[row,col] = 0 then
begin
Pole[row,col] ;= 100;
KletkafForml.Canvas, row,col, 1);
Open(row,col-lJ;
Open(row-l,col];
Open(row,col+1];
Open(row+l,col];
// примыкающие диагонально
Open(row-1,col-l|;
Open(row-1,col+1) ;
Open(row+1,col-l);
Open(row+1,col+1);
end
else
if (Pole[row,col] < 100] and (Pole[row,col] <> -3) then
begin
Pole[row,col] := Pole[row,col] + 100;
Kletka(Forml.Canvas, row, col, 1);
end;
end;
// новая игра — генерирует новое поле
procedure NewGame();
var
row,col : integer; // координаты клетки
n : integer; // количество поставленных мин
k : integer; // кол-во мин в соседних клетках
begin
// очистим эл-ты массива, соответствующее клеткам
// игрового поля
for row :=1 to MR do
for col :=1 to MC do
Pole trow,col] := 0;
// расставим мины
Randomized; // инициализация ГСЧ
n :=0; // кол-во мин
repeat
row := Random(MR) + 1;
col := Random(MC) + 1;
it (Pole[row,col] о Э) then
begin
Pole[row,col] := 9;
n := n+1;
end;
until (n = NM);
// для каждой клетки вычислим
// кол-во мин в соседних клетках
for row := 1 to MR do
for col := 1 to MC do
if (Pole£row,col] <> 9) then
begin
k :=0 ;
if Pole[row-l,col-l] = 9 then inc(k);
if Pole[row-l,col] = 9 then inc(k);
if Pole[row-l,col+l] = 9 then inc(k);
if Pole[row,col-l] = 9 then inc(k);
if Pole[row,col+l] - 9 then inc(k);
if Pole[row-t-l,col-1! = 9 then inc(k);
if Pole[row+l,col] = 9 then inc(k);
if Pole[row+l,col+l] = 9 then inc(k);
Pole[tow,col] := k;
end;
status := 0; // начало игры
nMin := 0; // нет обнаруженных мин
nFlag := 0; // нет флагов
end;
// рисуем мину
Procedure Mina(Canvas : TCanvas; x, у : integer);
begin
with Canvas do
begin
Brush.Color := clGreen;
Pen.Color :- clBlack;
Rectangle(x+16,y+26,x+24,y+30);
Rectangle(x+8,y+30,x+16,y+34);
Rectangle(x+24,y+30,x+32,y+34);
Pie(x+6,y+28,x+34,y+44,x+34,y+36,x+6,y+36)
MoveTo(x+12,y+32); LineTo(x+26,y+32);
MoveTo(x+8,y+36|; LineTo(x+32,y+36);
MoveTo(x+20,y+22); LineTo(x+20,y+26);
MoveTo(x+8, y+30); LineTo(x+6,y+28);
MoveTo(x+32,y+30); LineTo(x+34,yi-28);
end;
end;
// рисуем флаг
Procedure Flag(Canvas : TCanvas; x, у ; integer);
var
p : array 10..3] of TPoint; // координаты точек флажке
m : array [0..4] of TPoint; // буква М
begin
// зададим координаты точек флажка
р[0].х =х+4; р[0].у:=у+4;
р[1].х =х+30; р[1].у:=у+12;
р[2].х =х+4; р[2].у:=у+20;
р[3].х =х+4; р[3].у:=у+36; // нижняя точка древка
m[0].х =х+4; m[0].у:=у+14;
m[1].х =х+8; m[1].у:=у+8;
m[2].х =х+10; m[2].у:=у+10;
m[3].х =х+12; m[3].у:=у+8;
m[4],x:=x+12; m[4].у:=у+14;
with Canvas do
begin
// установим цвет кисти и карандаша
Brush.Color := clRed;
Pen.Color := clRed;
Polygon(p); // флажок
// древко
Pen.Color := clBlack;
MoveTo(p[0].x, p[0].y);
LineTo(p[3].x, p[3].y);
// буква М
Pen.Color : = clWhite;
Polyline(m);
Pen.Color := clBlack;
end;
end;
// выбор из меню ? команды О программе
procedure TForml.mClick(Sender: TObject);
begin
AboutForm.Top := Trunc(Forml.Top + Forml.Height/2— AboutForm.Height/2);
AboutForm.Left := Trunc(Forml.Left +Forml.Width/2- AboutForm.Width/2);
AboutForm.ShowModal;
end;
procedure TForml.FormlCreatefSender: TObject);
var
row,col : integer;
begin
// в неотображаемые эл-гы массива, которые соответствуют
// клеткам по границе игрового поля, запишем число -3.
// это значение используется функцией Open для завершения
// рекурсивного процесса открытия соседних пустых клеток
for row :=0 to MR+1 do
for col :=0 to MC+1 do
Pole[row,col] := -3;
NewGame(); // "разбросать" мины
Forml.ClientHeight := H*MR + 1;
Forml.ClientWidth := W'MC + 1;
end;
// нажатие кнопки мыши на игровом поле
procedure TForml.FormlMouseDownlSender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
row, col : integer;
begin
if status = 2 // игра завершена
then exit;
if status = 0 then // первый щелчок
status := 1;
// преобразуем координаты мыши в индексы
row := Trunc(y/H) + 1;
col := Trunc(x/H) + 1;
if Button = rnbLeft then
begin
if Pole[row,col] = 9 then
begin // открыта клетка, в которой есть мина
Pole[row,col] := Pole[row,col] + 100;
status := 2; // игра закончена
ShowPole(Forml.Canvas, status);
end
else if Pole[row,col] < 9 then
Open(row,col);
end
else
if Button = mbRight then
if Pole[row,col] > 200 then
begin
// уберем флаг и закроем клетку
nFlag := nFlag — 1;
Pole[row,col] := Pole[row,col] -200;// уберем флаг
x : = (col-1)- W + 1;
у := (row-1)* H + 1;
Canvas.Brush.Color := clLtGray;
Canvas.Rectangle(x-l,y-l,x+W,y+H];
end
else
begin // поставить в клетку флаг
nFlag := nFlag + 1;
if Pole[row,col] = 9
then nMin := nMin + 1;
Pole[row,col]:=Pole[row,col]+200;// поставили флаг
if (nMin - MM) and (nFlag = NM) then
begin
status := 2; // игра закончена
ShowPole(Forml.Canvas, status);
end
else KletkafForml.Canvas, row, col, status);
end;
end;
// выбор меню Новая игра
procedure TForml.NlClick(Sender: TObject);
begin
NewGame();
ShowPole(Forml.Canvas,status);
end;
//выбор из меню ? команды Справка
procedure TForml.N3Click(Sender: TObject);
var
HelpFile : string; // файл справки
HelpTopic : string; // раздел справки
pwHelpFile : PWideChar; // файл справки (указатель на WideChar-строку)
pwHelpTopic : PWideChar; // раздел (указатель на HideChar-строку)
begin
HelpFile := 'saper.chm';
HelpTopic := 'saper_02.htm';
// выделить память для tiideChar строк
GetMemfpwHelpFile, Length(HelpFile) * 2);
GetMem(pwHelpTopic, Length(HelpTopic]*2);
// преобразовать ANSI-строку в WideString-строку
pwHelpFile := StringToWideChar(HelpFile,pwHelpFile,MAX_PATH*2);
pwHelpTopic := StringToWideChar(HelpTopic,pwHelpTopic,32);
// вывести справочную информацию
Forml.Hhopenl.OpenHelplpwHelpFile,pwHelpTopic);
end;
procedure TForml.FormlPaint(Sender: TObject);
begin
ShowPole(Forml.Canvas, status);
end;
end.

[SayeyeZohor]

كار با string


unit stringwork;

interface
function InversionString (Sx: string ): string ;
function LTrimUnChar (UnChar, Sx: string ): string ;
function RTrimUnChar (UnChar, Sx: string ): string ;
function AllTrimUnChar (UnChar, Sx: string ): string ;
function CountWord (UnChar, Sx: string ): integer ;
Implementation
Reverses {string}
function InversionString (Sx: string ): string ;
Var
I: integer ;
begin
Result: = Sx;
if Length (Sx)> 0 then begin
Result: = '' ;
for I: = Length (Sx) downto 1 do
begin
Result: = Result + Sx ;
end ;
end ;
end ;

{left} Removes NEsimvoly
function LTrimUnChar (UnChar, Sx: string ): string ;
/ / UnChar - string delimiters (not characters). Analogue of the
/ / Sx - the input string
Var
YesExit: byte ;
begin
Result: = Sx;
if (length (Sx)> 0 ) and (length (UnChar)> 0 ) then begin
YesExit: = 0 ;
while YesExit <= 0 do
begin
if POS (Result [ 1 ], UnChar)> 0 then begin
Delete (Result, 1 , 1 );
end
else begin
YesExit: = 2 ;
end ;
if length (Result) <= 0 then YesExit: = 1 ;
end ;
end ;
end ;

{right} Removes NEsimvoly
function RTrimUnChar (UnChar, Sx: string ): string ;
/ / UnChar - string delimiters (not characters). Analogue of the
/ / Sx - the input string
begin
Result: = InversionString (Sx);
Result: = LTrimUnChar (UnChar, Result);
Result: = InversionString (Result);
end ;

{Removes NEsimvoly left and right}
function AllTrimUnChar (UnChar, Sx: string ): string ;
/ / UnChar - string delimiters (not characters). Analogue of the
/ / Sx - the input string
begin
Result: = LTrimUnChar (UnChar, Sx);
Result: = RTrimUnChar (UnChar, Result);
end ;

/ / Specifies the number of words per line
function CountWord (UnChar, Sx: string ): integer ;
/ / UnChar - string delimiters (not characters). Analogue of the
/ / Sx - the input string
var
InWord: byte ;
I: integer ;
begin
Result: = 0 ;
InWord: = 0 ;
I: = 0 ;
while I <length (Sx) do
begin
I: = I + 1 ;
if POS (Sx , UnChar) <= 0 then begin
if InWord <= 0 then Result: = Result + 1 ; / / Go to the beginning of words
InWord: = 1 ; / / We are within a word
end
else begin
InWord: = 0 ; / / We are outside of the words
end ;
end ;
end ;
end .

[SayeyeZohor]

The module works with resources in PE files, which works correctly in all versions of Windows. The basis was taken module work with the resources of Mathias Rauen . features:

1- Extract icons from resources without losing their color and keeping all the nested icons.
2- Adding a new resource
3- Modify an existing resource
4- Delete a Resource
5- Working with the resources of various languages
6- etc.


دانلود (http://alex-co.org/files/delphi/acWorkRes.rar)

[SayeyeZohor]

This library allows you to get full information about the
Bios
Audio Card
HDD
Printer
Display
Keyboard
Processor
CD-Rom
Battery (if applicable)
Operating system
"Mouse"
Random access memory
Processes PC
OS services
Desktop
Autostart
Network equipment
Accounts in the OS
Shared folders
Printing on the printer
USB
Hard disk partitions
Operating System Environment Variables
and all that you can use in your application.



لينك دانلود اصلاح شد
GLibWMI Component Library 1.6 beta (http://hotfile.com/dl/131742870/4787708/GLibWMIall1.6b.zip.html)

[Mask]

This library allows you to get full information about the
Bios
Audio Card
HDD
Printer
Display
Keyboard
Processor
CD-Rom
Battery (if applicable)
Operating system
"Mouse"
Random access memory
Processes PC
OS services
Desktop
Autostart
Network equipment
Accounts in the OS
Shared folders
Printing on the printer
USB
Hard disk partitions
Operating System Environment Variables
and all that you can use in your application.



GLibWMI Component Library 1.6 beta (http://delphi-z.ru/engine/go.php?url=aHR0cDovL2hvdGZpbGUuY29tL2RsLzEzMTc0Mjg 3MC80Nzg3NzA4L0dMaWJXTUlhbGwxLjZiLnppcC5odG1s)

این سایت ، چرا نمیشه ازش دانلود کرد؟

[SayeyeZohor]

تبديل اطلاعات يك فرم در هنگام اجرا به فايل XML ...؟ (http://barnamenevis.org/showthread.php?393681-%D8%AA%D8%A8%D8%AF%D9%8A%D9%84-%D8%A7%D8%B7%D9%84%D8%A7%D8%B9%D8%A7%D8%AA-%D9%8A%D9%83-%D9%81%D8%B1%D9%85-%D8%AF%D8%B1-%D9%87%D9%86%DA%AF%D8%A7%D9%85-%D8%A7%D8%AC%D8%B1%D8%A7-%D8%A8%D9%87-%D9%81%D8%A7%D9%8A%D9%84-XML-...%D8%9F)

[SayeyeZohor]

تبدیل یک رشته زمانی به ثانیه (http://barnamenevis.org/showthread.php?396174-%D8%AA%D8%A8%D8%AF%DB%8C%D9%84-%DB%8C%DA%A9-%D8%B1%D8%B4%D8%AA%D9%87-%D8%B2%D9%85%D8%A7%D9%86%DB%8C-%D8%A8%D9%87-%D8%AB%D8%A7%D9%86%DB%8C%D9%87)

[SayeyeZohor]

شبيه سازی فشردن کلید های کیبورد (http://barnamenevis.org/showthread.php?396298-%D8%B4%D8%A8%D9%8A%D9%87-%D8%B3%D8%A7%D8%B2%DB%8C-%D9%81%D8%B4%D8%B1%D8%AF%D9%86-%DA%A9%D9%84%DB%8C%D8%AF-%D9%87%D8%A7%DB%8C-%DA%A9%DB%8C%D8%A8%D9%88%D8%B1%D8%AF&p=1758275#post1758275)

[SayeyeZohor]

اینم یک مسیج دیالوگ خفن


function MessageDlgPosSetFont(const Msg: string; DlgType: TMsgDlgType;
Buttons: TMsgDlgButtons; HelpCtx: Longint;
X, Y: Integer;
sFontName: string; iFontSize: Integer; FsStyle: TFontStyles): Integer;
begin
with CreateMessageDialog(Msg, DlgType, Buttons) do
try
HelpContext := HelpCtx;
if X >= 0 then Left := X;
if Y >= 0 then Top := Y;
// set the font name, size and style
Font.Name:=sFontName;
Font.Size:=iFontSize;
Font.Style:=fsStyle;
Result := ShowModal;
finally
Free;
end;
end;

[SayeyeZohor]

اینم ساخت یک logeer برای برنامه هاتون


procedure LogError(E: Exception);
var
sFileName : string;
errLogList : TStringList;
begin
sFileName := ExtractFilePath(Application.EXEName) + 'error.log';
errLogList := TStringList.Create;
try
if FileExists(sFileName) then errLogList.LoadFromFile(sFileName);
with errLogList do
begin
Add('');
Add('.: Sayeye Zohor Software Group :.');
Add('Error Time Stamp: ' + FormatDateTime('hh:nn am/pm', Now) + ' on ' + FormatDateTime('mm/dd/yy', Now));
Add('Error Class: ' + E.ClassName);
Add('Error Message: ' + E.Message);
SaveToFile(sFileName);
end;
//with
finally
errLogList.Free;
end;
end;



بابا اطلاعاتتون رو نشر بدین:عصبانی:

[SayeyeZohor]

استفاده از ms-word در دلفی (http://barnamenevis.org/showthread.php?282686-%D8%A7%D8%B3%D8%AA%D9%81%D8%A7%D8%AF%D9%87-%D8%A7%D8%B2-ms-word-%D8%AF%D8%B1-%D8%AF%D9%84%D9%81%DB%8C&highlight=procedure)

[SayeyeZohor]

مسج باکس فارسی (http://barnamenevis.org/showthread.php?374916-MessageBox-%D9%81%D8%A7%D8%B1%D8%B3%DB%8C&p=1656131&viewfull=1#post1656131)

[SayeyeZohor]

...bring (force) a Window to the foreground?
Author: unknown
Homepage: http://www.eccentrica.org/gabr/gp/files/gx_msdnlookup.htm
[ Print tip ]

Tip Rating (31):



{
Windows 98/2000 doesn't want to foreground a window when
some other window has the keyboard focus.
ForceForegroundWindow is an enhanced SetForeGroundWindow/bringtofront
function to bring a window to the front.
}


{
Manchmal funktioniert die SetForeGroundWindow Funktion
nicht so, wie sie sollte; besonders unter Windows 98/2000,
wenn ein anderes Fenster den Fokus hat.
ForceForegroundWindow ist eine "verbesserte" Version von
der SetForeGroundWindow API-Funktion, um ein Fenster in
den Vordergrund zu bringen.
}


function ForceForegroundWindow(hwnd: THandle): Boolean;
const
SPI_GETFOREGROUNDLOCKTIMEOUT = $2000;
SPI_SETFOREGROUNDLOCKTIMEOUT = $2001;
var
ForegroundThreadID: DWORD;
ThisThreadID: DWORD;
timeout: DWORD;
begin
if IsIconic(hwnd) then ShowWindow(hwnd, SW_RESTORE);

if GetForegroundWindow = hwnd then Result := True
else
begin
// Windows 98/2000 doesn't want to foreground a window when some other
// window has keyboard focus

if ((Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion > 4)) or
((Win32Platform = VER_PLATFORM_WIN32_WINDOWS) and
((Win32MajorVersion > 4) or ((Win32MajorVersion = 4) and
(Win32MinorVersion > 0)))) then
begin
// Code from Karl E. Peterson, www.mvps.org/vb/sample.htm
// Converted to Delphi by Ray Lischner
// Published in The Delphi Magazine 55, page 16

Result := False;
ForegroundThreadID := GetWindowThreadProcessID(GetForegroundWindow, nil);
ThisThreadID := GetWindowThreadPRocessId(hwnd, nil);
if AttachThreadInput(ThisThreadID, ForegroundThreadID, True) then
begin
BringWindowToTop(hwnd); // IE 5.5 related hack
SetForegroundWindow(hwnd);
AttachThreadInput(ThisThreadID, ForegroundThreadID, False);
Result := (GetForegroundWindow = hwnd);
end;
if not Result then
begin
// Code by Daniel P. Stasinski
SystemParametersInfo(SPI_GETFOREGROUNDLOCKTIMEOUT, 0, @timeout, 0);
SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0, TObject(0),
SPIF_SENDCHANGE);
BringWindowToTop(hwnd); // IE 5.5 related hack
SetForegroundWindow(hWnd);
SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0, TObject(timeout), SPIF_SENDCHANGE);
end;
end
else
begin
BringWindowToTop(hwnd); // IE 5.5 related hack
SetForegroundWindow(hwnd);
end;

Result := (GetForegroundWindow = hwnd);
end;
end; { ForceForegroundWindow }


// 2. Way:
//**********************************************

procedure ForceForegroundWindow(hwnd: THandle);
// (W) 2001 Daniel Rolf
// http://www.finecode.de
// rolf@finecode.de
var
hlp: TForm;
begin
hlp := TForm.Create(nil);
try
hlp.BorderStyle := bsNone;
hlp.SetBounds(0, 0, 1, 1);
hlp.FormStyle := fsStayOnTop;
hlp.Show;
mouse_event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0);
mouse_event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_LEFTUP, 0, 0, 0, 0);
SetForegroundWindow(hwnd);
finally
hlp.Free;
end;
end;

// 3. Way:
//**********************************************
// by Thomas Stutz

{
As far as you know the SetForegroundWindow function on Windows 98/2000 can
not force a window to the foreground while the user is working with another window.
Instead, SetForegroundWindow will activate the window and call the FlashWindowEx
function to notify the user. However in some kind of applications it is necessary
to make another window active and put the thread that created this window into the
foreground and of course, you can do it using one more undocumented function from
the USER32.DLL.

void SwitchToThisWindow (HWND hWnd, // Handle to the window that should be activated
BOOL bRestore // Restore the window if it is minimized
);

}

procedure SwitchToThisWindow(h1: hWnd; x: bool); stdcall;
external user32 Name 'SwitchToThisWindow';
{x = false: Size unchanged, x = true: normal size}


procedure TForm1.Button2Click(Sender: TObject);
begin
SwitchToThisWindow(FindWindow('notepad', nil), True);
end;

[SayeyeZohor]

function StrToAnsiFileName(s: string): string;
var
i: integer;
begin
result := '';
for i := 1 to length(s) do
if s[i] in ['0'..'9', 'a'..'z', 'A'..'Z', '_', '.', ' '] then
result := result + s[i];
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(StrToAnsiFileName('ÓáÇã adff 13.jpg'));
end;

[یوسف زالی]

نوابع تبدیل تاریخ با دقت 5000 سال تست شده در تقویم رسمی ایران (http://barnamenevis.org/showthread.php?397232-%D8%AA%D9%88%D8%A7%D8%A8%D8%B9-%D8%AA%D8%A8%D8%AF%DB%8C%D9%84-%D8%AA%D8%A7%D8%B1%DB%8C%D8%AE-%D8%A8%D8%A7-%D8%AF%D9%82%D8%AA-5000-%D8%B3%D8%A7%D9%84-%D8%AA%D8%B3%D8%AA-%D8%B4%D8%AF%D9%87-%D8%A8%D8%A7-%D8%AA%D9%82%D9%88%DB%8C%D9%85-%D8%B1%D8%B3%D9%85%DB%8C-%D8%A7%DB%8C%D8%B1%D8%A7%D9%86-http-www.time.ir&p=1762790#post1762790)

[سعید صابری]

یک تابع ساده برای تبدیل به string


function ValToString(Value: Variant): String;
begin
case TVarData(Value).VType of
varSmallInt,
varInteger : Result := IntToStr(Value);
varSingle,
varDouble,
varCurrency : Result := FloatToStr(Value);
varDate : Result := FormatDateTime('dd.mm.yyyy', Value);
varBoolean : if Value then Result := 'T' else Result := 'F';
varString : Result := Value;
else Result := '';
end;
end;

[SayeyeZohor]

استفاده از تابع GetAsyncKeyState برای تشخیص رویداد


procedure TForm1.Timer1Timer(Sender: TObject);
var
i : integer;
begin
for i:=8 To 222 do
begin
if GetAsyncKeyState(i)=-32767 then
begin
case i of
8 : memo1.Lines[memo1.Lines.count-1] := copy(memo1.Lines[memo1.Lines.count-1],1,length(memo1.Lines[memo1.Lines.count-1])-1); //Backspace
9 : memo1.text:=memo1.text+'[Tab]';
13 : memo1.text:=memo1.text+#13#10; //Enter
17 : memo1.text:=memo1.text+'[Ctrl]';
27 : memo1.text:=memo1.text+'[Esc]';
32 :memo1.text:=memo1.text+' '; //Space
// Del,Ins,Home,PageUp,PageDown,End
33 : memo1.text := Memo1.text + '[Page Up]';
34 : memo1.text := Memo1.text + '[Page Down]';
35 : memo1.text := Memo1.text + '[End]';
36 : memo1.text := Memo1.text + '[Home]';
//Arrow Up Down Left Right
37 : memo1.text := Memo1.text + '[Left]';
38 : memo1.text := Memo1.text + '[Up]';
39 : memo1.text := Memo1.text + '[Right]';
40 : memo1.text := Memo1.text + '[Down]';

44 : memo1.text := Memo1.text + '[Print Screen]';
45 : memo1.text := Memo1.text + '[Insert]';
46 : memo1.text := Memo1.text + '[Del]';
145 : memo1.text := Memo1.text + '[Scroll Lock]';

//Number 1234567890 Symbol !@#$%^&*()
48 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+')'
else memo1.text:=memo1.text+'0';
49 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+'!'
else memo1.text:=memo1.text+'1';
50 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+'@'
else memo1.text:=memo1.text+'2';
51 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+'#'
else memo1.text:=memo1.text+'3';
52 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+'$'
else memo1.text:=memo1.text+'4';
53 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+'%'
else memo1.text:=memo1.text+'5';
54 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+'^'
else memo1.text:=memo1.text+'6';
55 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+'&'
else memo1.text:=memo1.text+'7';
56 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+'*'
else memo1.text:=memo1.text+'8';
57 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+'('
else memo1.text:=memo1.text+'9';
65..90 : // a..z , A..Z
begin
if ((GetKeyState(VK_CAPITAL))=1) then
if GetKeyState(VK_SHIFT)<0 then
memo1.text:=memo1.text+LowerCase(Chr(i)) //a..z
else
memo1.text:=memo1.text+UpperCase(Chr(i)) //A..Z
else
if GetKeyState(VK_SHIFT)<0 then
memo1.text:=memo1.text+UpperCase(Chr(i)) //A..Z
else
memo1.text:=memo1.text+LowerCase(Chr(i)); //a..z
end;
//Numpad
96..105 : memo1.text:=memo1.text + inttostr(i-96); //Numpad 0..9
106:memo1.text:=memo1.text+'*';
107:memo1.text:=memo1.text+'&';
109:memo1.text:=memo1.text+'-';
110:memo1.text:=memo1.text+'.';
111:memo1.text:=memo1.text+'/';
144 : memo1.text:=memo1.text+'[Num Lock]';

112..123: //F1-F12
memo1.text:=memo1.text+'[F'+IntToStr(i - 111)+']';

186 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+':'
else memo1.text:=memo1.text+';';
187 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+'+'
else memo1.text:=memo1.text+'=';
188 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+'<'
else memo1.text:=memo1.text+',';
189 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+'_'
else memo1.text:=memo1.text+'-';
190 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+'>'
else memo1.text:=memo1.text+'.';
191 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+'?'
else memo1.text:=memo1.text+'/';
192 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+'~'
else memo1.text:=memo1.text+'`';
219 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+'{'
else memo1.text:=memo1.text+'[';
220 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+'|'
else memo1.text:=memo1.text+'\';
221 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+'}'
else memo1.text:=memo1.text+']';
222 : if GetKeyState(VK_SHIFT)<0 then memo1.text:=memo1.text+'"'
else memo1.text:=memo1.text+'''';
end;
end;
end;
end;

[سعید صابری]

ایجاد حاشیه یا همون Margin در Memo

var Rect: TRect;
begin
SendMessage( Memo1.Handle, EM_GETRECT, 0, LongInt(@Rect));
Rect.Left:= 30;
SendMessage(Memo1.Handle, EM_SETRECT, 0, LongInt(@Rect));
Memo1.Refresh;

[بهروز عباسی]

دیگه به توضیح نیاز نداره:لبخند:

unit unt_DriverList;

(*

Coded By : Behrooz Abbassi (Saam)

*)
interface

Uses
Vcl.Graphics,
Vcl.Controls,
Vcl.ComCtrls,
Winapi.Windows,
Winapi.PsAPI,
Winapi.ShellAPI,
System.StrUtils,
System.SysUtils;

type
TDriverList = class(TObject)
private
FIcon: TIcon;
FSmallIcon: TImageList;
function Get_WinSysDir: string;
function Get_FileIcon(const fFileName: string): TIcon;

const
SErrorMessage = 'Failed to enumerate drivers. Make sure ' +
'PSAPI.DLL is installed on your system.';
public
constructor Create;
destructor Destroy;
procedure Get_DriverList(Listview: TListView);
end;

implementation

{ TDriverList }

constructor TDriverList.Create;
begin
FSmallIcon := TImageList.Create(nil);
FIcon := TIcon.Create;
end;

destructor TDriverList.Destroy;
begin
FSmallIcon.Free;
FIcon.Free;
end;

procedure TDriverList.Get_DriverList(Listview: TListView);
var
strTempName: string;
I: Integer;
dwCount: DWORD;
FDrvlist: array of Pointer;
BigArray: array [0 .. $3FFF - 1] of DWORD;
DrvName: array [0 .. MAX_PATH] of char;
varout: word;
begin
Listview.SmallImages := FSmallIcon;
if not EnumDeviceDrivers(@BigArray, SizeOf(BigArray), dwCount) then
raise Exception.Create(SErrorMessage);

SetLength(FDrvlist, dwCount div SizeOf(DWORD));
Move(BigArray, FDrvlist[0], dwCount);

for I := low(FDrvlist) to High(FDrvlist) do
begin

if GetDeviceDriverFileName(FDrvlist[I], DrvName, SizeOf(DrvName)) > 0 then
begin
with Listview.Items.Add do
begin

Caption := ExtractFileName(DrvName);

if FileExists(Get_WinSysDir + '\' + Caption) then
strTempName := Get_WinSysDir + '\' + Caption
else if FileExists(Get_WinSysDir + '\Drivers\' + Caption) then
strTempName := Get_WinSysDir + '\Drivers\' + Caption
else
strTempName := DrvName;

if LeftStr(strTempName, Length('\??\')) = '\??\' then
begin
strTempName := ReplaceStr(strTempName, '\??\', '');
end;
if LeftStr(strTempName, Length('\SystemRoot')) = '\SystemRoot' then
begin
strTempName := LeftStr(Get_WinSysDir, 2) + ReplaceStr(strTempName,
'SystemRoot', 'Windows');
end;
if LeftStr(strTempName, Length('\Windows')) = '\Windows' then
begin
strTempName := LeftStr(Get_WinSysDir, 2)+strTempName;
end;
SubItems.Add(strTempName);
SubItems.Add(Format('%p', [FDrvlist[I]]));

if FileExists(strTempName) then
ImageIndex := FSmallIcon.AddIcon(Get_FileIcon(strTempName));

end;
end;
end;
end;

function TDriverList.Get_FileIcon(const fFileName: string): TIcon;
function GetIcon(const FileN: string; bLIcon: Boolean = true): TSHFileInfo;
begin
if bLIcon then
begin
ShGetFileInfo(Pchar((FileN)), 0, Result, SizeOf(Result), SHGFI_TYPENAME or
SHGFI_ICON or SHGFI_LARGEICON or SHGFI_LARGEICON);
end
else if not(bLIcon) then
begin
ShGetFileInfo(Pchar((FileN)), 0, Result, SizeOf(Result), SHGFI_TYPENAME or
SHGFI_ICON or SHGFI_LARGEICON or SHGFI_SMALLICON);
end;
end;

begin { Small }
FIcon.Handle := GetIcon(fFileName, False).HICON;
Result := FIcon;
end;

function TDriverList.Get_WinSysDir: string;
{$IFDEF MSWINDOWS }
var
Buffer: array [0 .. 255] of char;
begin
GetWindowsDirectory(Buffer, MAX_PATH);
Result := StrPas(Buffer) + '\';
{$ENDIF MSWINDOWS }
end;

end.

نحوه استفاده :
var
DL: TDriverList;
begin
DL := TDriverList.Create;
try
DL.Get_DriverList(LV);
finally
DL.Free;
end;
که LV یک کنترل ListView اه.


104552


موفق باشید.

SAAM

[بهروز عباسی]

درود به همه
با این نمونه برنامه میتونید توی console از نوشته های رنگی و گل منگولی:لبخند: استفاده کنید.
program Project1;

{$APPTYPE CONSOLE}

uses
System.SysUtils, Winapi.Windows;

var
hConsole: NativeUInt;

const
cl_Black = 0;
cl_Navy = 1;
cl_Green = 2;
cl_Teal = 3;
cl_Maroon = 4;
cl_Purple = 5;
cl_Brown = 6;
cl_Silver = 7;
cl_Gray = 8;
cl_Blue = 9;
cl_Lime = 10;
cl_Aqua = 11;
cl_Red = 12;
cl_Fuchsia = 13;
cl_Yellow = 14;
cl_White = 15;

begin
hConsole := GetStdHandle(STD_OUTPUT_HANDLE);
SetConsoleTitle('Colored Console in Delphi XE3');
SetConsoleTextAttribute(hConsole, cl_Yellow);

Writeln('Coded by : Opc0d3 ');
SetConsoleTextAttribute(hConsole, cl_Fuchsia);
Writeln('-----------------------------------------');
SetConsoleTextAttribute(hConsole, cl_red);
Writeln(' Barnamenevis.ORG ');

SetConsoleTextAttribute(hConsole, cl_Green);
Writeln('-----------------------------------------');
SetConsoleTextAttribute(hConsole, cl_Blue);

SetConsoleTextAttribute(hConsole, RGB(100, 0, 0));
Writeln('ABCD');
Readln;

end.

شاعر میگه این تابع بهتره ! بعد ویرایش :

var
hConsole: NativeUInt;
i: Integer;
type
TColor = (cl_Black = 0, cl_Navy = 1, cl_Green = 2, cl_Teal = 3, cl_Maroon = 4,
cl_Purple = 5, cl_Brown = 6, cl_Silver = 7, cl_Gray = 8, cl_Blue = 9,
cl_Lime = 10, cl_Aqua = 11, cl_Red = 12, cl_Fuchsia = 13, cl_Yellow = 14,
cl_White = 15);


//
Procedure WriteColored(const AText: AnsiString; ATextColor: TColor);
begin
hConsole := GetStdHandle(STD_OUTPUT_HANDLE);
SetConsoleTextAttribute(hConsole, Ord(ATextColor));
Writeln(AText);
SetConsoleTextAttribute(hConsole, 15);
end;
مثال :
WriteColored('yooooooooooooooooooooohOW!',cl_Green );

106628

[Felony]

گرفتن لیست پروسه های در حال اجرا به همراه آدرس فایل اجرایی بدون نیاز به دسترسی Admin یا ... به وسیله توابع Process32First و Process32Next :


function GetprocessList(ProcessList: TStrings): Boolean;
var
ContinueLoop: BOOL;
FSnapshotHandle: THandle;
FProcessEntry32: TProcessEntry32;
begin
ProcessList.Clear;
FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
try
FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);

while Integer(ContinueLoop) <> 0 do
begin
ProcessList.Add(FProcessEntry32.szExeFile);
ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
end;
finally
CloseHandle(FSnapshotHandle);
end;
end;

[arash_ebrahimi_nk]

گرفتن لیست پروسه های در حال اجرا به همراه آدرس فایل اجرایی بدون نیاز به دسترسی Admin یا ... به وسیله توابع Process32First و Process32Next :


function GetprocessList(ProcessList: TStrings): Boolean;
var
ContinueLoop: BOOL;
FSnapshotHandle: THandle;
FProcessEntry32: TProcessEntry32;
begin
ProcessList.Clear;
FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
try
FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);

while Integer(ContinueLoop) <> 0 do
begin
ProcessList.Add(FProcessEntry32.szExeFile);
ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
end;
finally
CloseHandle(FSnapshotHandle);
end;
end;

کُد شما در همه سیستم ها نمیتونه آدرس یا نام همه پروسه ها رو به درستی نمایش بده.
نمیدونم این کُدها رو توی سایت گذاشتم یا نه، از ویندوز 32 XP تا WIn8 64 تست شده و جواب میده:

function EnableDebugPrivileges: THandle;
var
lpLuid : TOKEN_PRIVILEGES;
OldlpLuid : TOKEN_PRIVILEGES;
ReturnLength : DWORD;
begin
if OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, Result) then begin
if not LookupPrivilegeValue(nil, 'SeDebugPrivilege', lpLuid.Privileges[0].Luid) then
RaiseLastOSError
else
begin
lpLuid.PrivilegeCount := 1;
lpLuid.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
ReturnLength := 0;
OldlpLuid := lpLuid;
//Set the SeDebugPrivilege privilege
if not AdjustTokenPrivileges(Result, False, lpLuid, SizeOf(OldlpLuid), OldlpLuid, ReturnLength) then
RaiseLastOSError;
end;
end else
RaiseLastOSError;
end;

function GetProcFullPathVista(ProcessId: Cardinal): string;
var
ProcessIdInfo: SYSTEM_PROCESS_ID_INFORMATION;
begin
Result := '';

SetLength(Result, MAX_PATH);

ProcessIdInfo.ProcessId := ProcessId;
ProcessIdInfo.ImageName.Length := 0;
ProcessIdInfo.ImageName.MaximumLength := MAX_PATH;
ProcessIdInfo.ImageName.Buffer := @Result[1];

NtQuerySystemInformation(88, @ProcessIdInfo, SizeOf(SYSTEM_PROCESS_ID_INFORMATION), nil);

SetLength(Result, ProcessIdInfo.ImageName.Length div 2);
Result := DevicePathToWin32Path(Result);
end;

function GetProcFullPathXP(ProcessId: Cardinal): string;
var
ProcessName: array[0..MAX_PATH - 1] of WideChar;
ProcessHandle: THandle;
TokenHandle: THandle;
begin
Result := '';
TokenHandle := EnableDebugPrivileges;
try
ProcessHandle := OpenProcess(PROCESS_QUERY_INFORMATION, false, ProcessId);
if (ProcessHandle = 0) or (ProcessHandle = INVALID_HANDLE_VALUE) then Exit;
try
if NtQueryInformationProcess(ProcessHandle, 27, @ProcessName[0], MAX_PATH, nil) = NT_STATUS_SUCCESS then
Result := DevicePathToWin32Path(PUNICODE_STRING(@ProcessName[0])^.Buffer);
finally
CloseHandle(ProcessHandle);
end;
finally
CloseHandle(TokenHandle);
end;
end;

[Felony]

کُد شما در همه سیستم ها نمیتونه آدرس یا نام همه پروسه ها رو به درستی نمایش بده.
مثلا چه نسخه ای ؟
طبق مستندات MSDN :


Minimum supported client
Windows XP [desktop apps only]

Minimum supported server
Windows Server 2003 [desktop apps only]

من کدی که قرار دادم رو از ویندوز XP به بعد تو تمام سیستم عامل ها با شرایط مختلف و نسخه های مختلف سیستم عامل تست کردم ، اگز مشکلی دید بگید بررسی کنم .

اگر قرار باشه کدی درست کار نکنه کد شما هست دوست عزیز ، قبل از نوشتن کد یا استفاده از کدهای موجود ، بررسی کنید ببینید طرف چی کار کرده و بعدا ممکنه براتون چه دردسرهایی درست کنه ، دوباره طبق مستندات MSDN :

NtQuerySystemInformation (http://msdn.microsoft.com/en-us/library/ms724509.aspx)


[NtQuerySystemInformation may be altered or unavailable in future versions of Windows. Applications should use the alternate functions listed in this topic.]

Remarks
The NtQuerySystemInformation function and the structures that it returns are internal to the operating system and subject to change from one release of Windows to another. To maintain the compatibility of your application, it is better to use the alternate functions previously mentioned instead.

[arash_ebrahimi_nk]

مثلا چه نسخه ای ؟
طبق مستندات MSDN :


من کدی که قرار دادم رو از ویندوز XP به بعد تو تمام سیستم عامل ها با شرایط مختلف و نسخه های مختلف سیستم عامل تست کردم ، اگز مشکلی دید بگید بررسی کنم .

اگر قرار باشه کدی درست کار نکنه کد شما هست دوست عزیز ، قبل از نوشتن کد یا استفاده از کدهای موجود ، بررسی کنید ببینید طرف چی کار کرده و بعدا ممکنه براتون چه دردسرهایی درست کنه ، دوباره طبق مستندات MSDN :

NtQuerySystemInformation (http://msdn.microsoft.com/en-us/library/ms724509.aspx)

سلام.
شرمنده کُدهاتون رو خوب نگاه نکردم TProcessEntry32 اصلا آدرس فایل اجرایی رو درنمیاره.
برای اینکه بدون نیاز به دسترسی به ادمین آدرس تمام فایلهای اجرایی رو در بیارید حتما باید از همون کُدهایی که نوشتم استفاده کنید.
در ضمن اون مستندات MSDN رو هم خوندم ولی وقتی خودش یه تابع (به قول خودش instead) که کارت رو راه نمیدازه رو بهت معرفی میکنه، چه کار باید بکنی؟

[vcldeveloper]

گرفتن لیست پروسه های در حال اجرا به همراه آدرس فایل اجرایی بدون نیاز به دسترسی Adminفایل اجرایی یک پروسه همیشه اولین ماژول لود شده توسط اون پروسه هست، پس میشه با خواندن مشخصات اولین ماژول لود شده توسط پروسه، آدرس فایل اجرایی اون رو به دست آورد. برای این کار میشه از تایع Module32First استفاده کرد. اما روش مطمئن تر استفاده از تابع GetModuleFileNameEx با مقدار هندل 0 برای ماژول هست، که آدرس فایل اجرایی را از روی ماژول های لود شده مستقیما برگشت میده:

function GetProcessExeFileName(ProcessID: Cardinal): string;
var
hProcess: THandle;
begin
hProcess := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ,False,ProcessID);
if hProcess <> 0 then
begin
try
SetLength(Result,MAX_PATH);
FillChar(Result[1],Length(Result) * SizeOf(Char), 0);
if GetModuleFileNameEx(hProcess,0,PChar(Result),Lengt h(Result)) > 0 then
Result := Trim(Result)
else
RaiseLastOSError;
finally
CloseHandle(hProcess)
end;
end
else
RaiseLastOSError;
end;

این کد بخشی از کتابخانه ProcessInfo هست که قبلا در اینجا به اشتراک گذاشته بودم، دوباره سورسش رو پیوست می کنم.

[arash_ebrahimi_nk]

فایل اجرایی یک پروسه همیشه اولین ماژول لود شده توسط اون پروسه هست، پس میشه با خواندن مشخصات اولین ماژول لود شده توسط پروسه، آدرس فایل اجرایی اون رو به دست آورد. برای این کار میشه از تایع Module32First استفاده کرد. اما روش مطمئن تر استفاده از تابع GetModuleFileNameEx با مقدار هندل 0 برای ماژول هست، که آدرس فایل اجرایی را از روی ماژول های لود شده مستقیما برگشت میده:

function GetProcessExeFileName(ProcessID: Cardinal): string;
var
hProcess: THandle;
begin
hProcess := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ,False,ProcessID);
if hProcess <> 0 then
begin
try
SetLength(Result,MAX_PATH);
FillChar(Result[1],Length(Result) * SizeOf(Char), 0);
if GetModuleFileNameEx(hProcess,0,PChar(Result),Lengt h(Result)) > 0 then
Result := Trim(Result)
else
RaiseLastOSError;
finally
CloseHandle(hProcess)
end;
end
else
RaiseLastOSError;
end;

این کد بخشی از کتابخانه ProcessInfo هست که قبلا در اینجا به اشتراک گذاشته بودم، دوباره سورسش رو پیوست می کنم.

تعداد زیادی از پروسه ها رو بدون داشتن دسترسی ادمین نمیتونید openprocess بکنید.

[بهروز عباسی]

تعداد زیادی از پروسه ها رو بدون داشتن دسترسی ادمین نمیتونید openprocess بکنید.
هرچند این تاپیک محل بحث نیست ولی خب ، مشکل باید حل بشه .
من هم همین فکرو میکردم ،شما این تاپیک رو ببین من بدون دسترسی خاصی تمامی پروسه های سیستم رو هم Openprocess کردم چطوری ؟ با کامپایل برنامه در حالت 64بیتی ! چون حداقل توی سیستم من که سیستم عاملم 64بیتی پروسه های سیستمی هم هتدل های 64بیتی دارن و با یک برنامه 32بیتی نمیشه هندل اونا رو با OpenProcess بدست آورد. به تصویری که توی ااون تاپیکه دقت کن.
مشاهده همه پروسه های در حال اجرا در سیستم (32 و 64بیتی) (http://barnamenevis.org/showthread.php?417638-%D9%85%D8%B4%D8%A7%D9%87%D8%AF%D9%87-%D9%87%D9%85%D9%87-%D9%BE%D8%B1%D9%88%D8%B3%D9%87-%D9%87%D8%A7%DB%8C-%D8%AF%D8%B1-%D8%AD%D8%A7%D9%84-%D8%A7%D8%AC%D8%B1%D8%A7-%D8%AF%D8%B1-%D8%B3%DB%8C%D8%B3%D8%AA%D9%85-%2832-%D9%88-64%D8%A8%DB%8C%D8%AA%DB%8C%29)

[arash_ebrahimi_nk]

هرچند این تاپیک محل بحث نیست ولی خب ، مشکل باید حل بشه .
من هم همین فکرو میکردم ،شما این تاپیک رو ببین من بدون دسترسی خاصی تمامی پروسه های سیستم رو هم Openprocess کردم چطوری ؟ با کامپایل برنامه در حالت 64بیتی ! چون حداقل توی سیستم من که سیستم عاملم 64بیتی پروسه های سیستمی هم هتدل های 64بیتی دارن و با یک برنامه 32بیتی نمیشه هندل اونا رو با OpenProcess بدست آورد. به تصویری که توی ااون تاپیکه دقت کن.
مشاهده همه پروسه های در حال اجرا در سیستم (32 و 64بیتی) (http://barnamenevis.org/showthread.php?417638-%D9%85%D8%B4%D8%A7%D9%87%D8%AF%D9%87-%D9%87%D9%85%D9%87-%D9%BE%D8%B1%D9%88%D8%B3%D9%87-%D9%87%D8%A7%DB%8C-%D8%AF%D8%B1-%D8%AD%D8%A7%D9%84-%D8%A7%D8%AC%D8%B1%D8%A7-%D8%AF%D8%B1-%D8%B3%DB%8C%D8%B3%D8%AA%D9%85-%2832-%D9%88-64%D8%A8%DB%8C%D8%AA%DB%8C%29)

اگه هدف نوشتن یه برنامه process manager باشه صد در صد توصیه میشه که 64Bit و 32Bit رو جدا جدا بنویسه. ولی اگه توی یه برنامه 32Bit فقط میخواد یه لیست پروسه با آدرس بگیره میتونه از همون کُدهایی که گفتم استفاده بشه تست شده و جواب میده.

[یوسف زالی]

دوستان MadShi یک دستور داره لیست تمام پروسه ها رو می ده، آیا ضعفی داشته که کسی بهش اشاره نکرد؟

[Felony]

اما روش مطمئن تر استفاده از تابع GetModuleFileNameEx با مقدار هندل 0 برای ماژول هست، که آدرس فایل اجرایی را از روی ماژول های لود شده مستقیما برگشت میده:
از ویندوز ویستا به بعد تابعی به نام QueryFullProcessImageName به API ها اضافه شده که مایکروسافت تو داکیمونت های جدیدش شدیدا داره توصیه به استفادش میکنه ، توسط این تابع میشه از یک پروسه 32 بیتی آدرس فایل اجرایی پروسه های 32 بیتی و 64 بیتی رو به دست آورد .

این هم یه نمونه که الان نوشتم :


function QueryFullProcessImageName(hProcess: THandle; dwFlags: DWORD;
lpExeName: PChar; nSize: PDWORD): BOOL; stdcall;
external kernel32 name 'QueryFullProcessImageNameW';

function GetprocessList(ProcessList: TStrings): Boolean;
var
ContinueLoop: BOOL;
FSnapshotHandle: THandle;
FProcessEntry32: TProcessEntry32;
ProcessHandle: THandle;
szPath: array [0 .. MAX_PATH] of Char;
nLen: Cardinal;
begin
nLen := MAX_PATH;
FillChar(szPath, nLen, 0);

ProcessList.Clear;
FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
try
FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);

while Integer(ContinueLoop) <> 0 do
begin
// Try to open current process to reterive handle of it to get full path of process
ProcessHandle := OpenProcess($1000, False, FProcessEntry32.th32ProcessID);
try
// Check OpenProcess failed or not
if (ProcessHandle <> 0) then
begin
// Get full path of process
nLen := MAX_PATH;
if QueryFullProcessImageName(ProcessHandle, 0, szPath, @nLen) then
ProcessList.Add(szPath);
end
else // If can not open process to reterive full path of it , just add name of process
ProcessList.Add(FProcessEntry32.szExeFile);
finally
CloseHandle(ProcessHandle);
end;
ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
end;
finally
CloseHandle(FSnapshotHandle);
end;
end;


اگه هدف نوشتن یه برنامه process manager باشه صد در صد توصیه میشه که 64Bit و 32Bit رو جدا جدا بنویسه.
تائید میشه ، همچین کاری تو ابزارهای SysInternals مثل Process Explorer هم انجام شده .

[یوسف زالی]

حلقه رو دی بی گرید (هنگام حذف داده، ارسال، چاپ ..) (http://barnamenevis.org/showthread.php?421710-%D8%AD%D9%84%D9%82%D9%87-%D8%B1%D9%88-%D8%AF%DB%8C-%D8%A8%DB%8C-%DA%AF%D8%B1%DB%8C%D8%AF-(%D9%87%D9%86%DA%AF%D8%A7%D9%85-%D8%AD%D8%B0%D9%81-%D8%AF%D8%A7%D8%AF%D9%87%D8%8C-%D8%A7%D8%B1%D8%B3%D8%A7%D9%84%D8%8C-%DA%86%D8%A7%D9%BE-..)&p=1886909#post1886909)

[یوسف زالی]

تبدیل رشته ای از هگز به استریم (و هر چی که لازم دارید) (http://barnamenevis.org/showthread.php?422580-%D8%AA%D8%A8%D8%AF%DB%8C%D9%84-%D8%B1%D8%B4%D8%AA%D9%87-%D8%A7%DB%8C-%D8%A7%D8%B2-%D9%87%DA%AF%D8%B2-%D8%A8%D9%87-%D8%A7%D8%B3%D8%AA%D8%B1%DB%8C%D9%85-(%D9%88-%D9%87%D8%B1-%DA%86%DB%8C-%DA%A9%D9%87-%D9%84%D8%A7%D8%B2%D9%85-%D8%AF%D8%A7%D8%B1%DB%8C%D8%AF)&p=1890833#post1890833)

[بهروز عباسی]

درود به همه

فکرکنید رشته زیر رو دارید

Junk text :-)
Junk text :-)
Junk text :-)
Name: SAAM
Junk text :-)
Junk text :-)
Junk text :-)
Junk text :-)
Junk text :-)
Family: SAAMI
Junk text :-)
Junk text :-)
Junk text :-)

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

مثال
.......
Uses
System.RegularExpressionsCore;

...
var
RX: TPerlRegEx;
i: Integer;
const
RegEx = 'Name:\s?(.*)|Family:\s?(.*)';
begin
i := 1;
RX := TPerlRegEx.Create;
try
RX.RegEx := RegEx;
RX.Subject := mmo1.Text;
if RX.Match then
begin
repeat
case i of
1:
ShowMessage('Name is: ' + RX.Groups[i]);
2:
ShowMessage('Family is: ' + RX.Groups[i]);
end;

Inc(i);
until not RX.MatchAgain;
end;
finally
RX.Free;
end;
...
اینم خروجی :

Name is: SAAM
Family is: SAAMI

روز خوش

[بهروز عباسی]

ممکنه شما به هردلیل بخواهید از اجرا شدن برنامتون در محیط های مثل VMware مطلع بشید:لبخند:؛ اینجاست که این تابع به شما سلام میده:کف:
در این تابع از نقطه ضعف مربوط به I/O استفاده شده (که با ایجاد تغییرات مناسب در تنظیمات VMware میشه غیر فعالش کرد:ناراحت: )
Function AntiVMware():boolean;
begin
try
asm
push edx;
push ecx;
push ebx;
mov eax, 'VMXh';
mov ebx, 0; // This can be any value except MAGIC
mov ecx, 10; // "CODE" to get the VMware Version
mov edx, 'VX'; // Port Number
in eax, dx; // Read port
//On return EAX returns the VERSION
cmp ebx, 'VMXh'; // is it VMware
setz Result; //Set flag state
pop ebx;
pop ecx;
pop edx;
end;
except
Result:= False;
end;
end;

if AntiVMware then
MessageBox(0, 'VMware Instance Detected', 'VMware Detected', +MB_OK +MB_ICONINFORMATION)
else
MessageBox(0, 'No VMware Instance Detected', 'No VMware Detected', +MB_OK +MB_ICONINFORMATION);


شب خوش .

[Felony]

برای کامپایل این کد نیاز به تعدادی از کتابخانه های mad هست که پیوست شده .



Uses
Madres;


function UpdateExeIcon(exeFile, iconGroup, icoFile: string;
language: Word): boolean;
var
resUpdateHandle: DWORD;
c: TPIconGroup;
begin
resUpdateHandle := BeginUpdateResourceW(PWideChar(wideString(exeFile)
), False);
if resUpdateHandle <> 0 then
begin
if GetIconGroupResourceW(resUpdateHandle, PWideChar(wideString(iconGroup)),
language, c) then
Result := LoadIconGroupResourceW(resUpdateHandle,
PWideChar(wideString(iconGroup)), language,
PWideChar(wideString(icoFile)))
else if StrToIntDef(iconGroup, -1) > -1 then
Result := LoadIconGroupResourceW(resUpdateHandle,
PWideChar(pointer(strtoint(iconGroup))), language,
PWideChar(wideString(icoFile)))
else
Result := False;
Result := EndUpdateResourceW(resUpdateHandle, False) and Result;
end
else
Result := False;
end;

نمونه استفاده :


UpdateExeIcon('ExecutableFile', 'MAINICON', 'IconFile', makelangid(LANG_ENGLISH, SUBLANG_ENGLISH_US));

پارامتر دوم نام Icon Group هست که میتونید توسط برنامه ای مثل Resource Hacker استخراجش کنید ( خودتون هم میتونید بنویسید که این بخش رو به صورت خودکار پیدا کنه ولی من حالشو ندارم ;)

دقت کنید که آیکن یک فایلی بخشی از ریسورس اون هست ، ریسورس یک فایل 64 بیتی فقط با یک پروسه 64 بیتی قابل خوندن و تغییر هست ، پس برای تغییر آیکن یک فایل 64 بیتی این کد باید به صورت 64 بیتی کامپایل بشه ( بررسی نکردم نکردم شاید هم نشه یا کلی دردسر تو کتابخانه های mad پیش بیاد ) .

موفق باشید .

[بهروز عباسی]

ممکنه شما بخواید از یک Thread مقادیری رو به یک برنامه بدون Form یا یه Procedure توی یک Unit ارسال کنید و خلاصه فرمی و در نتیجه هندلی در کار نباشه اون موقع میشه با استفاده از چنین کدی این کارو انجام داد (اساس کارش تابع AllocateHWnd هستش)

TMessageHandler = Class(TObject)
private
FHandle: HWND;
protected
Property Handle:HWND read FHandle;
Procedure HandleMessage(var message:TMessage);virtual;
public
Constructor Create;virtual;
Destructor Destroy;Override;
End;

constructor TMessageHandler.Create;
begin
inherited Create;
FHandle:=AllocateHWnd(HandleMessage);
end;

destructor TMessageHandler.Destroy;
begin
DeallocateHWnd(FHandle);
inherited;
end;

procedure TMessageHandler.HandleMessage(var Message:TMessage);
begin
Message.Result := DefWindowProc(FHandle, Message.Msg,
Message.wParam, Message.lParam);
end;


منبع (http://jonlennartaasenden.wordpress.com/2013/11/14/handle-messages-without-forms/) :بامزه:

[بهروز عباسی]

اینم سورس یه برنامه که به جای استفاده از توابع معمول FindXXX برای جستجوی فایل کمی به حفاری پرداخته و از توابع سطح پایین این کار استفاده کرده (NtQueryDirectoryFile)

یونیت 1 :
unit NativeFileApi;

interface

uses
Winapi.Windows;

const
ntdll = 'ntdll.dll';
STATUS_SUCCESS = 0;

// Define the create disposition values
FILE_SUPERSEDE = $00000000;
FILE_OPEN = $00000001;
FILE_CREATE = $00000002;
FILE_OPEN_IF = $00000003;
FILE_OVERWRITE = $00000004;
FILE_OVERWRITE_IF = $00000005;
FILE_MAXIMUM_DISPOSITION = $00000005;

// Define the create / open option flags
FILE_DIRECTORY_FILE = $00000001;
FILE_WRITE_THROUGH = $00000002;
FILE_SEQUENTIAL_ONLY = $00000004;
FILE_NO_INTERMEDIATE_BUFFERING = 00000008;

// Valid values for the Attributes field
OBJ_INHERIT = $00000002;
OBJ_PERMANENT = $00000010;
OBJ_EXCLUSIVE = $00000020;
OBJ_CASE_INSENSITIVE = $00000040;
OBJ_OPENIF = $00000080;
OBJ_OPENLINK = $00000100;
OBJ_KERNEL_HANDLE = $00000200;
OBJ_FORCE_ACCESS_CHECK = $00000400;
OBJ_VALID_ATTRIBUTES = $000007F2;

type
PNTSTATUS = ^NTSTATUS;
NTSTATUS = Integer;
ULONG_PTR = Longword;
USHORT = Word;
PWSTR = LPWSTR;
HANDLE = THandle;
PVOID = Pointer;
CCHAR = Char;
LONG = Longint;

PUNICODE_STRING = ^UNICODE_STRING;

_UNICODE_STRING = Record
Length: USHORT;
MaximumLength: USHORT;
Buffer: PWSTR;
end;

UNICODE_STRING = _UNICODE_STRING;
PCUNICODE_STRING = ^UNICODE_STRING;
TUnicodeString = UNICODE_STRING;
PUnicodeString = PUNICODE_STRING;

PString = ^TString;

_STRING = Record
Length: USHORT;
MaximumLength: USHORT;
Buffer: PAnsiChar;
end;

TString = _STRING;
ANSI_STRING = _STRING;
PANSI_STRING = PString;

LPLARGE_INTEGER = ^LARGE_INTEGER;
{$IFDEF USE_DELPHI_TYPES}
_LARGE_INTEGER = Windows._LARGE_INTEGER;
LARGE_INTEGER = Windows.LARGE_INTEGER;
TLargeInteger = Windows.TLargeInteger;
{$ELSE}

_LARGE_INTEGER = Record
case Integer of
0:
(LowPart: DWORD; HighPart: LONG);
1:
(QuadPart: LONGLONG);
end;

LARGE_INTEGER = _LARGE_INTEGER;
TLargeInteger = LARGE_INTEGER;
{$ENDIF}
PLARGE_INTEGER = ^LARGE_INTEGER;
PLargeInteger = LPLARGE_INTEGER;
LPULARGE_INTEGER = ^ULARGE_INTEGER;
{$IFDEF USE_DELPHI_TYPES}
ULARGE_INTEGER = Windows.ULARGE_INTEGER;
TULargeInteger = Windows.TULargeInteger;
PULargeInteger = Windows.PULargeInteger;
{$ELSE}

ULARGE_INTEGER = record
case Integer of
0:
(LowPart: DWORD; HighPart: DWORD);
1:
(QuadPart: LONGLONG);
end;

TULargeInteger = ULARGE_INTEGER;
PULargeInteger = LPULARGE_INTEGER;
{$ENDIF}
PULARGE_INTEGER = ^ULARGE_INTEGER;

POBJECT_ATTRIBUTES = ^OBJECT_ATTRIBUTES;

_OBJECT_ATTRIBUTES = Record
Length: ULONG;
RootDirectory: HANDLE;
ObjectName: PUNICODE_STRING;
Attributes: ULONG;
SecurityDescriptor: PVOID; // Points to type SECURITY_DESCRIPTOR
SecurityQualityOfService: PVOID;
// Points to type SECURITY_QUALITY_OF_SERVICE
end;

OBJECT_ATTRIBUTES = _OBJECT_ATTRIBUTES;
TObjectAttributes = OBJECT_ATTRIBUTES;
PObjectAttributes = POBJECT_ATTRIBUTES;

_IO_STATUS_BLOCK = Record
Status: NTSTATUS;
Information: ULONG_PTR;
end;

IO_STATUS_BLOCK = _IO_STATUS_BLOCK;
PIO_STATUS_BLOCK = ^IO_STATUS_BLOCK;
TIOStatusBlock = IO_STATUS_BLOCK;
PIOStatusBlock = PIO_STATUS_BLOCK;
PIO_APC_ROUTINE = procedure(ApcContext: PVOID;
IoStatusBlock: PIO_STATUS_BLOCK; Reserved: ULONG); stdcall;

_EVENT_TYPE = (NotificationEvent, SynchronizationEvent);
EVENT_TYPE = _EVENT_TYPE;
PEVENT_TYPE = ^EVENT_TYPE;

_FILE_INFORMATION_CLASS = (FileFiller0, FileDirectoryInformation, // 1
FileFullDirectoryInformation, // 2
FileBothDirectoryInformation, // 3
FileBasicInformation, // 4 wdm
FileStandardInformation, // 5 wdm
FileInternalInformation, // 6
FileEaInformation, // 7
FileAccessInformation, // 8
FileNameInformation, // 9
FileRenameInformation, // 10
FileLinkInformation, // 11
FileNamesInformation, // 12
FileDispositionInformation, // 13
FilePositionInformation, // 14 wdm
FileFullEaInformation, // 15
FileModeInformation, // 16
FileAlignmentInformation, // 17
FileAllInformation, // 18
FileAllocationInformation, // 19
FileEndOfFileInformation, // 20 wdm
FileAlternateNameInformation, // 21
FileStreamInformation, // 22
FilePipeInformation, // 23
FilePipeLocalInformation, // 24
FilePipeRemoteInformation, // 25
FileMailslotQueryInformation, // 26
FileMailslotSetInformation, // 27
FileCompressionInformation, // 28
FileObjectIdInformation, // 29
FileCompletionInformation, // 30
FileMoveClusterInformation, // 31
FileQuotaInformation, // 32
FileReparsePointInformation, // 33
FileNetworkOpenInformation, // 34
FileAttributeTagInformation, // 35
FileTrackingInformation, // 36
FileMaximumInformation);
FILE_INFORMATION_CLASS = _FILE_INFORMATION_CLASS;
PFILE_INFORMATION_CLASS = ^FILE_INFORMATION_CLASS;

PFILE_BOTH_DIR_INFORMATION = ^FILE_BOTH_DIR_INFORMATION;

_FILE_BOTH_DIR_INFORMATION = Record
NextEntryOffset: ULONG;
FileIndex: ULONG;
CreationTime: LARGE_INTEGER;
LastAccessTime: LARGE_INTEGER;
LastWriteTime: LARGE_INTEGER;
ChangeTime: LARGE_INTEGER;
EndOfFile: LARGE_INTEGER;
AllocationSize: LARGE_INTEGER;
FileAttributes: ULONG;
FileNameLength: ULONG;
EaSize: ULONG;
ShortNameLength: CCHAR;
ShortName: array [0 .. 11] of WCHAR;
FileName: array [0 .. 0] of WCHAR;
end;

FILE_BOTH_DIR_INFORMATION = _FILE_BOTH_DIR_INFORMATION;
TFileBothDirInformation = FILE_BOTH_DIR_INFORMATION;
PFileBothDirInformation = PFILE_BOTH_DIR_INFORMATION;

function NT_SUCCESS(Status: NTSTATUS): boolean;
procedure InitializeObjectAttributes(p: POBJECT_ATTRIBUTES; n: PUNICODE_STRING;
a: ULONG; r: HANDLE; s: PVOID { PSECURITY_DESCRIPTOR } );
function NtCreateFile(FileHandle: PHANDLE; DesiredAccess: ACCESS_MASK;
ObjectAttributes: POBJECT_ATTRIBUTES; IoStatusBlock: PIO_STATUS_BLOCK;
AllocationSize: PLARGE_INTEGER; FileAttributes: ULONG; ShareAccess: ULONG;
CreateDisposition: ULONG; CreateOptions: ULONG; EaBuffer: PVOID;
EaLength: ULONG): NTSTATUS; stdcall;
function NtQueryDirectoryFile(FileHandle: HANDLE; Event: HANDLE;
ApcRoutine: PIO_APC_ROUTINE; ApcContext: PVOID;
IoStatusBlock: PIO_STATUS_BLOCK; FileInformation: PVOID;
FileInformationLength: ULONG; FileInformationClass: FILE_INFORMATION_CLASS;
ReturnSingleEntry: ByteBool; FileName: PUNICODE_STRING; RestartScan: ByteBool)
: NTSTATUS; stdcall;
function NtCreateEvent(EventHandle: PHANDLE; DesiredAccess: ACCESS_MASK;
ObjectAttributes: POBJECT_ATTRIBUTES; EventType: EVENT_TYPE;
InitialState: ByteBool): NTSTATUS; stdcall;
function NtWaitForSingleObject(HANDLE: HANDLE; Alertable: ByteBool;
Timeout: PLARGE_INTEGER): NTSTATUS; stdcall;
procedure RtlInitUnicodeString(DestinationString: PUNICODE_STRING;
SourceString: LPCWSTR); stdcall;
function RtlUnicodeStringToAnsiString(DestinationString: PANSI_STRING;
SourceString: PUNICODE_STRING; AllocateDestinationString: ByteBool)
: NTSTATUS; stdcall;

implementation

function NT_SUCCESS(Status: NTSTATUS): boolean;
begin
result := Status >= 0
end;

procedure InitializeObjectAttributes(p: POBJECT_ATTRIBUTES; n: PUNICODE_STRING;
a: ULONG; r: HANDLE; s: PVOID { PSECURITY_DESCRIPTOR } );
begin
p^.Length := sizeof(OBJECT_ATTRIBUTES);
p^.RootDirectory := r;
p^.Attributes := a;
p^.ObjectName := n;
p^.SecurityDescriptor := s;
p^.SecurityQualityOfService := nil;
end;

function NtCreateFile; external ntdll name 'NtCreateFile';
function NtQueryDirectoryFile; external ntdll name 'NtQueryDirectoryFile';
function NtCreateEvent; external ntdll name 'NtCreateEvent';
function NtWaitForSingleObject; external ntdll name 'NtWaitForSingleObject';
procedure RtlInitUnicodeString; external ntdll name 'RtlInitUnicodeString';
function RtlUnicodeStringToAnsiString;
external ntdll name 'RtlUnicodeStringToAnsiString';

end.

برنامه :

program NativeFileListing;

{$APPTYPE CONSOLE}

uses
Windows,
NativeFileApi in 'NativeFileApi.pas';

// This simple test program demonstrates opening the root directory of the C:\ volume and enumerating its contents
//
// Contents provided by
// OSR Open Systems Resources, Inc.
//
// port by Krid

var
RootDirectoryName : UNICODE_STRING;
EntryName : UNICODE_STRING;
RootAnsiName : ANSI_STRING;
RootDirectoryAttributes: OBJECT_ATTRIBUTES;
Status : NTSTATUS;
RootDirectoryHandle : HANDLE;
Iosb: IO_STATUS_BLOCK;
Event : HANDLE;
Buffer:array [0..65535] of byte;
DirInformation : PFILE_BOTH_DIR_INFORMATION;
begin
// We use the name DosDevices rather than ?? so that it works on NT 3.51 as well as NT 4.0
RtlInitUnicodeString(@RootDirectoryName, '\DosDevices\C:\Windows\System32\');
// Now open it
InitializeObjectAttributes(@RootDirectoryAttribute s,
@RootDirectoryName,OBJ_CASE_INSENSITIVE,
0, // absolute open, no relative directory handle
nil); // no security descriptor necessary
Status := NtCreateFile(@RootDirectoryHandle,
GENERIC_READ,
@RootDirectoryAttributes,
@Iosb,
nil, // no meaning for allocation
FILE_ATTRIBUTE_DIRECTORY, // MUST be a directory
FILE_SHARE_READ or FILE_SHARE_WRITE or FILE_SHARE_DELETE, // share all
FILE_OPEN, // must already exist
FILE_DIRECTORY_FILE, // MUST be a directory
nil,
0);
if not NT_SUCCESS(Status) then
begin
writeln('Unable to open root directory, error =', Status);
halt(Status);
end;
// Create an event
Status:= NtCreateEvent (@Event,
GENERIC_ALL,
nil, // no object attributes
NotificationEvent,
FALSE);
if not NT_SUCCESS (Status) then
begin
writeln('Event creation failed with error =', Status);
halt(Status);
end;
// We pass NO NAME which is the same as *.*
Status := NtQueryDirectoryFile(RootDirectoryHandle,
Event,
nil, // No APC routine
nil, // No APC context
@ Iosb,
@ Buffer,
length (Buffer),
FileBothDirectoryInformation,
FALSE,
nil,
FALSE);
// If the directory operation is in progress, wait for it to finish.
if (Status = STATUS_PENDING) then
Status := NtWaitForSingleObject(Event, TRUE, nil);
// Check for errors.
if not NT_SUCCESS (Status) then
begin
writeln ('Unable to query directory contents, error =', Status);
halt (Status)
end;

// Note that as this is an example we're not ITERATING over the directory. To
// Do so we should use a loop and query the directory AGAIN until we get back
// STATUS_NO_MORE_FILES. If the directory was TOTALLY EMPTY we'd get back
// STATUS_NO_SUCH_FILE - but only the ROOT directory can ever be TOTALLY EMPTY.
DirInformation:= PFILE_BOTH_DIR_INFORMATION (@ Buffer);
writeln('File / Dir Name, Allocation_Size');
writeln('------------------------------'+ #13 + #10);
while true do
begin
EntryName.MaximumLength:= DirInformation^.FileNameLength;
EntryName.Length:= DirInformation^.FileNameLength;
EntryName.Buffer:= @DirInformation^.FileName;
RtlUnicodeStringToAnsiString (@RootAnsiName, @EntryName, TRUE);
// Dump the full name of the file. We could dump the other information
// Here as well, but we'll keep the example shorter instead.
writeln (RootAnsiName.Buffer, ',', DirInformation ^. AllocationSize.QuadPart);
// If there is no offset in the entry, the buffer has been exhausted.
if (DirInformation ^. NextEntryOffset = 0) then break else
begin
// Advance to the next entry.
DirInformation:= PFILE_BOTH_DIR_INFORMATION (Cardinal (DirInformation) + DirInformation ^. NextEntryOffset);
end;
end; // while
// Note that we skip closing our handles. The process death will do it for us.
Readln;
halt (STATUS_SUCCESS)
end.

منبع (http://www.ic0de.org/showthread.php?9610-using-native-ntquerydirectoryfile-api-to-list-files)

[بهروز عباسی]

نمونه برنامه دلفی برای ارتباط با درایور ها (سورسی که به زبان سی است:لبخند:) شامل متدهای زیر:



Registering the driver in the system
Dynamic loading driver
Dynamic unloading drivers
Removing the driver from the system
Calculation IOCTO code
and three methods of communication with the driver.



unit dDriver;

interface
uses Windows;
const
METHOD_BUFFERED = 0;
METHOD_NEITHER = 3;
FILE_ANY_ACCESS = 0;
FILE_READ_ACCESS = 1;
FILE_WRITE_ACCESS = 2;

FILE_DEVICE_UNKNOWN = $00000022;
Type
NTStatus = cardinal;
TString = array[0..MAX_PATH] of char;
PUnicodeString = ^TUnicodeString;
TUnicodeString = record
Length: WORD;
MaximumLength: WORD;
Buffer: PWideChar;
end;

const
STATUS_OBJECT_NAME_EXISTS = $40000000;
OBJ_CASE_INSENSITIVE = $00000040;
OBJ_OPENIF = $00000080;
DIRECTORY_TRAVERSE = $0002;
DIRECTORY_CREATE_OBJECT = $0004;

procedure RtlInitUnicodeString(DestinationString: PUnicodeString; SourceString: PWideChar);
stdcall; external 'ntdll.dll';
function ZwLoadDriver(DriverServiceName: PUnicodeString): cardinal;
stdcall;external 'ntdll.dll';

function ZwUnloadDriver(DriverServiceName: PUnicodeString): cardinal;
stdcall;external 'ntdll.dll';
type
TDriver = class
private
DrName: TString;
DrPath: TString;
hDriver: Cardinal;
RegisteredStatus,
LoadedStatus,
UnRegisteredStatus,
UnLoadStatus: boolean;
public
constructor Create(Name,Path: PCHAR); //??????? ??????-???????.???????? ???????,???? ? ????????
function Registered: boolean; //??????????? ???????? ? ???????. True - ?????
function Load: boolean; //???????????? ????????? ????????,True - ?????
function Start(Popitka:byte = 0):boolean; //???? ???? ???????? ??????? Registered,? ?????
//Load,?? ????? ??????? ????? Start.???????? ??????????? ??????? ???????? ????????
function UnLoad: boolean; //???????????? ?????????? ????????.True - ?????
function UnRegistered: boolean; //??????? ??????????? ???????? ?? ???????
function Stop:boolean; //????????? ??????? ? UnRegistered.
function IOCTL_CODE(DeviceType, FunctionNo, Method, Access: Integer): Integer; //???????? IOCTL ??????
function WriteToDriver(Var WriteBuf; SizeW: DWORD): integer; //?????? ????? ?? ????????,???????? WriteFile
function ReadFromDriver(Var ReadBuf; SizeR: DWORD): integer; //????? ????? ? ???????,????????? ReadFile
function ReadWrite(Var ToDroverBuf; SizeOfToDroverBuf: DWORD; CTL_CODE: DWORD; //????? ????? ? ????????? ? ???????? ??????.
Var FromDriverBuf; SizeOfFromDriverBuf: DWORD): Integer; //???????????? DeviceIOcontrol
property MyDriverName: TString read DrName; //???????? ???????? ???????
property MyDriverPath: TString read DrPath; //???? ? ????????
//property MyDriverHandle: Cardinal read hDriver; //???????? hDriver

property MyRegisteredStatus: boolean read RegisteredStatus; //???????
property MyLoadedStatus: boolean read LoadedStatus;
property MyUnRegisteredStatus: boolean read UnRegisteredStatus;
property MyUnLoadStatus: boolean read UnLoadStatus;
end;

implementation
const
DrvReg = '\registry\machine\system\CurrentControlSet\Servic es\';

function EnablePrivilegeEx(Process: dword; lpPrivilegeName: PChar):Boolean;
var
hToken: dword;
NameValue: Int64;
tkp: TOKEN_PRIVILEGES;
ReturnLength: dword;
begin
Result:=false;
OpenProcessToken(Process, TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken);
if not LookupPrivilegeValue(nil, lpPrivilegeName, NameValue) then
begin
CloseHandle(hToken);
exit;
end;
tkp.PrivilegeCount := 1;
tkp.Privileges[0].Luid := NameValue;
tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
AdjustTokenPrivileges(hToken, false, tkp, SizeOf(TOKEN_PRIVILEGES), tkp, ReturnLength);
if GetLastError() <> ERROR_SUCCESS then
begin
CloseHandle(hToken);
exit;
end;
Result:=true;
CloseHandle(hToken);
end;

{ TDriver }

constructor TDriver.Create(Name, Path: PCHAR);
begin
inherited Create;
lStrCpy(DrName,Name);
lStrCpy(DrPath,Path);

RegisteredStatus:= False; LoadedStatus:= False;
UnRegisteredStatus:= False; UnLoadStatus:= False;
hDriver:=0;
//EnablePrivilegeEx(GetCurrentProcessId, 'SeLoadDriverPrivilege'); //SetDebugPrivileges
end;

function TDriver.Load: boolean;
var
Image: TUnicodeString;
Buff: array [0..MAX_PATH] of WideChar;
begin
StringToWideChar(DrvReg + DrName, Buff, MAX_PATH);
RtlInitUnicodeString(@Image, Buff);
Result := ZwLoadDriver(@Image) = 0;
LoadedStatus:= Result;
end;

function TDriver.Registered: boolean;
var
Key, Key2: HKEY;
dType: dword;
Err: dword;
NtPath: array[0..MAX_PATH] of Char;
begin
Result := false;
dType := 1;
Err := RegOpenKeyA(HKEY_LOCAL_MACHINE, 'system\CurrentControlSet\Services', Key);
if Err = ERROR_SUCCESS then
begin
Err := RegCreateKeyA(Key, drName, Key2);
if Err <> ERROR_SUCCESS then Err := RegOpenKeyA(Key, drName, Key2);
if Err = ERROR_SUCCESS then
begin
lstrcpy(NtPath, PChar('\??\' + drPath));
RegSetValueExA(Key2, 'ImagePath', 0, REG_SZ, @NtPath, lstrlen(NtPath));
RegSetValueExA(Key2, 'Type', 0, REG_DWORD, @dType, SizeOf(dword));
RegCloseKey(Key2);
Result := true;
end;
RegCloseKey(Key);
end;
RegisteredStatus:= Result;
end;

function TDriver.Start(Popitka:byte = 0):boolean;
Var F:Boolean;
i:byte;
Begin
F:=false;
i:=0;
repeat
F:=(Registered and Load);
if not F then
begin
UnLoad;
UnRegistered;
end;
inc(i);
if i = Popitka then
Break;
until F;
Result:=F;
End;

function TDriver.UnLoad: boolean;
var
Image: TUnicodeString;
Buff: array [0..MAX_PATH] of WideChar;
begin
StringToWideChar(DrvReg + DrName, Buff, MAX_PATH);
RtlInitUnicodeString(@Image, Buff);
Result := ZwUnloadDriver(@Image) = 0;
UnLoadStatus:= Result;
end;

function TDriver.UnRegistered: boolean;
var
Key: HKEY;
begin
Result := false;
if RegOpenKeyA(HKEY_LOCAL_MACHINE, 'system\CurrentControlSet\Services', Key) = ERROR_SUCCESS then
begin
RegDeleteKey(Key, PChar(drName+'\Enum'));
RegDeleteKey(Key, PChar(drName+'\Security'));
Result := RegDeleteKey(Key, drName) = ERROR_SUCCESS;
RegCloseKey(Key);
end;
UnRegisteredStatus:= Result;
end;

function TDriver.Stop:boolean;
Begin
Result:= UnLoad and UnRegistered;
End;

function TDriver.ReadFromDriver(var ReadBuf; SizeR: DWORD): integer;
Var H,N:Dword;
begin
ZeroMemory(@ReadBuf,SizeR);
Result:=Integer(LoadedStatus and RegisteredStatus);
if Result = 0 then
exit;
h:= CreateFile(PCHAR('\\.\'+DrName),GENERIC_ALL,0,nil, OPEN_EXISTING,0,0);
if h = INVALID_HANDLE_VALUE then
begin
Result:= -1;
exit;
end;
ReadFile(h,ReadBuf,SizeR,N,0);
Result:=N;
CloseHandle(h);
end;

function TDriver.WriteToDriver(var WriteBuf; SizeW: DWORD): integer;
Var H,N:Dword;
begin
Result:=Integer(LoadedStatus and RegisteredStatus);
if Result = 0 then exit;
h:= CreateFile(PCHAR('\\.\'+DrName),GENERIC_ALL,0,nil, OPEN_EXISTING,0,0);
if h = INVALID_HANDLE_VALUE then
begin
Result:= -1;
exit;
end;
WriteFile(h,WriteBuf,SizeW,N,0);
Result:=N;
CloseHandle(h);
end;

function TDriver.ReadWrite(Var ToDroverBuf; SizeOfToDroverBuf:
DWORD; CTL_CODE: DWORD;
Var FromDriverBuf; SizeOfFromDriverBuf: DWORD): Integer;
var
Bytes: dword;
begin
Result:= -1;
hDriver := CreateFile(pChar('\\.\'+DrName),GENERIC_ALL,0,nil, OPEN_EXISTING,0,0);
if hDriver = INVALID_HANDLE_VALUE then exit;
if @FromDriverBuf <> nil then ZeroMemory(@FromDriverBuf,SizeOfFromDriverBuf);
if DeviceIoControl(hDriver,
CTL_CODE,
@ToDroverBuf,SizeOfToDroverBuf, //??????,?????????? ? ???????
@FromDriverBuf, SizeOfFromDriverBuf, //??????,??????? ??????? ???????
Bytes, nil) then
Result:=Bytes;
CloseHandle(hDriver);
end;

function TDriver.IOCTL_CODE(DeviceType, FunctionNo, Method, Access: Integer): Integer;
begin
Result :=( (DeviceType shl 16) or (Access shl 14) or (FunctionNo shl 2) or Method);
end;

end.




program DriverLoader;
{$Apptype Console}
uses
windows,dDriver,SysUtils;
Var
Name,Path:String;
Driver: TDriver;
DataToDriver,DataFromDriver:Array[0..19] of char;
CTL:DWORD;
begin
Name:= 'Share';
Path:='D:\Sniffer\Share\i386\Share.sys';
WriteLn('Name: ',Name);
WriteLn('Path: ',Path);
Driver:= TDriver.Create(pChar(Name),pChar(Path));

{if Driver.Registered then
WriteLn('Registered!') else
WriteLn('Not Registered!');

if Driver.Load then
WriteLn('Loaded!') else
WriteLn('Not Loaded!');}
Driver.Start(3);
CTL:=Driver.IOCTL_CODE(FILE_DEVICE_UNKNOWN,$803,ME THOD_BUFFERED,FILE_ANY_ACCESS);
//???????? ???????? ???????? Hellow...
DataToDriver:='Project1.exe';
Driver.WriteToDriver(DataToDriver,Length(DataToDri ver));
//????????? ???????? ?? ???????? Hellow.
Driver.ReadFromDriver(DataFromDriver,SizeOf(DataFr omDriver));
WriteLn(DataFromDriver);
//????????? ? ?? ? ??
FillChar(DataToDriver,0,SizeOf(DataToDriver)); FillChar(DataFromDriver,0,SizeOf(DataFromDriver));
DataToDriver:='Hellow against!';
Driver.ReadWrite(DataToDriver,SizeOf(DataToDriver) ,CTL,DataFromDriver,SizeOf(DataToDriver));
WriteLn(DataFromDriver);
{if Driver.UnLoad then
WriteLn('UnLoad!') else
WriteLn('Not UnLoad!');

if Driver.UnRegistered then
WriteLn('UnRegistered!') else
WriteLn('Not UnRegistered!');}
Driver.Stop;
ReadLn;
end.


#include "ntddk.h"
#define NT_DEVICE_NAME L"\\Device\\Share"
#define WIN32_DEVICE_NAME L"\\DosDevices\\SHare"
#define DWORD unsigned long
#define SECTION_SIZE 255

#define IOCTL_SHARE CTL_CODE (FILE_DEVICE_UNKNOWN, 0x803, METHOD_BUFFERED, FILE_ANY_ACCESS)

NTSTATUS CtlCreate(IN PDEVICE_OBJECT, IN PIRP);
NTSTATUS CtlClose(IN PDEVICE_OBJECT, IN PIRP);
NTSTATUS CtlDriverDispatch(IN PDEVICE_OBJECT DeviceObject, IN PIRP Irp);
NTSTATUS CtlDriverDispatchWrite(IN PDEVICE_OBJECT,IN PIRP); //???? ?????????? ????? WriteFile
NTSTATUS CtlDriverDispatchRead(IN PDEVICE_OBJECT,IN PIRP); //???? ?????????? ????? ReadFile
NTSTATUS UnloadDriver(IN PDRIVER_OBJECT pDriverObject); //???? ?????????? ????? DeviceIOControl

NTSTATUS DriverEntry(IN PDRIVER_OBJECT pDriverObject, IN PUNICODE_STRING RegistryPath)
{
PDEVICE_OBJECT pDeviceObject;
UNICODE_STRING uniNtName;
UNICODE_STRING uniWin32Name;
RtlInitUnicodeString(&uniNtName, NT_DEVICE_NAME);
RtlInitUnicodeString(&uniWin32Name, WIN32_DEVICE_NAME);

IoCreateSymbolicLink(&uniWin32Name, &uniNtName);
IoCreateDevice(pDriverObject,0,&uniNtName,FILE_DEV ICE_UNKNOWN,0,FALSE,&pDeviceObject);

pDriverObject->MajorFunction[IRP_MJ_CREATE]=CtlCreate;
pDriverObject->MajorFunction[IRP_MJ_CLOSE]=CtlClose;
pDriverObject->MajorFunction[IRP_MJ_DEVICE_CONTROL]=CtlDriverDispatch;
pDriverObject->MajorFunction[IRP_MJ_WRITE] = CtlDriverDispatchWrite;
pDriverObject->MajorFunction[IRP_MJ_READ] = CtlDriverDispatchRead;
pDriverObject->DriverUnload = UnloadDriver;
DbgPrint("Driver has been loaded!");

return STATUS_SUCCESS;
}

NTSTATUS CtlCreate(IN PDEVICE_OBJECT pDeviceObject,IN PIRP Irp)
{
Irp->IoStatus.Status=STATUS_SUCCESS;
Irp->IoStatus.Information=0;
IoCompleteRequest(Irp,IO_NO_INCREMENT);
return STATUS_SUCCESS;
}

NTSTATUS CtlClose(IN PDEVICE_OBJECT pDeviceObject,IN PIRP Irp)
{
Irp->IoStatus.Status=STATUS_SUCCESS;
Irp->IoStatus.Information=0;
IoCompleteRequest(Irp,IO_NO_INCREMENT);
return STATUS_SUCCESS;
}

NTSTATUS UnloadDriver(IN PDRIVER_OBJECT pDriverObject)
{
PDEVICE_OBJECT deviceObject = pDriverObject->DeviceObject;
UNICODE_STRING uniWin32NameString;
RtlInitUnicodeString( &uniWin32NameString, WIN32_DEVICE_NAME );
IoDeleteSymbolicLink( &uniWin32NameString );
IoDeleteDevice( deviceObject );
DbgPrint("Driver has been Unloaded!");
return STATUS_SUCCESS;
}

NTSTATUS CtlDriverDispatchWrite(IN PDEVICE_OBJECT pDeviceObject,IN PIRP Irp)
{
//? Irp->UserBuffer ????? ??,??? ?????? ???????????? WriteFile??
PIO_STACK_LOCATION pIrpStack;
pIrpStack=IoGetCurrentIrpStackLocation(Irp);
Irp->IoStatus.Information = 0;

if (pIrpStack->MajorFunction == IRP_MJ_WRITE)
{
__try
{
ULONG Length = pIrpStack->Parameters.Write.Length;
DbgPrint("Recv:%s \n",Irp->UserBuffer);
}
__except(EXCEPTION_EXECUTE_HANDLER)
{
DbgPrint("Error");
}
}

Irp->IoStatus.Status=STATUS_SUCCESS;
IoCompleteRequest (Irp,IO_NO_INCREMENT);
return STATUS_SUCCESS;
}

NTSTATUS CtlDriverDispatchRead(IN PDEVICE_OBJECT pDeviceObject,IN PIRP Irp)
{
//???? ???????? ? Irp->UserBuffer ??,????????? ? ?????,??????? ????? ? ReadFile ?? ??????????
PIO_STACK_LOCATION pIrpStack;
pIrpStack=IoGetCurrentIrpStackLocation(Irp);

DbgPrint("CtlDriverDispatchRead");

if (pIrpStack->MajorFunction == IRP_MJ_READ)
{
__try
{
RtlCopyMemory(Irp->UserBuffer,"Hellow!FromDrover",18);
}
__except(EXCEPTION_EXECUTE_HANDLER)
{
DbgPrint("Error");
}
}

Irp->IoStatus.Information = 0;
Irp->IoStatus.Status=STATUS_SUCCESS;

IoCompleteRequest (Irp,IO_NO_INCREMENT);
return STATUS_SUCCESS;
}

NTSTATUS CtlDriverDispatch(IN PDEVICE_OBJECT pDeviceObject,IN PIRP Irp)
{
//? ?????? ?????? ??????? ????? ????? Irp->AssociatedIrp.SystemBuffer ???.
PIO_STACK_LOCATION pIrpStack;
PVOID pBuff = Irp->UserBuffer; //?????? ? ?????
PVOID pBuff_In = Irp->AssociatedIrp.SystemBuffer; //????? ?? ?????
DWORD *Pid = NULL;
DWORD PID = 0;
pIrpStack=IoGetCurrentIrpStackLocation(Irp);
DbgPrint("CtlDriverDispatch...\n");

DbgPrint("CTL: %d",IOCTL_SHARE);
if (pIrpStack->Parameters.DeviceIoControl.IoControlCode == IOCTL_SHARE)// ???? ????? IOCTL ??????,??
{//?????? ???.
__try
{
DbgPrint("We are in SEH mdoe!\n");
Pid = pBuff_In;
DbgPrint("RECV %s \n",pBuff_In);

RtlCopyMemory(pBuff,"12345",5);
DbgPrint("Sended: %s","12345");
}
__except(EXCEPTION_EXECUTE_HANDLER)
{
DbgPrint("Error");
}
}

Irp->IoStatus.Information = 0;
Irp->IoStatus.Status=STATUS_SUCCESS;

IoCompleteRequest (Irp,IO_NO_INCREMENT);
return STATUS_SUCCESS;
}



من اینو تست نکردم (مال خودم رو دارم:بامزه:)

منبع برادران روس (http://delfcode.ru/forum/35-1037-1&usg=ALkJrhgtAUzO9KRVqYuF_YAqxwDDNn8LNA)

شب خوش

[بهروز عباسی]

ممکنه در برخی شرایط خاص بخواهید اندازه یک تابع رو به دست بیارید در این صورت می تونید از یونیت زیر استفاده کنید (مثلاً: Injection :شیطان:)

{
---------------------------------------------------
Opcode Length Disassembler.
Coded By Ms-Rem ( Ms-Rem@yandex.ru ) ICQ 286370715
---------------------------------------------------
12.08.2005 - fixed many bugs...
09.08.2005 - fixed bug with 0F BA opcode.
07.08.2005 - added SSE, SSE2, SSE3 and 3Dnow instruction support.
06.08.2005 - fixed bug with F6 and F7 opcodes.
29.07.2005 - fixed bug with OP_WORD opcodes.
}
unit LDasm;

interface

type
dword = cardinal;
ppbyte = ^pbyte;

function SizeOfCode(Code: pointer; pOpcode: ppbyte): dword;
function SizeOfProc(Proc: pointer): dword;
function IsRelativeCmd(pOpcode: pbyte): boolean;

implementation

const
OP_NONE = $00;
OP_MODRM = $01;
OP_DATA_I8 = $02;
OP_DATA_I16 = $04;
OP_DATA_I32 = $08;
OP_DATA_PRE66_67 = $10;
OP_WORD = $20;
OP_REL32 = $40;


const
OpcodeFlags: array [$00..$FF] of byte =
(
OP_MODRM, // 00
OP_MODRM, // 01
OP_MODRM, // 02
OP_MODRM, // 03
OP_DATA_I8, // 04
OP_DATA_PRE66_67, // 05
OP_NONE, // 06
OP_NONE, // 07
OP_MODRM, // 08
OP_MODRM, // 09
OP_MODRM, // 0A
OP_MODRM, // 0B
OP_DATA_I8, // 0C
OP_DATA_PRE66_67, // 0D
OP_NONE, // 0E
OP_NONE, // 0F
OP_MODRM, // 10
OP_MODRM, // 11
OP_MODRM, // 12
OP_MODRM, // 13
OP_DATA_I8, // 14
OP_DATA_PRE66_67, // 15
OP_NONE, // 16
OP_NONE, // 17
OP_MODRM, // 18
OP_MODRM, // 19
OP_MODRM, // 1A
OP_MODRM, // 1B
OP_DATA_I8, // 1C
OP_DATA_PRE66_67, // 1D
OP_NONE, // 1E
OP_NONE, // 1F
OP_MODRM, // 20
OP_MODRM, // 21
OP_MODRM, // 22
OP_MODRM, // 23
OP_DATA_I8, // 24
OP_DATA_PRE66_67, // 25
OP_NONE, // 26
OP_NONE, // 27
OP_MODRM, // 28
OP_MODRM, // 29
OP_MODRM, // 2A
OP_MODRM, // 2B
OP_DATA_I8, // 2C
OP_DATA_PRE66_67, // 2D
OP_NONE, // 2E
OP_NONE, // 2F
OP_MODRM, // 30
OP_MODRM, // 31
OP_MODRM, // 32
OP_MODRM, // 33
OP_DATA_I8, // 34
OP_DATA_PRE66_67, // 35
OP_NONE, // 36
OP_NONE, // 37
OP_MODRM, // 38
OP_MODRM, // 39
OP_MODRM, // 3A
OP_MODRM, // 3B
OP_DATA_I8, // 3C
OP_DATA_PRE66_67, // 3D
OP_NONE, // 3E
OP_NONE, // 3F
OP_NONE, // 40
OP_NONE, // 41
OP_NONE, // 42
OP_NONE, // 43
OP_NONE, // 44
OP_NONE, // 45
OP_NONE, // 46
OP_NONE, // 47
OP_NONE, // 48
OP_NONE, // 49
OP_NONE, // 4A
OP_NONE, // 4B
OP_NONE, // 4C
OP_NONE, // 4D
OP_NONE, // 4E
OP_NONE, // 4F
OP_NONE, // 50
OP_NONE, // 51
OP_NONE, // 52
OP_NONE, // 53
OP_NONE, // 54
OP_NONE, // 55
OP_NONE, // 56
OP_NONE, // 57
OP_NONE, // 58
OP_NONE, // 59
OP_NONE, // 5A
OP_NONE, // 5B
OP_NONE, // 5C
OP_NONE, // 5D
OP_NONE, // 5E
OP_NONE, // 5F
OP_NONE, // 60
OP_NONE, // 61
OP_MODRM, // 62
OP_MODRM, // 63
OP_NONE, // 64
OP_NONE, // 65
OP_NONE, // 66
OP_NONE, // 67
OP_DATA_PRE66_67, // 68
OP_MODRM or OP_DATA_PRE66_67, // 69
OP_DATA_I8, // 6A
OP_MODRM or OP_DATA_I8, // 6B
OP_NONE, // 6C
OP_NONE, // 6D
OP_NONE, // 6E
OP_NONE, // 6F
OP_DATA_I8, // 70
OP_DATA_I8, // 71
OP_DATA_I8, // 72
OP_DATA_I8, // 73
OP_DATA_I8, // 74
OP_DATA_I8, // 75
OP_DATA_I8, // 76
OP_DATA_I8, // 77
OP_DATA_I8, // 78
OP_DATA_I8, // 79
OP_DATA_I8, // 7A
OP_DATA_I8, // 7B
OP_DATA_I8, // 7C
OP_DATA_I8, // 7D
OP_DATA_I8, // 7E
OP_DATA_I8, // 7F
OP_MODRM or OP_DATA_I8, // 80
OP_MODRM or OP_DATA_PRE66_67, // 81
OP_MODRM or OP_DATA_I8, // 82
OP_MODRM or OP_DATA_I8, // 83
OP_MODRM, // 84
OP_MODRM, // 85
OP_MODRM, // 86
OP_MODRM, // 87
OP_MODRM, // 88
OP_MODRM, // 89
OP_MODRM, // 8A
OP_MODRM, // 8B
OP_MODRM, // 8C
OP_MODRM, // 8D
OP_MODRM, // 8E
OP_MODRM, // 8F
OP_NONE, // 90
OP_NONE, // 91
OP_NONE, // 92
OP_NONE, // 93
OP_NONE, // 94
OP_NONE, // 95
OP_NONE, // 96
OP_NONE, // 97
OP_NONE, // 98
OP_NONE, // 99
OP_DATA_I16 or OP_DATA_PRE66_67, // 9A
OP_NONE, // 9B
OP_NONE, // 9C
OP_NONE, // 9D
OP_NONE, // 9E
OP_NONE, // 9F
OP_DATA_PRE66_67, // A0
OP_DATA_PRE66_67, // A1
OP_DATA_PRE66_67, // A2
OP_DATA_PRE66_67, // A3
OP_NONE, // A4
OP_NONE, // A5
OP_NONE, // A6
OP_NONE, // A7
OP_DATA_I8, // A8
OP_DATA_PRE66_67, // A9
OP_NONE, // AA
OP_NONE, // AB
OP_NONE, // AC
OP_NONE, // AD
OP_NONE, // AE
OP_NONE, // AF
OP_DATA_I8, // B0
OP_DATA_I8, // B1
OP_DATA_I8, // B2
OP_DATA_I8, // B3
OP_DATA_I8, // B4
OP_DATA_I8, // B5
OP_DATA_I8, // B6
OP_DATA_I8, // B7
OP_DATA_PRE66_67, // B8
OP_DATA_PRE66_67, // B9
OP_DATA_PRE66_67, // BA
OP_DATA_PRE66_67, // BB
OP_DATA_PRE66_67, // BC
OP_DATA_PRE66_67, // BD
OP_DATA_PRE66_67, // BE
OP_DATA_PRE66_67, // BF
OP_MODRM or OP_DATA_I8, // C0
OP_MODRM or OP_DATA_I8, // C1
OP_DATA_I16, // C2
OP_NONE, // C3
OP_MODRM, // C4
OP_MODRM, // C5
OP_MODRM or OP_DATA_I8, // C6
OP_MODRM or OP_DATA_PRE66_67, // C7
OP_DATA_I8 or OP_DATA_I16, // C8
OP_NONE, // C9
OP_DATA_I16, // CA
OP_NONE, // CB
OP_NONE, // CC
OP_DATA_I8, // CD
OP_NONE, // CE
OP_NONE, // CF
OP_MODRM, // D0
OP_MODRM, // D1
OP_MODRM, // D2
OP_MODRM, // D3
OP_DATA_I8, // D4
OP_DATA_I8, // D5
OP_NONE, // D6
OP_NONE, // D7
OP_WORD, // D8
OP_WORD, // D9
OP_WORD, // DA
OP_WORD, // DB
OP_WORD, // DC
OP_WORD, // DD
OP_WORD, // DE
OP_WORD, // DF
OP_DATA_I8, // E0
OP_DATA_I8, // E1
OP_DATA_I8, // E2
OP_DATA_I8, // E3
OP_DATA_I8, // E4
OP_DATA_I8, // E5
OP_DATA_I8, // E6
OP_DATA_I8, // E7
OP_DATA_PRE66_67 or OP_REL32, // E8
OP_DATA_PRE66_67 or OP_REL32, // E9
OP_DATA_I16 or OP_DATA_PRE66_67, // EA
OP_DATA_I8, // EB
OP_NONE, // EC
OP_NONE, // ED
OP_NONE, // EE
OP_NONE, // EF
OP_NONE, // F0
OP_NONE, // F1
OP_NONE, // F2
OP_NONE, // F3
OP_NONE, // F4
OP_NONE, // F5
OP_MODRM, // F6
OP_MODRM, // F7
OP_NONE, // F8
OP_NONE, // F9
OP_NONE, // FA
OP_NONE, // FB
OP_NONE, // FC
OP_NONE, // FD
OP_MODRM, // FE
OP_MODRM or OP_REL32 // FF
);

OpcodeFlagsExt: array [$00..$FF] of byte =
(
OP_MODRM, // 00
OP_MODRM, // 01
OP_MODRM, // 02
OP_MODRM, // 03
OP_NONE, // 04
OP_NONE, // 05
OP_NONE, // 06
OP_NONE, // 07
OP_NONE, // 08
OP_NONE, // 09
OP_NONE, // 0A
OP_NONE, // 0B
OP_NONE, // 0C
OP_MODRM, // 0D
OP_NONE, // 0E
OP_MODRM or OP_DATA_I8, // 0F
OP_MODRM, // 10
OP_MODRM, // 11
OP_MODRM, // 12
OP_MODRM, // 13
OP_MODRM, // 14
OP_MODRM, // 15
OP_MODRM, // 16
OP_MODRM, // 17
OP_MODRM, // 18
OP_NONE, // 19
OP_NONE, // 1A
OP_NONE, // 1B
OP_NONE, // 1C
OP_NONE, // 1D
OP_NONE, // 1E
OP_NONE, // 1F
OP_MODRM, // 20
OP_MODRM, // 21
OP_MODRM, // 22
OP_MODRM, // 23
OP_MODRM, // 24
OP_NONE, // 25
OP_MODRM, // 26
OP_NONE, // 27
OP_MODRM, // 28
OP_MODRM, // 29
OP_MODRM, // 2A
OP_MODRM, // 2B
OP_MODRM, // 2C
OP_MODRM, // 2D
OP_MODRM, // 2E
OP_MODRM, // 2F
OP_NONE, // 30
OP_NONE, // 31
OP_NONE, // 32
OP_NONE, // 33
OP_NONE, // 34
OP_NONE, // 35
OP_NONE, // 36
OP_NONE, // 37
OP_NONE, // 38
OP_NONE, // 39
OP_NONE, // 3A
OP_NONE, // 3B
OP_NONE, // 3C
OP_NONE, // 3D
OP_NONE, // 3E
OP_NONE, // 3F
OP_MODRM, // 40
OP_MODRM, // 41
OP_MODRM, // 42
OP_MODRM, // 43
OP_MODRM, // 44
OP_MODRM, // 45
OP_MODRM, // 46
OP_MODRM, // 47
OP_MODRM, // 48
OP_MODRM, // 49
OP_MODRM, // 4A
OP_MODRM, // 4B
OP_MODRM, // 4C
OP_MODRM, // 4D
OP_MODRM, // 4E
OP_MODRM, // 4F
OP_MODRM, // 50
OP_MODRM, // 51
OP_MODRM, // 52
OP_MODRM, // 53
OP_MODRM, // 54
OP_MODRM, // 55
OP_MODRM, // 56
OP_MODRM, // 57
OP_MODRM, // 58
OP_MODRM, // 59
OP_MODRM, // 5A
OP_MODRM, // 5B
OP_MODRM, // 5C
OP_MODRM, // 5D
OP_MODRM, // 5E
OP_MODRM, // 5F
OP_MODRM, // 60
OP_MODRM, // 61
OP_MODRM, // 62
OP_MODRM, // 63
OP_MODRM, // 64
OP_MODRM, // 65
OP_MODRM, // 66
OP_MODRM, // 67
OP_MODRM, // 68
OP_MODRM, // 69
OP_MODRM, // 6A
OP_MODRM, // 6B
OP_MODRM, // 6C
OP_MODRM, // 6D
OP_MODRM, // 6E
OP_MODRM, // 6F
OP_MODRM or OP_DATA_I8, // 70
OP_MODRM or OP_DATA_I8, // 71
OP_MODRM or OP_DATA_I8, // 72
OP_MODRM or OP_DATA_I8, // 73
OP_MODRM, // 74
OP_MODRM, // 75
OP_MODRM, // 76
OP_NONE, // 77
OP_NONE, // 78
OP_NONE, // 79
OP_NONE, // 7A
OP_NONE, // 7B
OP_MODRM, // 7C
OP_MODRM, // 7D
OP_MODRM, // 7E
OP_MODRM, // 7F
OP_DATA_PRE66_67 or OP_REL32, // 80
OP_DATA_PRE66_67 or OP_REL32, // 81
OP_DATA_PRE66_67 or OP_REL32, // 82
OP_DATA_PRE66_67 or OP_REL32, // 83
OP_DATA_PRE66_67 or OP_REL32, // 84
OP_DATA_PRE66_67 or OP_REL32, // 85
OP_DATA_PRE66_67 or OP_REL32, // 86
OP_DATA_PRE66_67 or OP_REL32, // 87
OP_DATA_PRE66_67 or OP_REL32, // 88
OP_DATA_PRE66_67 or OP_REL32, // 89
OP_DATA_PRE66_67 or OP_REL32, // 8A
OP_DATA_PRE66_67 or OP_REL32, // 8B
OP_DATA_PRE66_67 or OP_REL32, // 8C
OP_DATA_PRE66_67 or OP_REL32, // 8D
OP_DATA_PRE66_67 or OP_REL32, // 8E
OP_DATA_PRE66_67 or OP_REL32, // 8F
OP_MODRM, // 90
OP_MODRM, // 91
OP_MODRM, // 92
OP_MODRM, // 93
OP_MODRM, // 94
OP_MODRM, // 95
OP_MODRM, // 96
OP_MODRM, // 97
OP_MODRM, // 98
OP_MODRM, // 99
OP_MODRM, // 9A
OP_MODRM, // 9B
OP_MODRM, // 9C
OP_MODRM, // 9D
OP_MODRM, // 9E
OP_MODRM, // 9F
OP_NONE, // A0
OP_NONE, // A1
OP_NONE, // A2
OP_MODRM, // A3
OP_MODRM or OP_DATA_I8, // A4
OP_MODRM, // A5
OP_NONE, // A6
OP_NONE, // A7
OP_NONE, // A8
OP_NONE, // A9
OP_NONE, // AA
OP_MODRM, // AB
OP_MODRM or OP_DATA_I8, // AC
OP_MODRM, // AD
OP_MODRM, // AE
OP_MODRM, // AF
OP_MODRM, // B0
OP_MODRM, // B1
OP_MODRM, // B2
OP_MODRM, // B3
OP_MODRM, // B4
OP_MODRM, // B5
OP_MODRM, // B6
OP_MODRM, // B7
OP_NONE, // B8
OP_NONE, // B9
OP_MODRM or OP_DATA_I8, // BA
OP_MODRM, // BB
OP_MODRM, // BC
OP_MODRM, // BD
OP_MODRM, // BE
OP_MODRM, // BF
OP_MODRM, // C0
OP_MODRM, // C1
OP_MODRM or OP_DATA_I8, // C2
OP_MODRM, // C3
OP_MODRM or OP_DATA_I8, // C4
OP_MODRM or OP_DATA_I8, // C5
OP_MODRM or OP_DATA_I8, // C6
OP_MODRM, // C7
OP_NONE, // C8
OP_NONE, // C9
OP_NONE, // CA
OP_NONE, // CB
OP_NONE, // CC
OP_NONE, // CD
OP_NONE, // CE
OP_NONE, // CF
OP_MODRM, // D0
OP_MODRM, // D1
OP_MODRM, // D2
OP_MODRM, // D3
OP_MODRM, // D4
OP_MODRM, // D5
OP_MODRM, // D6
OP_MODRM, // D7
OP_MODRM, // D8
OP_MODRM, // D9
OP_MODRM, // DA
OP_MODRM, // DB
OP_MODRM, // DC
OP_MODRM, // DD
OP_MODRM, // DE
OP_MODRM, // DF
OP_MODRM, // E0
OP_MODRM, // E1
OP_MODRM, // E2
OP_MODRM, // E3
OP_MODRM, // E4
OP_MODRM, // E5
OP_MODRM, // E6
OP_MODRM, // E7
OP_MODRM, // E8
OP_MODRM, // E9
OP_MODRM, // EA
OP_MODRM, // EB
OP_MODRM, // EC
OP_MODRM, // ED
OP_MODRM, // EE
OP_MODRM, // EF
OP_MODRM, // F0
OP_MODRM, // F1
OP_MODRM, // F2
OP_MODRM, // F3
OP_MODRM, // F4
OP_MODRM, // F5
OP_MODRM, // F6
OP_MODRM, // F7
OP_MODRM, // F8
OP_MODRM, // F9
OP_MODRM, // FA
OP_MODRM, // FB
OP_MODRM, // FC
OP_MODRM, // FD
OP_MODRM, // FE
OP_NONE // FF
);

{دîëَ÷هيèه ïîëيîمî ًàçىهًà ىàّèييîé êîىىàينû ïî َêàçàٍهë‏ يà يهه }
function SizeOfCode(Code: pointer; pOpcode: ppbyte): dword;
var
cPtr: pbyte;
Flags: byte;
PFX66, PFX67: boolean;
SibPresent: boolean;
iMod, iRM, iReg: byte;
OffsetSize, Add: byte;
Opcode: byte;
begin
Result := 0;
OffsetSize := 0;
PFX66 := false;
PFX67 := false;
cPtr := Code;
{îïًهنهëےهى ًàçىهً ïًهôôèêٌîâ}
while cPtr^ in [$2E, $3E, $36, $26, $64, $65, $F0, $F2, $F3, $66, $67] do
begin
if cPtr^ = $66 then PFX66 := true;
if cPtr^ = $67 then PFX67 := true;
Inc(cPtr);
if dword(cPtr) > dword(Code) + 16 then Exit;
end;
Opcode := cPtr^;
if pOpcode <> nil then pOpcode^ := cPtr;
{îïًهنهëےهى ًàçىهً îïêîنà è ïîëَ÷àهى ôëàمè}
if cPtr^ = $0F then
begin
Inc(cPtr);
Flags := OpcodeFlagsExt[cPtr^];
end else
begin
Flags := OpcodeFlags[Opcode];
if Opcode in [$A0..$A3] then PFX66 := PFX67;
end;
Inc(cPtr);
if (Flags and OP_WORD) > 0 then Inc(cPtr);
{îلًàلàٍûâàهى MOD r/m}
if (Flags and OP_MODRM) > 0 then
begin
iMod := cPtr^ shr 6;
iReg := (cPtr^ and $38) shr 3;
iRM := cPtr^ and 7;
Inc(cPtr);
{îïêîنû F6 è F7 - Immediate ïًèٌٌٍٍَâَهٍ ٍîëüêî ïًè iReg = 0}
if (Opcode = $F6) and (iReg = 0) then Flags := Flags or OP_DATA_I8;
if (Opcode = $F7) and (iReg = 0) then Flags := Flags or OP_DATA_PRE66_67;
{îلًàلàٍûâàهى SIB è Offset}
SibPresent := (not PFX67) and (iRM = 4);
case iMod of
0: begin
if PFX67 and (iRM = 6) then OffsetSize := 2;
if (not PFX67) and (iRM = 5) then OffsetSize := 4;
end;
1: OffsetSize := 1;
2: if PFX67 then OffsetSize := 2 else OffsetSize := 4;
3: SibPresent := false;
end;
if SibPresent then
begin
if (cPtr^ and 7 = 5) and (iMod in [0, 2]) then OffsetSize := 4;
Inc(cPtr);
end;
Inc(cPtr, OffsetSize);
end;
{îلًàلàٍûâàهى IMM çيà÷هيèے}
if (Flags and OP_DATA_I8) > 0 then Inc(cPtr);
if (Flags and OP_DATA_I16) > 0 then Inc(cPtr, 2);
if (Flags and OP_DATA_I32) > 0 then Inc(cPtr, 4);
if PFX66 then Add := 2 else Add := 4;
if (Flags and OP_DATA_PRE66_67) > 0 then Inc(cPtr, Add);
Result := dword(cPtr) - dword(Code);
end;


{ دîëَ÷هيèه ًàçىهًà ôَيêِèè ïî َêàçàٍهë يà يهه (ًàçىهً نî ïهًâîé êîىىàينû RET) }
function SizeOfProc(Proc: pointer): dword;
var
Length: dword;
pOpcode: pbyte;
begin
Result := 0;
repeat
Length := SizeOfCode(Proc, @pOpcode);
Inc(Result, Length);
if (Length = 1) and (pOpcode^ = $C3) then Break;
Proc := pointer(dword(Proc) + Length);
until Length = 0;
end;

{îïًهنهëهيèه ٍîمî, èىههٍ ëè êîىىàينà rel32 offset}
function IsRelativeCmd(pOpcode: pbyte): boolean;
var
Flags: byte;
begin
if pOpcode^ = $0F then Flags := OpcodeFlagsExt[pbyte(dword(pOpcode) + 1)^]
else Flags := OpcodeFlags[pOpcode^];
Result := Flags and OP_REL32 > 0;
end;


end.

مثال:
procedure MSGBOX;
begin
ShowMessage('hello');
end;
procedure TForm1.btn1Click(Sender: TObject);
begin
ShowMessage(IntToStr(SizeOfProc(@MSGBOX)));
end;


:ناراحت:

[بهروز عباسی]

شاید یه روزی بخوایید تمام رشته های موجود توی یه فایل exe رو به دست بیارید خب این توابع بهتون کمک میکنه
اولی توی کل فایل و دومی فقط سکشن ها رو می گرده
تشکر از عمو steve :لبخند:
{steve10120@ic0de.org}

function FileToPtr(szFilePath: string; var pFile: Pointer;
var dwFileSize: DWORD): Boolean;
var
hFile: DWORD;
dwRead: DWORD;
begin
Result := FALSE;
hFile := CreateFile(PChar(szFilePath), GENERIC_READ, 0, nil,
OPEN_EXISTING, 0, 0);
if (hFile <> INVALID_HANDLE_VALUE) then
begin
dwFileSize := GetFileSize(hFile, nil);
if (dwFileSize > 0) then
begin
pFile := VirtualAlloc(nil, dwFileSize, MEM_COMMIT, PAGE_READWRITE);
if (Assigned(pFile)) then
begin
SetFilePointer(hFile, 0, nil, FILE_BEGIN);
ReadFile(hFile, pFile^, dwFileSize, dwRead, nil);
if (dwRead = dwFileSize) then
Result := TRUE;
end;
end;
CloseHandle(hFile);
end;
end;

function FindASCIIStringsA(szFilePath: string; dwMinLength: DWORD;
szDumpPath: string): Boolean;
var
pFile: Pointer;
dwFileSize: DWORD;
i: DWORD;
szDump: string;
dwLength: DWORD;
hFile: TextFile;
begin
Result := FALSE;
if (FileToPtr(szFilePath, pFile, dwFileSize)) then
begin
dwLength := 0;
AssignFile(hFile, szDumpPath);
// yeah I don't like it but its easiest for writing lines..
Rewrite(hFile);
for i := 0 to (dwFileSize - 1) do
begin
if (PByte(DWORD(pFile) + i)^ in [$20 .. $7E]) then
begin
szDump := szDump + Char(PByte(DWORD(pFile) + i)^);
// WriteLn(hFile, '0x' + IntToHex(i - dwLength, 8) + ': ' + szDump);
Inc(dwLength);
end
else
begin
if (dwLength >= dwMinLength) then
WriteLn(hFile, '0x' + IntToHex(i - dwLength, 8) + ': ' + szDump);
dwLength := 0;
szDump := '';
end;
end;
if (FileSize(hFile) > 0) then
Result := TRUE;
CloseFile(hFile);
VirtualFree(pFile, 0, MEM_RELEASE);
end;
end;
function FindASCIIStrings(szFilePath:string; dwMinLength:DWORD; szDumpPath:string):Boolean;
var
pFile: Pointer;
dwFileSize: DWORD;
IDH: PImageDosHeader;
INH: PImageNtHeaders;
i: DWORD;
szDump: string;
dwLength: DWORD;
hFile: TextFile;
begin
Result := FALSE;
if (FileToPtr(szFilePath, pFile, dwFileSize)) then
begin
IDH := pFile;
if (IDH^.e_magic = IMAGE_DOS_SIGNATURE) then
begin
INH := Pointer(DWORD(pFile) + IDH^._lfanew);
if (INH^.Signature = IMAGE_NT_SIGNATURE) then
begin
dwLength := 0;
AssignFile(hFile, szDumpPath); // yeah I don't like it but its easiest for writing lines..
Rewrite(hFile);
for i := INH^.OptionalHeader.SizeOfHeaders to (dwFileSize - 1) do
begin
if (PByte(DWORD(pFile) + i)^ in [$20..$7E]) then
begin
szDump := szDump + Char(PByte(DWORD(pFile) + i)^);
Inc(dwLength);
end
else
begin
if (dwLength >= dwMinLength) then
WriteLn(hFile, '0x' + IntToHex(i - dwLength, 8) + ': ' + szDump);
dwLength := 0;
szDump := '';
end;
end;
if (FileSize(hFile) > 0) then
Result := TRUE;
CloseFile(hFile);
end;
end;
VirtualFree(pFile, 0, MEM_RELEASE);
end;
end;
procedure TForm2.btn1Click(Sender: TObject);
begin
FindASCIIStrings('e:\AntiDebugg.exe', 2,
IncludeTrailingPathDelimiter(ExtractFilePath(param str(0))) +
ExtractFileName(paramstr(1)) + '.dmp')
end;

[یوسف زالی]

BruteForce کردن یک تابع، معرفی روش و توضیح روال مربوطه (http://barnamenevis.org/showthread.php?442100-BruteForce-%DA%A9%D8%B1%D8%AF%D9%86-%DB%8C%DA%A9-%D8%AA%D8%A7%D8%A8%D8%B9%D8%8C-%D9%85%D8%B9%D8%B1%D9%81%DB%8C-%D8%B1%D9%88%D8%B4-%D9%88-%D8%AA%D9%88%D8%B6%DB%8C%D8%AD-%D8%B1%D9%88%D8%A7%D9%84-%D9%85%D8%B1%D8%A8%D9%88%D8%B7%D9%87&p=1977905#post1977905)

[یوسف زالی]

چک کردن باز بودن نسخه اي از برنامه، معرفي يک برنامه براي مانيتورينگ Mutex هاي بانام (http://barnamenevis.org/showthread.php?447393-%DA%86%DA%A9-%DA%A9%D8%B1%D8%AF%D9%86-%D8%A8%D8%A7%D8%B2-%D8%A8%D9%88%D8%AF%D9%86-%D9%86%D8%B3%D8%AE%D9%87-%D8%A7%DB%8C-%D8%A7%D8%B2-%D8%A8%D8%B1%D9%86%D8%A7%D9%85%D9%87%D8%8C-%D9%85%D8%B9%D8%B1%D9%81%DB%8C-%DB%8C%DA%A9-%D8%A8%D8%B1%D9%86%D8%A7%D9%85%D9%87-%D8%A8%D8%B1%D8%A7%DB%8C-%D9%85%D8%A7%D9%86%DB%8C%D8%AA%D9%88%D8%B1%DB%8C%D 9%86%DA%AF-Mutex-%D9%87%D8%A7%DB%8C-%D8%A8%D8%A7%D9%86%D8%A7%D9%85&p=2001388#post2001388)

[AliReza Vafakhah]

جدا کردن سه رقم در حین ورود ارقام. (مثل حالت Digit Grouping در ماشین حساب ویندوز)


procedure TFrmIns.EdtPriceChange(Sender: TObject);
begin
if (Trim(EdtPrice.Text) = '') then Exit;


EdtPrice.Text:= FormatFloat(',###.##', StrToFloat(ReplaceStr(EdtPrice.Text,
',', '')));
EdtPrice.SelStart:= Length(EdtPrice.Text);
end;

[یوسف زالی]

نحوه کلون کردن یک شی با تمام زیرمجموعه ها (http://barnamenevis.org/showthread.php?452598-%D9%86%D8%AD%D9%88%D9%87-%DA%A9%D9%84%D9%88%D9%86-%DA%A9%D8%B1%D8%AF%D9%86-%DB%8C%DA%A9-%D8%B4%DB%8C-%D8%A8%D8%A7-%D8%AA%D9%85%D8%A7%D9%85-%D8%B2%DB%8C%D8%B1%D9%85%D8%AC%D9%85%D9%88%D8%B9%D 9%87-%D9%87%D8%A7&p=2024277#post2024277)

[Saeid59_m]

برای نمایش وضعیت شهر های دیگر WOEID شهر خود را از yahoo weather پیدا کرده و در آدرس URL قسمت w= قرار دهید

[Mask]

داشتم با Qr-code اندروید ور میرفتم . یه سرچی کردم دیدم چه یونیت باحالی برای ساخت گزاشتند .
و به صورت سر بسته باید بگم ، qr-code ارتباط پر دردسر بیرون به سیستم رو ، بی دردسر کرده. شما متنی رو با این روش کد میکنید . در قالب یه عکس میدید به دوستتون. کافیه با Qr-Code خوان . دوباره به تکست برش گردونید.
برای دریافت اطلاعات بهتر مراجعه بشه به http://qr-code.ir/document/

[یوسف زالی]

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

[یوسف زالی]

دوستانی که در استفاده از این کامپوننت مشکل Parent دارند این خط رو در متد Create اضافه کنند:


Parent := TWinControl(AOwner);

[BORHAN TEC]

با سلام
کد زیر نحوه ساخت یک برنامه ریموت دسکتاپ ساده را نشان میدهد. این کد شامل دو پروژه Server و Client است.
این فقط یک مثال ساده است و باید کارهای دیگری برای بالا بردن Performance و ... روی آن صورت پذیرد.

[rainstorm]

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

86266
من محتوای یونیت Messages رو تو یه فایل txt ریختم و تو برنامه پیغامها رو جدا می کنم و در یک ListBox می ریزم. دلفی من قدیمیه اگر دوست داشتین محتوای یونیت Messages دلفی خودتون رو رو توی فایل Messages.txt کنار برنامه بریزین تا کامل تر بشه.وقتی در لیست باکس مربوط به نام پیغام هستین می تونین کارکتر اول نام پیغام (بدون پیشوند!) رو فشار بدین تا یکراست (چیزی مثل AutoComplete) به اون پیغام منتقل بشین!
اگه نمی دونستین کدوم پیغام به دردتون میخوره می تونین دکمه View Messages Text File رو فشار بدین و در فایل جستجو بدینتا پیغام مربوطه رو پیدا کنین.البته بعضی پیغامها تو یونیت Windows هستند که البته اگه خواستین می تونین پیغامهاش رو تو فایل Messages.txt بریزین و توی برنامه استفاده کنین.
برای تولید کد یا ارسال پیام روی کامپوننت یا فرم مورد نظر برین و Ctrl+Space رو فشار بدین و بعد دکمه مربوطه رو در برنامه فشار بدین تا برنامه با استفاده از اطلاعات کادرهای بالای فرم کد رو تولید کنه یا پیغام رو بفرسته.Ctrl+L هم باعث میشه برنامه چیزی گزارش نکنه!
توی کادر پارامترها هم می تونین عدد یا رشته وارد کنین. دکمه Send Message هم پیغام می فرسته هم کد ایجاد می کنه.
یک تجربه:
من هندل یک کامپوننت رو نداشتم با ;(متن کامپوننت,نام کلاس کامپوننت)FindWindow نتونستم هندش رو بدست بیارم!
ولی اگه هندل کامپوننت رو دارین با کد جناب MohsenB می تونین هندل فرم رو بدست بیارین:

function GetFormHandle(ObjHandle: THandle): THandle;
begin
if GetParent(ObjHandle) = 0 then
Result := ObjHandle
else
Result := GetFormHandle(GetParent(ObjHandle));
end;

سلام
ضمن تشکر از برنامه بی نظیرتون من برنامه رو با app چک کردم جواب میده (تمام دکمه های ماشین حساب ویندوز رو به متن دلخواه تغییر دادم)ولی چه طوری میشه به یه Edit تو Firefox یا IE متن فرستاد؟ میخوام یه روبات برای پر کردن یه فرم رو اینترنت بنویسم

[rainstorm]

جدا کردن سه رقم در حین ورود ارقام. (مثل حالت Digit Grouping در ماشین حساب ویندوز)


procedure TFrmIns.EdtPriceChange(Sender: TObject);
begin
if (Trim(EdtPrice.Text) = '') then Exit;


EdtPrice.Text:= FormatFloat(',###.##', StrToFloat(ReplaceStr(EdtPrice.Text,
',', '')));
EdtPrice.SelStart:= Length(EdtPrice.Text);
end;


سلام
به ReplaceStr گیر میده! مشکلش چیه؟

[دلفــي]

سلام
به ReplaceStr گیر میده! مشکلش چیه؟



procedure TFrmIns.EdtPriceChange(Sender: TObject);
begin
if (Trim(EdtPrice.Text) = '') then Exit;
EdtPrice.Text:= FormatFloat(',###.##', StrToFloat(StringReplace(EdtPrice.Text,',','',[rfReplaceAll])));
EdtPrice.SelStart:= Length(EdtPrice.Text);
end;

[tadeh2010]

procedure TFrmIns.EdtPriceChange(Sender: TObject);
begin
if (Trim(EdtPrice.Text) = '') then Exit;
EdtPrice.Text:= FormatFloat(',###.##', StrToFloat(StringReplace(EdtPrice.Text,',','',[rfReplaceAll])));
EdtPrice.SelStart:= Length(EdtPrice.Text);
end;

فکر کنم باید اول مقدار EdtPrice.Text را بریزی توی یه رشته که در var تعریف کردی و بعد از تغییرات مجددا جابجایش بکنی.

[rainstorm]

[QUOTE=دلفــي;2201577][CODE]
procedure TFrmIns.EdtPriceChange(Sender: TObject);
begin
if (Trim(EdtPrice.Text) = '') then Exit;
EdtPrice.Text:= FormatFloat(',###.##', StrToFloat(StringReplace(EdtPrice.Text,',','',[rfReplaceAll])));
EdtPrice.SelStart:= Length(EdtPrice.Text);
end;
[/Cسلام
با تشكر فراوان مشكل با اين اصلاحيه حل شد.ممنون:لبخندساده:

[یوسف زالی]

اتوماتای سلولی (http://barnamenevis.org/showthread.php?505256-%D8%A7%D8%AA%D9%88%D9%85%D8%A7%D8%AA%D8%A7%DB%8C-%D8%B3%D9%84%D9%88%D9%84%DB%8C)

[mbshareat]

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

[mbshareat]

سلام مجدد
بهترین کدی که برای تغییر اندازه تصویر با حفظ کیفیت پیدا کردم:

[mbshareat]

سلام
من ترجمه کردن لاتینم خوب نیست.یه برنامه ساده نوشتم که کلمات بالای سه حرفی از متنی که بهش میدیم رو به ترتیب پر تکرار به کم تکرار، لیست می کنه.و بعد از کپي شدن ترجمه لغات در حافظه(به طور خودکار) ، باید لغات رو در مترجم گوگل ترجمه کرد و بعد در برنامه، با فشار یک دکمه ترجمه هر لغت به لیست کلمات لاتین اضافه میش.برنامه قابلیت جستجوی کلمه لاتین و ذخيره در فايل هم داره.
روند کار اینه:
1.کپی و الصاق متن لاتین در کادر سمت چپ(من مثلا زیرنویس فیلم استاد از وبلاگ رزمیکده رو ریختم-وبلاگ خوبی برای دانلود فیلمهای دوبله رزمی قدیمی)
2.فشار دکمه Get Words.با این کار لیست کلمات، توسط برنامه در حافظه کپی میشه!
3. الصاق لیست کلمات در مترجم گوگل(بعد از تنظیم ترجمه انگلیسی به فارسی)
4.گرفتن لیست ترجمه از مترجم گوگل با کلیک راست و selectAll و کپی(با این کار دو سطر ،قبل و سه سطر، بعد از ترجمه در حافظه ریخته میشه که مربوط به متنهای بالا و پایین صفحه درمترجم گوگل هست که برنامه خودش حذفش می کنه)
5.فشار دکمه "الصاق ترجمه"
اگه میشد ترجمه مناسب برای کلمات گیر اورد و کلمات رو با ترجمه مناسب واژه جایگزین کرد، خوب بود.چون همونطور که می دونید ترجمه متن گوگل قابل استفاده نیست(من که برنامه مناسبی برای ترجمه متن سراغ ندارم!) و مترجم کلمه هم که ده تا کلمه ردیف می کنند.
این هم از برنامه:

143557
راستی اگر مترجم متن خوبی سراغ دارید، بهم معرفی کنید. ممنون میشم!
نمی دونم میشه یا نه ولی اگه کسی روش کار کنه شاید بشه کلمات بی ارزش (مثلا this) رو از لیست حذف کرد و ترجمه ها رو با هم ترکیب کرد و لیست رو به روز کرد!(کاش این جمعه بیاید..!!)
اگه مسئولین لازم دونستند هم ارسالهای بعدی دوستان رو در صورت قابل فهم بودن توضیحات حذف کنند که تاپیک شلوغ نشه!

تو فکر اینم که برم لیست کلمات رو از فایل بخونم و سختهاش رو ستاره بزنم و در برنامه، دکمه ساخت فایل کلمات سخت (بعد از ستاره دار کردن کلمات سخت)و کلمات جدید (بعد از ترجمه دومین متن)بذارم .لیست کلمات جدید، با حذف لیست کلمات فایل اولیه(اعم از ستاره دار و بی ستاره) و کلمات سخت (که با هر ترجمه به روز میشه) از لیست کلمات ترجمه جدید،به دست میاد!

[یوسف زالی]

من اصلا نفهمیدم چی به چیه؟
یه توضیح خوب بده ببینم چطور با این برنامه کار می کنی؟

[Mask]

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

[یوسف زالی]

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

[mbshareat]

سلام
یه نمونه برنامه که یه لیست از برنامه های دلخواه ایجاد و ذخیره می کنه با سورس برنامه.
(البته می تونید هر نوع فايل رو اضافه و اجرا کنید.من برای اجرای Exe درستش کرد!)
موارد آموزشی:
درگ کردن فایل بر روی پنجره
گرفتن آیکن برنامه
لیست باکس سفارشی(در این برنامه از بیت مپ برای هر سطر استفاده شده)
پنجره ساده فارسی برای پیغام،سوال،دریافت متن

150251
150252
این هم یه کم خوشگل ترش!
150253

[mbshareat]

یه کد ساده برای استخراج فایلهای اجرایی همنام شاخه.
چند تا برنامه داشتم که روشون کار می کردم و فایلهای اجرایی نهایی رو به اشتراک میذاشتم.گفتم هر فایل رو دستی کپی نکنم
type
TForm1 = class(TForm)
DirectoryListBox1: TDirectoryListBox;
ProgressBar1: TProgressBar;
procedure FormActivate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}


procedure TForm1.FormActivate(Sender: TObject);
var
I:Word;
A,D,S:String;
begin
A:=ExtractFileDir(Application.exeName);
DirectoryListBox1.Directory:=A;
ProgressBar1.Max:=DirectoryListBox1.Count-DirectoryListBox1.ItemIndex;
For I:=DirectoryListBox1.ItemIndex to DirectoryListBox1.Count-1 do
Begin
ProgressBar1.Position:=I;
Refresh;
D:=DirectoryListBox1.Items[I];
DirectoryListBox1.ItemIndex:=I;
if FileExists(A+'\'+D+'\'+D+'.exe')=true then
CopyFile(PChar(A+'\'+D+'\'+D+'.exe'),PChar(A+'\'+D +'.exe'),false);
End;
Application.Terminate;
end;

[mbshareat]

برنامه ای برای کپی سورس برنامه ها به فلش مموری
این برنامه فقط برخی فایلهای پوشه رو کپی می کنه :(dcu.dfm.dpr.ddp.pas.exe.ico)
150384

[mbshareat]

سلام دوستان
کدهایی که دوست داشتم به صورت فایل متن کوچک دسته بندی کردم.
مثلا مباحثی مثل تصویر ،صفحه کلید،هندل،کار با فایل و شاخه،صوت و... که بیشتر به صورت یک پروسیجر در یک فایل هست.
برای مبتدیها ممکنه جالب باشه:
150404

[mbshareat]

سلام
میخواستم ببینم کجای یونیت تغییر کرده.دو نسخه یونیت رو به روش ساده مقایسه کردم.دو متن رو ریختم در دو ممو و سطرهای تکراری رو از دو متن حذف کردم.(البته این روش ساده به ترتیب حساس نیست!)
گفتم ممکنه به درد کسی بخوره.تا اونجا که یادم میاد قبلا با یه روش دیگه سطر به سطر مقایسه کرده بودم که به جابجایی کد هم حساس میشد.اما پیچیدگیهایی داه مثل نادیده گرفتن سطرهای غیر تکراری و...
این هم از سورس برنامه:
151243

[mbshareat]

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

151416

بازی فلشی بیست و چهار مرحله ای ساخت خودم (http://s7.picofile.com/file/8389958776/HamedAdventure1_24.rar.html)
این هم اگه کسی فایل swf خواست (http://s7.picofile.com/file/8386171600/HamedAdventure1_24.swf.html)

(http://s6.picofile.com/file/8389958142/MyGame2.rar.html)بازی فکری دو نفره (http://s6.picofile.com/file/8389958142/MyGame2.rar.html)

سورس برنامه بازی نوشته شده در محیط XE2 (http://s6.picofile.com/file/8392309100/2MindGames_Source.rar.html)
یادم رفت: Panel2.Left:=Panel1.Left; رو کامنت کنید و یه کم panel2 رو بیارید سمت راست.
(پیکوفایل سرعت پایینی داره.حوصله ندارم از اول، سورس رو بذارم!:خجالت:ایتا بی شوخی ده برابر سرعت داره)

[mbshareat]

سلام
کمتر از دو ماهه گوشی هوشمند گرفتم.
چند تا بازی پیدا کردن اختلاف دو تصویر دانلود کردم.مثل کارآگاه ريز بین و اختلاف تصویر سینا و اختلاف تصویر ثنا و ثمین.
معمولا آخرین اختلافها رو نمیتونستم پیدا کنم. پس براش برنامه نوشتم.
151489
اولش از یه روش سخت استفاده می کردم.تصویر صفحه گوشی رو میریختم پیکوفایل.
بعد در کامپیوتر دو تکه از یک jpeg (که هر کدوم یکی از دوتصویر مشابه بود) رو به تناوب نمایش میدادم که اختلاف معلوم شه.(وقتی تصویر Jpeg باشه نمیشه روی رنگ حساس شد!)
جدیدا شبیه ساز اندروید LDPlayer.3.79.3 نصب کردم.بازی کارآگاه ریزبین رو هم در اون نصب کردم.
یه برنامه نوشتم که به رنگها حساسه و رنگهای دو ناحیه از یه تصویر رو مقایسه می کنه و قسمتهایی که نقاط رنگی متفاوت داره قرمز می کنه.
در برنامه میشه مختصات دو محدوده تصویر (که همون دو تصویر مشابه هست) رو در تصویر گرفته شده از صفحه بازی هست، تعیین کرد.
این روش خیلی به دقیق بودن مختصات، حساس هست و میشه با فشار Alt+Q (وقتی ماوس روی پنجره شبیه ساز هست) تصویر ورودی رو برای برنامه تعیین کرد یا از یه فایل کنار برنامه .
مقادیر پیشفرض برنامه هم مربوط به بازی کارآگاه ریزبین با پایینترین رزولوشن شبیه ساز LDPlayer هست که قابل تغییره.

نکته:
وقتی با Alt+Q تصویر رو میگیریم میتونیم با الصاق محتوای کلیپ برد در برنامه msPaint، مختصات دو محدوده تصویرهای مشابه رو بررسی کنیم.
سورس برنامه نسخه جدید (http://s6.picofile.com/file/8391648942/Bmp_%DA%A9%D8%A7%D8%B1%D8%A2%DA%AF%D8%A7%D9%87_%D8 %B1%DB%8C%D8%B2%D8%A8%DB%8C%D9%86.rar.html)
151487
تصويري از نسخه کمی قدیمی تر:
151488

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

[mbshareat]

اجرای برنامه در پس زمینه
//FormCreate
WindowState:=wsMinimized;
Left:=-100;
Width:=0;
Height:=0;
SetWindowLong(Application.Handle, GWL_EXSTYLE,WS_EX_TOOLWINDOW AND NOT WS_EX_APPWINDOW);



//FormPaint
Application.MainForm.Hide;

[mbshareat]

تبدیل تصویر عمودی و افقی به مربع با اضافه کردن حاشیه سفید
میخواستم تصویر برای اینستاگرام بفرستم کناره هاش رو حذف می کرد.در مورد اندازه تصویر تحقیق کردم به کارم نیومد.میخواستم در یک پست چند تصویر بذارم پس تنظیم تمام تصویر اینستاگرام هم به کارم نیومد.NoCrop نصب کردم به نظرم اومد خوب کار می کنه بعد دیدم اندازه تصویر رو بی منطق 2080 در 2080 می کنه.منوی تنظیماتش رو هم می زدم خیلی عجیب نرم افزار کمی قفل می کرد میرفت پس زمینه و بالا می آوردیمش از اول میشد.
بگذریم.خودم یه برنامه نوشتم که فضای خالی به تصویر اضافه می کنه که تصویر مربع بشه.متاسفانه اینترنت گوشیم تموم شد.(مثل اینکه *1000*27# هم لغو شده!)
نتونستم ببینم مربع کردن با هر اندازه ای جواب میده یا نه.البته من تصاویر حد اکثر 1000*1000 کافیم بود.
برنامه رو میذارم چون کوچیکه میشه بهش از جنبه آموزشی هم نگاه کرد.تبدیل Jpg و Bmp به هم و حذف خاکستری برای تصویر تک رنگ(من میخواستم تصویر کتاب انگلیسی پست کنم!) در برنامه هست.
نمی دونم چرا در سایت آپلود کردم لینک درست نمیده.مجبورم نسخه دوم رو در پیکو فایل (http://s11.picofile.com/file/8393320868/IntagramJpgBox2.rar.html) بذارم.

[mbshareat]

ایجاد فایل متن برای دانلود سریال توسط IDM
ابتدا لینک یک قسمت سریال رو به برنامه می دیم و شماره اولین و آخرین قسمتی که میخوایم IDM دانلود کنه تعیین می کنیم.
برنامه فایل متن میسازه که لینک قسمتها در اون هست و از قسمت امور>وارد کردن<از فایل تکست فایل متن رو به IDM معرفی می کنیم که لینکها رو استفاده کنه

[mbshareat]

سلام علیکم
چند وقت پیش رفتم سایت Pinterest .
تصاویر بامزه و آیکنهای مفید برای برنامه نویسی داره که به صورت مجموعه ای هستند
من دوست داشتم برنامه ای باشه که بتونم با کلیک یکی از تصاویر کوچک فایل تصویری رو بگیرم.
از کد MagicWand برای گرفتن ناحیه و GraphicEx برای تنظیم اندازه با کیفیت استفاده کردم.
میتونید با درگ هم تصویر رو روی پنجره برنامه بکشید!
امیدوارم به درد کسی بخوره و اگر دعا کنیدهم ممنون میشم.
154229
این هم سورس برنامه و تصویر:
153867

این هم نسخه بهبود يافته با جعبه ابزار که به علت استفاده از کامپوننت دکمه بدقلق خودم فقط فایل اجرایی میذارم:
154227
154228

[mbshareat]

سلام علیکم
گاهی لازمه در یک TEDit مقدار عددی وارد کنیم و همزمان با تغییر عدد نتیجه رو در پنجره ببینیم.
من برای راحتی کار از کلید جهت بالا یا پایین برای تنظیم عدد استفاده می کنم. اگر کنترل رو هم نگه داریم، عدد ده تا کم یا زیاد میشه.
این هم از کد:

procedure EditAction(E:TEdit;Key:Word;Shift: TShiftState);
Var
N:Byte;
begin
SetWindowLong(E.Handle, GWL_STYLE, GetWindowLong(E.Handle, GWL_STYLE) or ES_NUMBER);
If ssCtrl in Shift then
N:=10
Else
N:=1;
If Key=vk_UP then
E.Text:=IntToStr(StrToInt(E.Text)+N);
If Key=VK_DOWN then
E.Text:=IntToStr(StrToInt(E.Text)-N);
end;

سطر اول پروسیجر رو میتونید در FormCreate بذارید و فقط یک بار اجرا کنید که ادیت فقط عدد قبول کنه.
نحوه استفاده:
یک TEdit روی فرم میذاریم و چنین کدی استفاده می کنیم:
procedure TForm1.Edit1KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
EditAction(TEdit(Sender),Key,Shift);
end;

[mbshareat]

سریع ترین کد برای قرینه کردن بیت مپ:
procedure FlipBmp(B:TBitmap;Mode:Byte);
Var
R,R2:TRect;
begin
R:=B.Canvas.ClipRect;
If Mode=1 then
R2:=Rect(R.Right,R.Top,R.Left,R.Bottom)
Else
R2:=Rect(R.Left,R.Bottom,R.Right,R.Top);
B.Canvas.CopyRect(R2,B.Canvas,R);
end;

[mbshareat]

کد برای تغییر رنگ پس زمینه سطر جاری در لیست باکس(حوصله توضیح اضافه ندارم:چشمک:)
ListBox1.Style-> lbOwnerDrawFixed

Var
LastItem:Integer=-1;
..

implementation
...

procedure TReplaceTextForm.ListBox1DrawItem(Control: TWinControl;
Index: Integer; Rect: TRect; State: TOwnerDrawState);
procedure DrawItem(Idx:Integer;R:TRect);
Var
S:String;
W:Word;
begin
If Idx=ListBox1.ItemIndex Then
ListBox1.Canvas.Brush.Color:=clAqua
Else
ListBox1.Canvas.Brush.Color:=ListBox1.Color;
//SetBkMode(ListBox1.Canvas.Handle,Transparent);
ListBox1.Canvas.FillRect(R);
ListBox1.Canvas.Font.Color:=clBlack;//ضروري
ListBox1.Canvas.TextOut(R.Left,R.Top,ListBox1.Item s[Idx]);
end;
begin
If (LastItem<>-1) And (LastItem<>ListBox1.ItemIndex)
And (LastItem<ListBox1.Items.Count) then
DrawItem(LastItem,ListBox1.ItemRect(LastItem));
DrawItem(Index,Rect);
LastItem:=Index;
end;

[mbshareat]

سلام دوستان
یه کد نسبتا ساده گذاشتم برای وقتیکه خواستید یه پیغام فارسی با شکلک نمایش بدید.میتونید تعیین کنیدچند ثانیه نمایش داده بشه یا تعیین نکنید.
نکته: شکلک نمایش داده شده، تصادفی است و احساس رو با رنگ نمایش میدیدم:لبخند:
154736
154737
نحوه استفاده:
بعد از اضافه کردن یونیت موجود در فایل فشرده به برنامه ، در فرم مد نظر چنین کدی میذاریم(حوصله توضیح بیشتر نداشتم:متفکر:):
FaceMsgForm.Msg('اين يک پيغام نمايشي است.',clYellow,1);
154738

یه تابع هم نوشتم که اگر تصویر بیت مپ شکلکها رو با نام AllFacesImg در یک فرم بذاریم، میتونیم یه پنجره پیغام مثل شکل داشته باشم(بدون اضافه کردن فرم پیغام به برنامه!)
فرق این کد با کد بالا اینه که تایمر نداره و اگر متن پیام کوتاه باشه، پهنای پنجره پیغام هم تنظیم میشه.
154740

[mbshareat]

سلام
احوال؟
چند تابع ساده نوشتم برای اینکه تعداد کارکترهای کد کمتر بشه:لبخند:. گفتم شاید به درد کسی خورد:
function TForm1.TrimFirst(S:String;N:Integer):String;begin
If S='' then
Exit;
Result:=Copy(S,N+1,Length(S)-N);
end;
function TForm1.TrimLast(S:String;N:Integer):String;
begin
If S='' then
Exit;
Result:=Copy(S,1,Length(S)-N);
end;
function TForm1.BeforeStr(S,S2:String):String;
begin
If S='' then
Exit;
Result:=Copy(S,1,Pos(S2,S)-1);
end;
function TForm1.AfterStr(S,S2:String):String;
begin
If S='' then
Exit;
Result:=Copy(S,Pos(S2,S)+1,Length(S)-Pos(S2,S));
end;
function TForm1.BetweenStr(S,S2,S3:String):String;
begin
If S='' then
Exit;
Result:=Copy(S,Pos(S2,S)+Length(S2),PosEx(S3,S,Pos (S2,S))-Pos(S2,S)-Length(S2));
end;
function TForm1.LastChar(S:String):String;
begin
If S='' then
Exit;
Result:=S[Length(S)];
end;
procedure TForm1.GetNums(S:String;Var A:Array of Word;Reverse:Boolean=False;ExitChar:Char=#0);
Var
I,N:Word;
Tmp:String;
begin
For I:=A[0] To High(A) Do
A[I]:=0;
S:=S+'.';
N:=0;
For I:=1 to Length(S) Do
Begin
If pos(S[I],'0123456789')>0 then
Begin
If Reverse=True then
Tmp:=S[I]+Tmp
Else
Tmp:=Tmp+S[I];
End
else If Tmp<>'' then
Begin
A[N]:=StrToInt(Tmp);
if S[I]=ExitChar then
Break;
Tmp:='';
Inc(N);
End;
End;
End;
Function TForm1.IntRev(S:String):Integer;
begin
Result:=StrToInt(ReverseString(S));
end;
Function TForm1.Rev(S:String):String;
begin
Result:=ReverseString(S);
end;
Function TForm1.AppDir:String;
begin
Result:=ExtractFileDir(Application.ExeName);
end;
Function TForm1.TopDir(S:String;LC:Boolean=False):String;
begin
If LC=True then
Result:=LowerCAse(ExtractFileDir(S))
Else
Result:=ExtractFileDir(S);
end;
Function TForm1.FN(S:String;LC:Boolean=False):String;
begin
If LC=True then
Result:=LowerCAse(ExtractFileName(S))
Else
Result:=ExtractFileName(S);
end;
Function TForm1.Ext(S:String;LC:Boolean=False):String;
begin
If LC=True then
Result:=LowerCAse(ExtractFileExt(S))
Else
Result:=ExtractFileExt(S);
end;
function TForm1.MatchPos(S,S2:String;N:Word):Integer;
Var
P,M:Integer;
begin
Result:=0;
P:=0;
M:=0;
While True Do
Begin
P:=PosEx(S2,S,P+1);
If P=0 then
Exit
Else
Begin
Inc(M);
If N=M then
Begin
Result:=P;
Exit;
End;
End;
End;
end;
function TForm1.FirstMatchPos(S:String;A:Array of String):Integer;
Var
I,P,P2:Integer;
begin
P:=0;
For I:=0 To High(A) Do
Begin
P2:=Pos(A[I],S);
If (P=0) or (P2<P) then
P:=P2;
End;
Result:=P;
end;

procedure TForm1.FormCreate(Sender: TObject);
Var
A:Array [1..3]Of Word;
begin
GetNums('}12\3-4{65',A,False,'{');
ShowMessage(IntToStr(A[3]));
ShowMessage(LastChar('bagher'));
ShowMessage(IntToStr(MatchPos('Papa','a',2)));
ShowMessage(IntToStr(FirstMatchPos('I am a Good Student!',['Go','!','a'])));
end;





دو نکته:
1. اگر اسم فرم شما TForm1 نیست میتونید با Ctrl+R تغییرش بدید و اگر صلاح دونستید .Tform1 رو حذف کنید.
2.من چون از بیسیک سراغ دلفی اومدم ترجیح میدم جای زیر رشته رو بعد از رشته اول بنویسم. اگر دلتون خواست جای پارامترها رو در MatchPos عوض کنید.