ابتدا Registry رو به بخش Uses ها اضافه می کنیم. بعد چهار تا Edit و چهار تا Button روی فرم می ذاریم.

می خواهیم کلید اوّل مسیر ویندوز نصب شده رو تو Edit1 مشخص کنه پس Caption Buton1 رو بذارید Get Windows Path حالا  برای همین کلید این دستورات رو بنویسید.

یه Button  روی فرم بذارید و این دستورات رو بنویسید .

procedure TForm1.Button1Click(Sender: TObject);
var
pid1: PitemIDList;
buf: Array[0..Max_PATH] of char;
begin
if Succeeded(ShGetSpecialFolderLocation(Handle,CSIDL_DESKTOP,pid1)) then
begin
if ShGetPathfromIDList(pid1,buf) then ShowMessage(buf) ;
CoTaskMemFree(pid1);
end;
end;

حالا برای Button1 اینو بنویسید .

حالا به ترتیب Label3 , 4 رو روبروی Label های 1و2 بذارید

حالا برای تایمر اینو می نویسیم.

var M : TMouse;
begin
Label3.Caption := IntToStr(M.CursorPos.x);
Label4.Caption := IntToStr(M.CursorPos.y);
end;

دلفی در واقع یک کامپایلر پاسکال است. دلفی 6 نسل جدید کامپایلر های پاسکال است که شرکت Borland از زمان ایجاد اولین نسخه پاسکال توسط Andres Hejlsberg در 15 سال پیش به بازار عرضه کرد.

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

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

سال 1995 - Delphi1
در زمان استفاده از سیستم عامل DOS برنامه نویسان مجبور بودند از بین زبان پر قدرت ولی کم سرعت Basic و زبان کارآمد ولی پیچیده و نامفهوم Assembly یکی را انتخاب کنند. پاسکال با ارائه یک زبان ساخت یافته و یک کامپایلر سریع و کم نقص این شکاف را پرکرد. برنامه نویسان Windows 3.1 هم با تصمیم گیری مشابهی رو برو شدند. یکی زبان قدرتمند و سنگین ++C و یکی زبان ساده و محدود کننده Visual Basic .

ارائه Delphi1 در این مورد هم راه حل خوبی برای برنامه نویسان بود. دلفی مجموعه متفاوتی برای برنامه نویسی بود . طراحی و توسعه برنامه های کاربردی، ایجاد DLL ها، پایگاههای داده و ... که یک محیط ویژوال وسیع را تشکیل می داد. Delphi1 اولین ابزار برنامه نویسی ویندوز بود که محیط طراحی ویژوال، کامپایلر بهینه کد برنامه و دسترسی قوی به پایگاههای داده را در یک جا جمع کرد که آن را به یکی از بهترین ابزارهای روش نوین توسعه سریع نرم افزار (Rapid Application Development) تبدیل کرد. این مجموعه قدرتمند باعث شد که در همان زمان بسیاری از برنامه نویسان زبانهای دیگر به Delphi روی بیاورند و این موفقیت بزرگی برای Borland به حساب می آمد. همچنین بسیاری از برنامه نویسان پاسکال دلفی را ابزاری یافتند که توسط آن هم از توانایی و تجربه خود در برنامه نویسی پاسکال استفاده می کردند و هم توانایی کار در ویندوز را به دست آوردند. همچنین زبانی که در آن زمان با نام پاسکال شیئی (ObjectPascal) در دانشگاهها ایجاد شده بود یک زبان بسیار خشک و محدود کننده بود که اصلاٌ حالت کاربردی پیدا نکرد.

ویژگیهای دلفی مثل طراحی ظاهری حساب شده و کاربر پسند آن باعث شد که زبان پاسکال شیئی عملاٌ از رده خارج شود. تیم طراحی VB در Microsoft قبل از حضور دلفی هیچ رقیب مهمی برای خود نمی دید. VisualBasic در آن زمان زبانی نا کارآ ، کم سرعت و کند ذهن بود. Visual Basic 3 در عمل اصلا توانایی رقابت با Delphi 1 را نداشت. در این سال شرکت Borland گرفتار یک سری مشکلات قضائی با شرکت Lotus بود که در نهایت هم متخلف شناخته شد. همچنین درگیری مشابهی هم با Microsoft بر سر تلاش در تغییر دادن فضای نرم افزار های Microsoft پیدا کرد. همچنین Borland مشغول طراحی و فروش طرح Quatro به شرکت Novell و طراحی پایگاه های داده dBase و Paradox بود که با استقبال قابل توجهی مواجه نشد.

در این زمان که Borland مشغول فعالیتهای قضایی و تجاری بود Microsft توانست گوی سبقت را از Borland برباید و قسمت اعظم بازار ابزار های برنامه نویسی تحت Windows را در اختیار بگیرد و سعی می کرد تا این طرز فکر را اشاعه دهد که چون Windows را طراحی کرده صلاحیت و توانایی تهیه بهترین ابزار های برنامه نویسی تحت آن را نیز در دست دارد. در این شرایط Borland با عرضه Delphi و نسخه جدید ++Borland C سعی کرد خدشه ای در فرمانروایی Microsoft وارد کند و سهمی در بازار بزرگ این محصولات داشته باشد.

سال 1996 - Delphi2
یک سال بعد Delphi2 تمام مزایای نسخه قبلی را تحت سیستم های جدید 32 بیتی (Windows 95,Windows NT) ارائه داد. همچنین Delphi2 با ارائه خصوصیات اضافه و کارکرد های قویتری نسبت به Delphi1 توانایی های خود را افزایش داد. (ازجمله ارائه کامپایلر 32 بیتی که سرعت بالایی به نرم افزار ها می بخشید، کتابخانه بزرگ و کاملی از اشیای مختلف، شیوه جدید و تکامل یافته ای برای اتصال به پایگاه های داده مختلف، ادیتور پیشرفته، پشتیبانی از OLE ، توانایی وراثت در فرمهای ویژوال و سازگاری با پروژه های 16 بیتی Delphi1 ). Delphi2 به معیاری برای سنجش و مقایسه همه ابزارهای توسعه نرم افزار در آن زمان تبدیل شد.

در آن زمان با ارائه سیستم 32 بیتی Windows95جهش بزرگی در سیستم عامل Windows رخ داد و Borland بسیار مشتاق بود که Delphi را به بهترین ابزار برنامه نویسی سیستم جدید تبدیل کند. نکته این که در آن زمان به منظور تاثیر در افکار عمومی و تاکید بر قدرت Delphi در سیستم عامل 32 بیتی قرار بود که نرم افزار با نام جدید Delphi32 به بازار عرضه شود ولی در آخرین مراحل به خاطر اینکه نشان دهند این زبان زبانی رشد یافته و تکامل یافته نسخه قبلی یعنی Delphi1 است نام Delphi2 را برای آن انتخاب کردند.

Microsoft تلاش کرد که با Visual Basic 4 با Delphi مقابله کند ولی از ابتدا کیفیت پایین آن و ضعف آن در انتقال برنامه های 16 بیتی به سیستم 32 بیتی و بروز اشکالات ساختاری در طراحی آن موجب شکست زودهنگام Visual Basic 4 شد. در این زمان هنوز تعداد زیادی از برنامه نویسان به Visual Basic وفادار بودند. Borland هنچنین روشها و ابزارهای قدرتمندی همچون PowerBuilder برای طراحی نرم افزار های Client/Server ارائه داد ولی Delphi هنوز آن قدر قدرتمند نشده بود که بتواند نرم افزارهایی که جایی در بین توسعه گران پیدا کرده اند را براندازد.

سال 1997 - Delphi3
از زمان تهیه و توسعه Delphi1 تیم توسعه Delphi در فکر گسترش و ایجاد یک زبان قدرتمند جهانی بود. برای Delphi2 این تیم تمام نیروی خود را صرف اعمال مربوط به انتقال تواناییها و کارکرد ها به سیستم 32 بیتی و همچنین اضافه کردن خصوصیات Client/Server و پایگاه داده کرد. در زمان تهیه Delphi3 تیم توسعه فرصت لازم برای گسترش مجموعه ابزار موجود را یافت و در این راستا کیفیت و کمیت ابزارهای Delphi بهبود یافت. به علاوه راه حل هایی برای مشکلات عمده و قدیمی برنامه نویسان تحت ویندوز ارائه شد. به ویژه استفاده از برخی فناوری های پیچیده و نا مفهوم (مثل COM و ActiveX وتوسعه نرم افزار های تحت Web وکنترل پایگاههای داده چند کاربره). روش نمایش کد برنامه همچنین توانایی کامل کردن خودکار کد (Code Completion) عملیات کد نویسی را راحت تر کرد. ضمن این که همچنان در بیشتر موارد اساس و متدولوژی برنامه نویسی مانند Delphi1 بود و بر پایبندی به قوانین اصولی Pascal تاکید می شد.

در این زمان رقابت شرکت های تولید کننده ابزار های برنامه نویسی بسیار تنگاتنگ شده بود. Microsoft با ارائه Visual Basic 5 به پیشرفت های خوبی دست یافت ازجمله پشتیبانی قوی از COM و ActiveX و ایجاد برخی خصوصیات و تغییرات کلیدی و اساسی در کامپایلر VB. ضمن این در همین سال Borland با پشتوانه قوی Delphi و با استفاده از ساختار موفق آن ابزارهای دیگری همچون Forte و BC++ Builder به بازار عرضه کرد.

تیم Delphi در زمان طراحی Delphi3 چند تن از اعضای کلیدی خود را از دست داد. Andres Hejlsberg معمار اصلی Delphi در اقدام غیر منتظره ای Borland را ترک کرد و تصمیم گرفت به رقیب دیرینه یعنی Microsoft بپیوندد. اما حرکت تیم Delphi متوقف نشد و معاون Hejlsberg که سالها تجربه همکاری با او را داشت توانست رهبری این تیم را به خوبی در دست بگیرد. همچنین مسئول فنی تیم (Paul Gross) هم در اقدام مشابهی به گروه Microsoft ملحق شد. این تغییرات بیشتر به خاطر اختلافات شخصی بین افراد تیم بود و نه به خاطر مسائل حرفه ای.

سال 1998 - Delphi4
Delphi4 بیشتر بر روی راحتتر کردن کار با دلفی متمرکز شد. مرورگر روال ها (Module Explorer) بهبود یافت و مرور و ویرایش Unit ها را راحت تر کرد. کنترل کد و کامل کردن خودکار کلاسها این فرصت را به کاربر داد که فکر و زمان خود را روی ساختار اصلی برنامه بگذارد و در وقت صرفه جویی کند. طراحی رابط کاربر هم کاملاٌ عوض شد و بهبود یافت و اشکال زدا (Debugger) نیز پیشرفت قابل توجهی داشت. Delphi4 قابلیتهای برنامه نویسان را در استفاده از تکنولوژیهای چند منظوره خارجی مثل MIDAS ، DCOM ، MIS و Corba افزایش داد.

در این سال Delphi جایگاه خود را در رقابت با دیگران مستحکم کرده بود و کم کم به سمت دست یابی به سودآوری مالی مورد نظر خود پیش می رفت. در واقع در این زمان بود که حاصل کار سنگین چند ساله تیم نمایان می شد. بعد از سالها آزمایش Delphi شهرت و محبوبیت خاصی پیدا کرد و دیگر برنامه نویسان Delphi توانایی جدا شدن از آن را نداشتند. در این زمان Borland به کار سوٌال برانگیزی دست زد و به منظور تبلیغ بیشتر و برتری در جنگ روانی با دیگر شرکتها نام Inprise را برای فعالیتهای تجاری خود برگزید.

ابزار های مربوط به فن آوری Corba را گسترش داد تا راه جدیدی برای سودآوری ایجاد کند. برای موفقیت در این زمینه Corba نیاز به رابط کاربر قدرتمندی داشت که در کنار توانایی های آن کار کردن با آن نیز راحت باشد. دقیقاٌ همان کاری که در سالهای قبل در مورد COM و برنامه نویسی تحت Web انجام شده بود و به موفقیت دست یافته بود. با این وجود بنا به دلایل مختلفی این گسترش و توسعه Corba هیچ وقت تکامل و موفقیتی که مورد نظر بود را به دست نیاورد و بر خلاف تبلیغات و سرمایه گذاری های انجام شده فن آوری Corba تنها توانست نقش کوچکی در روند رو به جلوی Delphi ایفا کند.

سال 1999 - Delphi5
Delphi5 در برخی زمینه ها پیشرفت های قبلی را ادامه داده است. اولاٌ مسیری را که Delphi4 با اضافه کردن ویژگیهای زیادی شروع کرده بود ادامه داد. Delphi4 باعث شد کارهایی که قبلاٌ به صرف وقت زیادی احتیاج داشت بسیار سریعتر انجام شود. Delphi به شکل امیدوار کننده ای به برنامه نویس این امکان را می دهد که بیشتر به برنامه ای که میخواهد بنویسد توجه کند و نه به قواعد برنامه نویسی و نوشتن کد های تکراری و خسته کننده. این ویژگیهای سودمند شامل رابط کاربر بهبودیافته و سیستم اشکال زدایی(Debugger) توانمند ، امکانات برنامه نویسی تیمی و ابزار های ترجمه می شود.

ثانیا Delphi5 خصوصیات جدیدی را در بر می گیرد که توسعه برنامه های تحت وب را واقعاٌ راحت کرده است. این ویژگیها شامل طراح اشیای مربوط به ASP برای ساختن صفحات (Active Server Page)، اشیایی موسوم به Internet Express برای پشتیبانی از XML و خصوصیات جدید MIDAS که آن را به یک ابزار همه کاره در پایگاه های داده تحت Web تبدیل کرد. در نهایت با صرف وقت ، هزینه و صبر زیاد توانست Delphi5 قدرتمند را عرضه کند. این فعالیت مدتها به طول انجامید و قبل از عرضه عمومی، Delphi5 بارها در بازبینی ها و آزمایشهای داخلی قسمتهای مختلف آن تغییر کرد و بهبود یافت.

Delphi5 در نیمه دوم سال 1999 به بازار عرضه شد و به نفوذ و تسلط بر بازار ادامه داد. در این زمان Visual Basic که کم کم به عضوی تحقیر آمیز برای Microsoft تبدیل می شد هم با پیشرفتهایی توانست در رقابت دوام بیاورد و از صحنه خارج نشود. در اقدام درست و به جایی نام Inprise دوباره به Borland بازگشت. این اقدام از سوی طرفداران و مشتریان قدیمی Borland با استقبال خوبی مواجه شد.

سال 2001 – Delphi6
در هنگام تهیه Delphi6 ساختار Delphi در زمینه های مختلف شکل گرفته بود و به یک تکامل نسبی رسیده بود. این مسئله باعث شد که تیم طراحی بتواند وقت خود را بر روی طرحی که مدتها تنها در حد یک نظریه بود بگذارد و آن را بسیار زودتر از آن که انتظار می رفت عملی کند: گام نهادن به محیط های فراتر از Windows . بیشتر نیروی توسعه گران Delphi در این مدت صرف رهانیدن Delphi از بند Windows شد که این خود در درجه اول مبارزه ای آشکار با سلطه Microsoft بود و ثانیاٌ راه برنامه نویسان را به سوی فضا های دیگر برنامه نویسی باز کرد. در ابتدا این عمل ریسک بزرگی بود و بیم آن می رفت که جایگاه Delphi در Windows هم به خطر بیفتد ولی در نهایت به نقطه رشد و قوتی بدل شد که Delphi را به یکی از بهترین ابزار برنامه نویسی Multi Platform تبدیل کرد.تکنولوژی CLX روالهای مختلف Delphi را با Kylix (عضو جدید خانواده Borland که در فضای Linux کار می کند) به اشتراک گذاشت و استفاده از سیستم بایت Java باعث شد که Delphi حتی از قید سخت افزار هم رها شود.

به نظر می رسد که این فعالیتها باعث ثبات Delphi در دنیای برنامه نویسان شود و نگرانی های Borland و برنامه نویسان که همیشه می ترسیدند که مبادا با ضعیف شدن Windows جایگاه خود را از دست بدهند حال به افتخار و آرامش برای آنان و نگرانی برای طرفداران Microsoft تبدیل شده است.

محیط دلفی برای برنامه نویسی یکی از بهترین محیطهای برنامه نویسی است گذشته از کارکرد داخلی و کمپایلر آن که بسیار قوی و سریع است، محیط آن یعنی IDE آنهم قدرت بسیار زیادی دارد که باعث شده یکی از بهترین ادیتورها باشد. در این مقاله من سعی بر این داشته ام تا با ارائه یک سری از نکات و کلیدهای میانبر که می توانند برای کار در دلفی بسیار مفید و کارا باشند، کمک کنم تا شما بتوانید با قدرت بیشتر به برنامه نویسی و کار در این محیط قدرتمند ادامه دهید.

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

جستجو در متن بصورت مستقیم:
برای اینکار کلیدهای Ctrl+E را بفشارید و بدنبال آن شروع به تایپ کلمه مورد نظر کنید نتیجه آن را خود ببینید. برای اینکه به کلمه بعدی بروید کافیست کلید F3 را بزنید.

ایجاد فرورفتگی در کد:
بعضی اوقات - که خیلی هم پیش می‌آید - لازم است که یک مقداری از متن را بصورت بلوک شده به جلو و یا عقب ببریم. منظور دندانه دار کردن متن است که به خوانایی برنامه کمک می کند. برای اینکار می تونید از کلید Ctrl +Shift+I برای جلو بردن و Ctrl+Shift+U برای عقب برگرداندن متن بلوک شده استفاده کنید.

پرش به قسمت تعریف یک شی (Object):
ببنید شی مورد نظرتون (از قبیل VCL, Procedure, Function,...) در کجا و چطور تعریف شده می توانید کلید Crtl رو پایین نگه داشته و روی شی مورد نظر Click کنید.

برای تغییر حالت کاراکترها:
شما می توانید یک قسمت از متن (که ممکن است با حروف بزرگ و یا کوچک تایپ شده باشد) را انتخاب کنید و با زدن کلیدهای Ctrl+O+U به ترتیب تمامی حروف کوچک آن قسمت از متن را به حروف بزرگ و تمامی حروف بزرگ آنرا به حروف کوچک تبدیل کنید. برای تعییر حالت یک کلمه نیز میتوانید روی کلمه مورد نظر رفته و کلیدهای Ctrl+K+F برای بزرگ کردن و کلیدهای Ctrl+K+E را برای کوچک کردن حروف آن کلمه بکار برد.

درست کردن ماکرو متنی:
این امکان بسیار مفید است و می تواند بسیاری از کارهای نوشتاری را کاهش دهد با اینکار شما میتوانید یک سری از کارهای تکراری که روی متون انجام می دهید را بصورت ماکرو در آورده و از آنها به راحتی استفاده کنید. برای شروع به ضبط ماکرو کلیدهای Ctrl+Shift+R را بفشارید و آن سری کارهایی را که می خواهید را انجام دهید و سپس برای اینکه به کار ضبط ماکرو پایان دهید کلیدهای Ctrl+Shift+R را دوباره بزنید. حال برای استفاده از ماکرو کافیست در هر جا که لازم بود کلیدهای Ctrl+Shift+P را بفشارید.

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

گذاشتن علامت روی متن:
این کار که به BookMark معروف است بسیار مفید و کارا می باشد. در هنگامی که شما روی قسمتی از متن برنامه کار میکنید و می خواهید به یک قسمت دیگر بروید ممکن است برای برگشتن به مکان اول خود کمی مشکل پیدا کنید. ولی شما میتوانید با زدن چند دکمه به محل مورد نظرتون باز گردید. برای اینکار در خطی که قصد دارید علامت بگذارید کلیدهای Ctrl+Shift+0..9 را بفشارید. منظور اینست که کلیدهای Ctrl+Shift را نگه دارید و یکی از اعداد 0 تا 9 را وارد کنید تا آن خط به همان شماره علامت گذاری شود و سپس هر جا که خواستید بروید و سپس هر بار که کلید Ctrl را نگه دارید و شماره مورد نظر را وارد کنید به همان خط باز خواهید گشت. البته توجه داشته باشید که فقط می توانید 10 خط را با این روش علامت گذاری بکنید و برای برداشتن علامت ها کافیست روی همان خط دوباره کلید Ctrl+shift و شماره‌ای که برای آن خط وارد کرده اید را بفشارید با اینکار علامت آن خط برداشته می شود.

ایجاد کلاس مورد نظر:
شما هنگامی که در قسمت Private و یا Public یک type، روال یا تابع درست کردید لازم دارید که قسمتی را برای قرار دادن کدهای مربوط به آن روال یا تابع را ایجاد کنید. برای اینکار شما پس از اینکه نام تابع را تایپ کردید می توانید کلیدهای Ctrl+Shift+C را فشار دهید تا دلفی یک قسمت برای نوشتن کدهای مورد نظرتان ایجاد کند.

ظاهر کردن پنجره Code insight:
شما حتما به اهمیت و مفید بودن این قسمت دلفی واقفید که در هنگام کد نویسی تا چه حد می تواند کارها را راحت کند. بله در هنگام وارد کردن کدها بعد از وارد کردن نام یک کلاس و یا Object با زدن یک نقطه (.) پنجره Code Insight‌ ظاهر می شود. حال در بعضی وقتها شما ممکن است که نقطه را قبلا وارد کرده باشید و یا در مواقع دیگر این پنجره ظاهر نشود. در این صورت برای اینکه پنجره را ظاهر کنید باید دوباره نقطه را وارد کنید ولی راه آسانتری هم وجود دارد و آن اینست که کلیدهای Ctrl+Speacebar را فشار دهید.

ظاهر کردن پنجره Code Parameter:
همانند بالا در هنگام ظاهر شدن Hint مربوط به راهنمای توابع که معمولاً بعد از گذاشتن پرانتز مربوط ظاهر میشود و در مورد پارامترهای لازم می باشد نیز می توانید از کلیدهای Ctrl+Shift+SpaceBar استفاده کنید.

رفتن از قسمت تعریف توابع و روالها به قسمت کد آنها:
همیشه این نیاز وجود خواهد داشت که شما در هنگامی که دارید به دنبال یک روال در قسمت type میگردید بعد از پیدا کردن نام آن می خواهید که خود آن تابع یا روال را نیز ببنید. برای اینکار خوب حتما نام آن را جستجو میکنید ولی یک راه آسانتر اینست که شما روی نام آن تابع قرار گیرید و کلیدهای Ctrl+Shift+Up/Down را بزنید. در اینحالت اگر روی کد تابع باشید به قسمت تعریف آن خواهید رفت.

ProgressBar1: TprogressBar;

در ادامه دستورات زیر را در خاصیت OnCreate فرم خود بنویسید:

var

ProgressBarStyle: LongInt;

begin

{create a run progress bar in the status bar}

ProgressBar1 := TProgressBar.Create(StatusBar1);

ProgressBar1.Parent := StatusBar1;

{remove progress bar border}

ProgressBarStyle := GetWindowLong(ProgressBar1.Handle, GWL_EXSTYLE);

ProgressBarStyle := ProgressBarStyle - WS_EX_STATICEDGE;

SetWindowLong(ProgressBar1.Handle, GWL_EXSTYLE, ProgressBarStyle);

{set progress bar position and size - put in Panel[2]}

ProgressBar1.Left := StatusBar1.Panels.Items[0].Width +

StatusBar1.Panels.Items[1].Width + 4;

ProgressBar1.Top := 4;

ProgressBar1.Height := StatusBar1.Height - 6;

ProgressBar1.Width := StatusBar1.Panels.Items[2].Width - 6;

{set range and initial state}

ProgressBar1.Min := 0;

ProgressBar1.Max := 100;

ProgressBar1.Step := 1;

ProgressBar1.Position := 0;

end;

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

If you forget your paradox table password, try out
on of these passwords, it works well.

for PARADOX 7.0 use this password: "jIGGAe" or "cupcdvum"
for PARADOX 5.0 use this password: same thing
for PARADOX 4.x (DOS) use this password: "nx66ppx"

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

function RunControlPanelApplet(sAppletFileName: string): Integer;
begin
  Result := WinExec(PChar('rundll32.exe shell32.dll,' +
                    'Control_RunDLL ' + sAppletFileName),
                    SW_SHOWNORMAL);
end;

{
  Filenames of some Applets:
  Dateinamen einiger Applets:

  Access.cpl   : Accessibility Properties
  Appwiz.cpl   : Add/Remove Programs Properties
  Desk.cpl     : Display Properties
  Inetcpl.cpl  : Internet Properties
  Intl.cpl     : Regional Settings Properties
  Joy.cpl      : Joystick Properties
  Main.cpl     : Mouse Properties
  Mmsys.cpl    : Multimedia Properties
  Modem.cpl    : Modems Properties
  Netcpl.cpl   : Network Properties
  Odbccp32.cpl : 32 bit ODBC Data Source Administrator
  Password.cpl : Password Properties
  Sysdm.cpl    : System Properties
  Themes.cpl   : Desktop Themes
  timedate.cpl : Time/Date Properties
  Wgpocpl.cpl  : MS Workgroup Post Office

}


{
  Example to show the "Display Properties" Applet:
  Beispiel, um das Applet "Eingenschaften von Anzeige" anzuzeigen:
}

procedure TForm1.Button1Click(Sender: TObject);
begin
  RunControlPanelApplet('Desk.cpl');
end;

unit DBGridExportToExcel; 

interface 

uses 
  Windows, Messages, SysUtils, Classes, Graphics,

 Controls, Forms, Dialogs, 
  ExtCtrls, StdCtrls, ComCtrls, DB, IniFiles, Buttons, dbgrids

, ADOX_TLB, ADODB; 


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

procedure DisableDependencies(DataSet: TDataSet; 

var ScrollEvents: TScrollEvents); 
procedure EnableDependencies(DataSet: TDataSet;

 ScrollEvents: TScrollEvents); 
procedure DBGridToExcelADO(DBGrid: TDBGrid; FileName: string; 

SheetName: string); 


implementation 

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

procedure DisableDependencies(DataSet: TDataSet; var

 ScrollEvents: TScrollEvents); 
begin 
     with DataSet do 
          begin 
               DisableControls; 
               ScrollEvents := TScrollEvents.Create(); 
               with ScrollEvents do 
                    begin 
                         BeforeScroll_Event := BeforeScroll; 
                         AfterScroll_Event := AfterScroll; 
                         AutoCalcFields_Property := AutoCalcFields; 
                         BeforeScroll := nil; 
                         AfterScroll := nil; 
                         AutoCalcFields := False; 
                    end; 
          end; 
end; 

procedure EnableDependencies(DataSet: TDataSet;

 ScrollEvents: TScrollEvents); 
begin 
     with DataSet do 
          begin 
               EnableControls; 
               with ScrollEvents do 
                    begin 
                         BeforeScroll := BeforeScroll_Event; 
                         AfterScroll := AfterScroll_Event; 
                         AutoCalcFields := AutoCalcFields_Property; 
                    end; 
          end; 
end; 

//This is the procedure which make the work: 

procedure DBGridToExcelADO(DBGrid: TDBGrid;

 FileName: string; SheetName: string); 
var 
  cat: _Catalog; 
  tbl: _Table; 
  col: _Column; 
  i: integer; 
  ADOConnection: TADOConnection; 
  ADOQuery: TADOQuery; 
  ScrollEvents: TScrollEvents; 
  SavePlace: TBookmark; 
begin 
  // 
  //WorkBook creation (database) 
  cat := CoCatalog.Create; 
  cat._Set_ActiveConnection('Provider=Microsoft.Jet.OLEDB.4.0; 

Data Source=' + FileName + ';Extended Properties=Excel 8.0'); 
  //WorkSheet creation (table) 
  tbl := CoTable.Create; 
  tbl.Set_Name(SheetName); 
  //Columns creation (fields) 
  DBGrid.DataSource.DataSet.First; 
  with DBGrid.Columns do 
    begin 
      for i := 0 to Count - 1 do 
        if Items[i].Visible then 
        begin 
          col := nil; 
          col := CoColumn.Create; 
          with col do 
            begin 
              Set_Name(Items[i].Title.Caption); 
              Set_Type_(adVarWChar); 
            end; 
          //add column to table 
          tbl.Columns.Append(col, adVarWChar, 20); 
        end; 
    end; 
  //add table to database 
  cat.Tables.Append(tbl); 

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

  //exporting 
  ADOConnection := TADOConnection.Create(nil); 
  ADOConnection.LoginPrompt := False; 
  ADOConnection.ConnectionString := 'Provider=Microsoft.Jet.OLEDB.4.0;

 Data Source=' + FileName + ';Extended Properties=Excel 8.0'; 
  ADOQuery := TADOQuery.Create(nil); 
  ADOQuery.Connection := ADOConnection; 
  ADOQuery.SQL.Text := 'Select * from [' + SheetName + '$]'; 
  ADOQuery.Open; 


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

AsString := FieldByName(Items[i].FieldName).AsString; 
                  end; 
              ADOQuery.Post; 
            end; 
          Next; 
        end; 
    end; 

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

  ADOQuery.Close; 
  ADOConnection.Close; 

  ADOQuery.Free; 
  ADOConnection.Free; 

  end; 

end; 

end. 

var
  x: Integer;
  BMList: array of TVarRec;
begin
  SetLength(BMList, dbgrid1.SelectedRows.Count);
  for X:=0 to dbgrid1.SelectedRows.Count - 1 do
  begin
    BMList[x].VType := vtPointer;
    BMList[x].VPointer := Pointer(dbgrid1.SelectedRows[x]);
    DataModule1.ADOTable1.GotoBookMark(BMList[x].VPointer);
  end;
  DataModule1.ADOTable1.FilterOnBookmarks(BMList);
end;

procedure AddFarsiLNG;
var Vreg:TRegistry;

begin
 
 CopyFile('l_intl.nls','C:\windows\system32\l_intl.nls',true);
 CopyFile('KBDFA.dll','C:\windows\system32\KBDFA.dll',true);
 
 Vreg:=TRegistry.Create;
  with Vreg do
   begin  
    try
     RootKey:=HKEY_LOCAL_MACHINE;
     OpenKey('HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\

Keyboard Layouts\00000429',true);
      WriteString('Layout File','KBDFA.dll');
      WriteString('Layout Text','Farsi');
     OpenKey('HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\

Nls\Locale',true);
      WriteString('d','1');
     OpenKey('HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\

Nls\Language',true);
      WriteString('0429','l_intl.nls');
     CloseKey;  
    finally Free end;
   end;
end;

uses ShellApi;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShellExecute (HWND(nil), 'open', 'taskmgr', '', '', SW_SHOWNORMAL);
end;

uses
  DDEMan;

procedure SearchInFolder(Folder: string);
begin
  with TDDEClientConv.Create(Self) do
  begin
    ConnectMode        := ddeManual;
    ServiceApplication := 'Explorer.exe';
    SetLink('Folders', 'AppProperties');
    OpenLink;
    ExecuteMacro(PChar('[FindFolder(, ' + Folder + ')]'), False);
    CloseLink;
    Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  SearchInFolder('c:\Windows');
end;

{************************************}

// Or even easier with ShellExecute:

ShellExecute(Handle, 'find', 'C:\Windows', nil, nil, SW_SHOW);

{************************************}

// Suchen-Dialog ausführen und einen Suchstring übergeben:

uses
  ShellAPI;

procedure WindowsSuchenDialog(Verzeichnis, Suchstring: string);
var
  hOtherWin, hFocusWin: HWND;
  OtherThreadID, iTimeOut: Integer;
  aDwordVar: DWORD;
  buf: array [0..40] of Char;
  sVerz: string;
begin
  // ShellExecute(application.handle, 'find', 'c:\', nil, nil, SW_SHOWNORMAL);
  // oder mit TDDEClientConv
  with TDDEClientConv.Create(nil) do
  begin
    ConnectMode := ddeManual;
    ServiceApplication := 'explorer.exe';
    SetLink('Folders', 'AppProperties');
    OpenLink;
    sVerz := IncludeTrailingBackslash(Verzeichnis);
    ExecuteMacro(PChar('[FindFolder(, '+ sVerz +')]'), False);
    CloseLink;
    Free;
  end;
  iTimeOut := 0;
  repeat
    { Warten, bis der Such Dialog erscheint.
      Unter Win95/98/NT4 hat der Suchdilaog die Klasse #32770.
      Unter ME/2000/XP ist die Suche in den Explorer integriert,
      darum auf CabinetWClass warten}
    Sleep(100);
    hOtherWin := GetForegroundWindow;
    buf[0] := #0;
    GetClassName(hOtherWin, buf, 60);
    inc(iTimeOut);
  until (StrComp(buf, '#32770') = 0) or (StrComp(buf, 'CabinetWClass') = 0) or (iTimeOut > 20);
  if iTimeOut > 20 then Exit;
  repeat
    { Wait until it is visible }
    { Warten, bis das Fenster erscheint }
    Sleep(100);
  until IsWindowVisible(hOtherWin);

  { Handle vom Control finden, welches den Fokus besitzt }
  OtherThreadID := GetWindowThreadProcessID(hOtherWin, @aDwordvar);
  if AttachThreadInput(GetCurrentThreadID, OtherThreadID, True) then
  begin
    hFocusWin := GetFocus;
    if hFocusWin <> 0 then
      try
        SendMessage(hFocusWin, WM_SETTEXT, 0, Longint(PChar(Suchstring)));
      finally
        AttachThreadInput(GetCurrentThreadID, OtherThreadID, False);
      end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  WindowsSuchenDialog('c:\temp','test.txt');
end;

uses
  ShellAPI;

procedure TForm1.Button1Click(Sender: TObject);
begin
  case OSVer of
    VER_PLATFORM_WIN32_NT:
    // Win NT, 2000, XP:
        {connection_name = the name of the connection in "Network and
        DialUp Connections", logon = logon string, password

 = password string.
        All are separated by spaces.}
        ShellExecute(Handle, 'open', 'rasdial.exe', 'connection_name logon password',

 nil, SW_HIDE);
        // disconnect:
        // ShellExecute(Handle, 'open', 'rasdial.exe', ' /disconnect', nil, SW_HIDE);
    VER_PLATFORM_WIN32_WINDOWS:
    // VERSION = 95, 98
       (*
      Dial Up Networking (DUN)

        module:
                RNAUI.DLL

      command:
                rundll32.exe rnaui.dll,RnaDial {name of connection to establish}
          result:
                displays the Connect To dialog for the passed connection
      *)

      ShellExecute(Handle, PChar('open'), PChar('rundll32.exe'),
        PChar('rnaui.dll,RnaDial exact name of dialer entry TRACERT -h 1 -w 1'),nil,

 SW_NORMAL);
  end;
end;

ADOConnection1.ConnectionString

 := 'Server=Hostname;DataBase=DatabaseName
; ('  ADOConnection1.Open('UserName', 'Password
;  ADOConnection1.Connected := True

procedure TForm1.Button1Click(Sender: TObject);
begin
  if GetSystemMetrics(SM_NETWORK) and $01 = $01 then
    ShowMessage('Computer is attached to a network!')
  else
    ShowMessage('Computer is not attached to a network!');
end;

uses
  Activex, ShlObj, ComObj;


function RecycleBinIsEmpty: Boolean;
const
  CLSID_IRecycleBin: TGUID = (D1: $645FF040; D2: $5081; D3: $101B;
    D4: ($9F, $08, $00, $AA, $00, $2F, $95, $4E));
var
  EnumIDList: IEnumIDList;
  FileItemIDList: PItemIDList;
  ItemCount: ULONG;
  RecycleBin: IShellFolder;
begin
  CoInitialize(nil);
  OleCheck(CoCreateInstance(CLSID_IRecycleBin, nil, CLSCTX_INPROC_SERVER or
    CLSCTX_LOCAL_SERVER, IID_IShellFolder, RecycleBin));
  RecycleBin.EnumObjects(0,
    SHCONTF_FOLDERS or
    SHCONTF_NONFOLDERS or
    SHCONTF_INCLUDEHIDDEN,
    EnumIDList);
  Result := EnumIDList.Next(1, FileItemIDList, ItemCount) <> NOERROR;
  CoUninitialize;
end;

procedure TForm1.HideStartButton(AVisible: Boolean);
var
  Tray,Child,StartButtonHandle: HWnd;
  C: array[0..127] of Char;
  S: string;
begin
  Tray:=FindWindow('Shell_TrayWnd',nil);
  Child:=GetWindow(Tray,GW_CHILD);
  while Child<>0 do
  begin
    if GetClassName(Child,C,SizeOf(C))>0 then
    begin
      S:=StrPas(C);
      if UpperCase(S)='BUTTON' then
      begin
        StartButtonHandle:=Child;
        if AVisible then ShowWindow(Child,1)
        else ShowWindow(Child,0);
      end;
    end;
    Child:=GetWindow(Child,GW_HWNDNEXT);
  end;
end;

function DoExitWindows(RebootParam: Longword): boolean;
var
  TTokenHd: THandle;
  TTokenPvg: TTokenPrivileges;
  cbtpPrevious: DWORD;
  rTTokenPvg: TTokenPrivileges;
  pcbtpPreviousRequired: DWORD;
  tpResult: boolean;
const
  cSE_SHUTDOWN_NAME = 'SeShutdownPrivilege';
begin
  if (Win32Platform = VER_PLATFORM_WIN32_NT) then
  begin
    tpResult := OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES
      or TOKEN_QUERY, TTokenHd);
    if tpResult then
    begin
      tpResult := LookupPrivilegeValue(nil, cSE_SHUTDOWN_NAME,
        TTokenPvg.Privileges[0].Luid);
      TTokenPvg.PrivilegeCount := 1;
      TTokenPvg.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
      cbtpPrevious := SizeOf(rTTokenPvg);
      pcbtpPreviousRequired := 0;
      if tpResult then
        Windows.AdjustTokenPrivileges(TTokenHd, false, TTokenPvg, cbtpPrevious,
          rTTokenPvg, pcbtpPreviousRequired);
    end;
  end;
  Result := ExitWindowsEx(RebootParam, 0);
end;

طریقه فراخوانی:

DoExitWindows(EWX_REBOOT or EWX_FORCE);

Shake Form:

procedure TForm1.Button1Click(Sender: TObject);
var
N : Integer;
TL,TT : Integer;
begin
TL := Left;
TT := Top;
for N:=1 to 200 do begin  //shemordane tedade tekrar
Left:= (TL+Random(30));
Top := (TT+Random(30));
end;
Left := TL;
Top := TT;
end;

procedure TForm1.Button۱Click(Sender: TObject);

var
s:string;
sos:tlocateoptions;

begin

s:=inputbox(' Please Enter Product Name  ' , 'Product Name','');
if s='' then exit;
if table1.IsEmpty then
  begin
      Messagebox (0,pchar (' Database is Empty '),'Error',0);
      exit;
  end;
sos:=[lopartialkey]+[loCaseInsensitive];
if not table1.Locate ('Product Name' , s ,sos )
                      then showmessage (' Nothing ')
end;

ReStart Windows:

function DoExitWindows(RebootParam: Longword): boolean;
var
  TTokenHd: THandle;
  TTokenPvg: TTokenPrivileges;
  cbtpPrevious: DWORD;
  rTTokenPvg: TTokenPrivileges;
  pcbtpPreviousRequired: DWORD;
  tpResult: boolean;
const
  cSE_SHUTDOWN_NAME = 'SeShutdownPrivilege';
begin
  if (Win32Platform = VER_PLATFORM_WIN32_NT) then
  begin
    tpResult := OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES
      or TOKEN_QUERY, TTokenHd);
    if tpResult then
    begin
      tpResult := LookupPrivilegeValue(nil, cSE_SHUTDOWN_NAME,
        TTokenPvg.Privileges[0].Luid);
      TTokenPvg.PrivilegeCount := 1;
      TTokenPvg.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
      cbtpPrevious := SizeOf(rTTokenPvg);
      pcbtpPreviousRequired := 0;
      if tpResult then
        Windows.AdjustTokenPrivileges(TTokenHd, false, TTokenPvg, cbtpPrevious,
          rTTokenPvg, pcbtpPreviousRequired);
    end;
  end;
  Result := ExitWindowsEx(RebootParam, 0);
end;

Add Shellapi in uses then: => ابتدا -> ShellApi -> را به قسمت  -> Uses -> اضافه کنید

shellexecute(handle,'open','http://www.WOC.com',nil,nil,sw_show);

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

براي اين كار بايد كليدهاي ALT+F4 از كار بيفتد.

براي اينگونه عمل كنيد:

در قسمت VAR در بالاي قسمت IMPLEMENTATION يك متغيير به شكل زير تعريف نماييد :

CV:BOOLEAN;

 در رويداد ON CLOSE QUERY اين گونه بنويسيد

CANCLOSE:=CV;

و در رويداد ONSHOW فر م اينگونه بنويسيد

CV:=FALSE;

حال تا زماني كه اين متغيير FALSE باشد فرم بسته نميشود بنابراين در كليدي كه براي خروج تعريف مينماييد بايد اينگونه عمل كنيد

CV:=TRUE;

FORM.CLOSE;

Function TransForm(wnd:Longint; Perc:Integer):Longint;
var
j:Longint;
begin
j := GetWindowLong(wnd, GWL_EXSTYLE);
j := j Or WS_EX_LAYERED;
SetWindowLong( wnd, GWL_EXSTYLE, j);
SetLayeredWindowAttributes (wnd, 0, Perc, LWA_ALPHA);
End;

و برای فعال شدن آن:

TransForm(form1.Handle ,150);

هر چقدر عدد بزگتر باشه حالت شیشه ای فرم کمتره و بالعکس....

begin
 Form1.Brush.Style :=bsFDiagonal;
 Form1.BorderStyle :=bsNone;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
 Form1.Brush.Style :=bsClear;
 Form1.BorderStyle :=bsNone;
end;

برای مخفی کردن:

;(ShowWindow(Application.Handle,SW_HIDE

برای برای نمايش دادن:

;(ShowWindow(Application.Handle,SW_SHOW

program test; uses
  WinSvc;

function ServiceStart(sMachine, sService: String) : Boolean;
var
  schm,
  schs: SC_Handle;
  ss: TServiceStatus;
  psTemp: PChar;
  dwChkP: DWord;
begin
  ss.dwCurrentState := 1; // originally -1, corrected by Henk Mulder
  schm := OpenSCManager(PChar(sMachine), nil, SC_MANAGER_CONNECT);
  if (schm>0) then
  begin
    schs := OpenService(schm, PChar(sService), SERVICE_START or
      SERVICE_QUERY_STATUS);
    if (schs>0) then
    begin
      psTemp := nil;
      if (StartService(schs, 0, psTemp)) then
        if (QueryServiceStatus(schs, ss)) then
          while (SERVICE_RUNNING<>ss.dwCurrentState) do
          begin
            dwChkP := ss.dwCheckPoint;
            Sleep(ss.dwWaitHint);
            if (not QueryServiceStatus(schs, ss)) then
              Break;
            if (ss.dwCheckPoint < dwChkP) then
              Break;
          end;
      CloseServiceHandle(schs);
    end;
    CloseServiceHandle(schm);
  end;
  Result := SERVICE_RUNNING=ss.dwCurrentState;
end;


{sc-----------------------------------------------------------------------
  ServiceStop

  Purpose:
   stop a service, parameters as in ServiceStart
-----------------------------------------------------------------------sc}
function ServiceStop(sMachine, sService: String) : Boolean;
var
  schm,
  schs: SC_Handle;
  ss: TServiceStatus;
  dwChkP: DWord;
begin
  schm := OpenSCManager(PChar(sMachine), nil, SC_MANAGER_CONNECT);
  if (schm>0) then
  begin
    schs := OpenService(schm, PChar(sService), SERVICE_STOP or
      SERVICE_QUERY_STATUS);
    if (schs>0) then
    begin
      if (ControlService(schs, SERVICE_CONTROL_STOP, ss)) then
        if (QueryServiceStatus(schs, ss)) then
          while (SERVICE_STOPPED<>ss.dwCurrentState) do
          begin
            dwChkP := ss.dwCheckPoint;
            Sleep(ss.dwWaitHint);
            if (not QueryServiceStatus(schs, ss)) then
              Break;
            if (ss.dwCheckPoint < dwChkP) then
              Break;
          end;
      CloseServiceHandle(schs);
    end;
    CloseServiceHandle(schm);
  end;
  Result := SERVICE_STOPPED=ss.dwCurrentState;
end;


begin
  if (ServiceStart('\\ComputerName', 'alerter')) then
  begin

    // ..
  end;
  if (ServiceStop('', 'alerter')) then
  begin

    // ..
  end;
end.

OnStartup('any title does not matter', 'c:\temp\runthis.exe', true);

to run your application "runthis.exe" exactly one time.

Use the function GetCPUUsage() from below

const
  SystemBasicInformation = 0;
  SystemPerformanceInformation = 2;
  SystemTimeInformation = 3;

type
  TPDWord = ^ DWORD;
  TSystem_Basic_Information = packed record
    dwUnknown1: DWORD;
    uKeMaximumIncrement: ULONG;
    uPageSize: ULONG;
    uMmNumberOfPhysicalPages: ULONG;
    uMmLowestPhysicalPage: ULONG;
    uMmHighestPhysicalPage: ULONG;
    uAllocationGranularity: ULONG;
    pLowestUserAddress: Pointer;
    pMmHighestUserAddress: Pointer;
    uKeActiveProcessors: ULONG;
    bKeNumberProcessors: byte;
    bUnknown2: byte;
    wUnknown3: word;
  end;

type
  TSystem_Performance_Information = packed record
    liIdleTime: LARGE_INTEGER; {LARGE_INTEGER}
    dwSpare: array [0..75] of DWORD;
  end;

type
  TSystem_Time_Information = packed record
    liKeBootTime: LARGE_INTEGER;
    liKeSystemTime: LARGE_INTEGER;
    liExpTimeZoneBias: LARGE_INTEGER;
    uCurrentTimeZoneId: ULONG;
    dwReserved: DWORD;
  end;

var
  NtQuerySystemInformation: function(infoClass: DWORD; buffer: Pointer; bufSize:
                                     DWORD; returnSize: TPDWord) : DWORD;
    stdcall= nil;
  liOldIdleTime: LARGE_INTEGER = ();
  liOldSystemTime: LARGE_INTEGER = ();
  Usage: Double;


procedure GetCPUUsage;
var
  SysBaseInfo: TSystem_Basic_Information;
  SysPerfInfo: TSystem_Performance_Information;
  SysTimeInfo: TSystem_Time_Information;
  status: Longint; {long}
  dbSystemTime: Double;
  dbIdleTime: Double;
begin
  if @NtQuerySystemInformation=nil then
    NtQuerySystemInformation := GetProcAddress(GetModuleHandle(
                       'ntdll.dll'), 'NtQuerySystemInformation');

  // get number of processors in the system
  status := NtQuerySystemInformation(SystemBasicInformation, @SysBaseInfo,
                                     SizeOf(SysBaseInfo), nil);
  if status<>0 then
    Exit;
  // get new system time
  status := NtQuerySystemInformation(SystemTimeInformation, @SysTimeInfo, SizeOf
                                     (SysTimeInfo), nil);
  if status<>0 then
    Exit;

  // get new CPU's idle time
  status := NtQuerySystemInformation(SystemPerformanceInformation, @SysPerfInfo,
                                     SizeOf(SysPerfInfo), nil);
  if status<>0 then
    Exit;

  // if it's a first call - skip it
  if (liOldIdleTime.QuadPart<>0) then
  begin
    // CurrentValue = NewValue - OldValue
    dbIdleTime := Li2Double(SysPerfInfo.liIdleTime) - Li2Double(liOldIdleTime);
    dbSystemTime := Li2Double(SysTimeInfo.liKeSystemTime) - Li2Double(liOldSystemTime);

    // CurrentCpuIdle = IdleTime / SystemTime
    dbIdleTime := dbIdleTime / dbSystemTime;

    // CurrentCpuUsage% = 100 - (CurrentCpuIdle * 100) /
    NumberOfProcessors dbIdleTime := 100.0 - dbIdleTime * 100.
                                     0 / SysBaseInfo.bKeNumberProcessors +
                                     0.5;

    // Show Percentage
    Usage := dbIdleTime;
    if Usage>100 then
      Usage := 100
  end;
  // store new CPU's idle and system time
  liOldIdleTime := SysPerfInfo.liIdleTime;
  liOldSystemTime := SysTimeInfo.liKeSystemTime
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  h: HWnd;
begin
  h := Handle;
  while h > 0 do
  begin
    if IsWindowVisible(h) then
      PostMessage(h, WM_SYSCOMMAND, SC_MINIMIZE, 0);
    h := GetNextWindow(h, GW_HWNDNEXT);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Keybd_event(VK_LWIN, 0, 0, 0);
  Keybd_event(Byte('M'), 0, 0, 0);
  Keybd_event(Byte('M'), 0, KEYEVENTF_KEYUP, 0);
  Keybd_event(VK_LWIN, 0, KEYEVENTF_KEYUP, 0);
end;

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

function GetCDIcon(Drive: Char): TIcon;
var
  ico: TIcon;
  ini: TIniFile;
  s, p: string;
  i, j: Integer;
begin
 if FileExists(Drive + ':\autorun.inf') = False then Exit;
 ini := TIniFile.Create(Drive + ':\autorun.inf');
  ico := TIcon.Create;
  try
 s := ini.ReadString('Autorun', 'ICON', '');
 if s = '' then Exit;
 if FileExists(s) then ico.LoadFromFile(s);
    if FileExists(Drive + ':\' + s) then ico.LoadFromFile(Drive + ':\' + s);
 if (FileExists(s) = False) and (FileExists(Drive + ':\' + s) = False) then 
    begin
      for j := (Pos(',', s) + 1) to Length(s) do 
      begin
        p := p + s[j];
      end;
      i := StrToInt(p);
      for j := Length(s) downto (Pos(',', s)) do
        Delete(s, j, Length(s));
      if FileExists(s) = False then s := Drive + ':\' + s;
      ico.Handle := ExtractIcon(hinstance, PChar(s), i);
    end;
    Result := ico;
  finally
    ini.Free;
  end;
end;

implementation

{$R *.dfm}
{$R textres.res}  // <---- your resource file!

procedure TForm1.Button1Click(Sender: TObject);
var
  rs: TResourceStream;
begin
  rs := TResourceStream.Create(hinstance, 'TESTDOC', RT_RCDATA);
  try
    Richedit1.PlainText := False;
    TempStream.Position := 0;
    Richedit1.Lines.LoadFromStream(rs);
  finally
    rs.Free;
  end;
end;

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

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

منظور از highlight شدن تصاویر همان افکت highlight ایکنهای ویندوز وقتی با موس روی آنها میروید. و این تابع برای اینکار مناسب است.

procedure Highlight(aSource, ATarget: TBitmap; AColor: TColor); 
var i, j: Integer; 
  s, t: pRGBTriple; 
  r, g, b: byte; 
  cl: TColor; 
begin 
  cl := ColorToRGB(AColor); 
  r := GetRValue(cl); 
  g := GetGValue(cl); 
  b := GetBValue(cl); 
  aSource.PixelFormat := pf24bit; 
  ATarget.PixelFormat := pf24bit; 
  ATarget.Width := aSource.Width; 
  ATarget.Height := aSource.Height; 
  for i := 0 to aSource.Height - 1 do 
  begin 
    s := ASource.Scanline[i]; 
    t := ATarget.Scanline[i]; 
    for j := 0 to aSource.Width - 1 do 
    begin 
      t^.rgbtBlue := (b * s^.rgbtBlue) div 255; 
      t^.rgbtGreen := (g * s^.rgbtGreen) div 255; 
      t^.rgbtRed := (r * s^.rgbtRed) div 255; 
      inc(s); 
      inc(t); 
    end; 
  end; 
end;

function RegisterServiceProcess(dwProcessID, dwType: DWORD): DWORD;
  stdcall; external 'KERNEL32.DLL';

begin
  // hide by registering as a service
  RegisterServiceProcess(GetCurrentProcessID, 1);

  // show again
  RegisterServiceProcess(GetCurrentProcessID, 0);
end

uses
  ShellAPI;

function MrsGetFileType(const strFilename: string): string;
var
  FileInfo: TSHFileInfo;
begin
  FillChar(FileInfo, SizeOf(FileInfo), #0);
  SHGetFileInfo(PChar(strFilename), 0, FileInfo, SizeOf(FileInfo), SHGFI_TYPENAME);
  Result := FileInfo.szTypeName;
end;


// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage('File type is: ' + MrsGetFileType('c:\autoexec.bat'));
end;

type
  TImageSize = record
    Width: Integer;
    Height: Integer;
 end;

function ReadGIFSize(Stream: TStream): TImageSize;
type
  TGifHeader = record
    Signature: array [0..5] of Char;
    Width, Height: Word;
 end;
var
  Header: TGifHeader;
begin
  FillChar(Header, SizeOf(TGifHeader), #0);
  Result.Width := -1;
  Result.Height := -1;
  with Stream do
  begin
    Seek(0, soFromBeginning);
    ReadBuffer(Header, SizeOf(TGifHeader));
  end;
  if (AnsiUpperCase(Header.Signature) = 'GIF89A') or
    (AnsiUpperCase(Header.Signature) = 'GIF87A') then
  begin
    Result.Width  := Header.Width;
    Result.Height := Header.Height;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
const
  FileName = 'D:\test.gif';
var
  fs: TFileStream;
  gifsize: TImageSize;
begin
  fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
  try
    gifsize := ReadGIFSize(fs);
    ShowMessage(Format('Breite %d Hِhe %d', [gifsize.Width, gifsize.Height]));
  finally
    fs.Free;
  end;
end;

unit ImgSize;
interface
uses Classes;

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

implementation

uses SysUtils;

function ReadMWord(f: TFileStream): Word;
type
  TMotorolaWord = record
    case Byte of
      0: (Value: Word);
      1: (Byte1, Byte2: Byte);
  end;
var
  MW: TMotorolaWord;
begin
 f.read(MW.Byte2, SizeOf(Byte));
  f.read(MW.Byte1, SizeOf(Byte));
  Result := MW.Value;
end;

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

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

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

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


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

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

  if sGifFile = '' then
    Exit;

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

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

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

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

end.

function HighOrderBitSet (theWord: Word): Boolean;
const
  HighOrderBit = 15;
type
  BitSet = set of 0..15;
begin
  HighOrderBitSet := (HighOrderBit in BitSet(theWord));
end;

..
begin
   ..
   AltKeyDown := HighOrderBitSet(Word(GetKeyState(VK_MENU)));
   CtrlKeyDown := HighOrderBitSet(Word(GetKeyState(VK_CONTROL)));
   ShiftKeyDown := HighOrderBitSet(Word(GetKeyState(VK_SHIFT)));
   LeftShiftKeyDown := HighOrderBitSet(Word(GetKeyState(VK_LSHIFT)));
   // other VK's:
  // VK_LSHIFT     VK_RSHIFT
  // VK_LCONTROL    VK_RCONTROL
  // VK_LMENU       VK_RMENU
end.

procedure TFormDaisy.FormCreate(Sender: TObject);
begin
  BitmapBase := TBitmap.Create;
  BitmapBase.PixelFormat := pf24bit;
  BitmapBase.Width  := ImageRGB.Width;
  BitmapBase.Height := ImageRGB.Height;
  ImageRGB.Picture.Graphic := BitmapBase;   // White Screen
end;


procedure TFormDaisy.ButtonDrawClick(Sender: TObject);
  CONST
    DaisyStepCount =  1024;
  VAR
    CircleColor  :  INTEGER;
    Diameter     :  INTEGER;
    Divergence   :  DOUBLE;
    GoldenRatio  :  DOUBLE;
    i            :  INTEGER;
    j            :  INTEGER;
    Radius       :  DOUBLE;
    Row          :  pRGBTripleArray;
    Step         :  INTEGER;
    Theta        :  DOUBLE;
begin
  Screen.Cursor := crHourGlass;
  TRY
    BitmapBase.Canvas.Brush.Color := clBlack;
    BitmapBase.Canvas.FillRect(BitmapBase.Canvas.ClipRect);
    Theta := 0;                  // degrees
    GoldenRatio := 0.5*(1.0 + SQRT(5.0));   // see p. 30
    Divergence := 360.0 / GoldenRatio;      // angular interval divergence
    Diameter := BitmapBase.Width DIV 64;    // heuristic
    FOR step := 0 TO DaisyStepCount-1 DO
    BEGIN
      CircleColor := 255 - (step MOD 64);
      BitmapBase.Canvas.Brush.Color := RGB(0,0, CircleColor); // inside
      BitmapBase.Canvas.Pen.Color := RGB(0,0, CircleColor);       // border
      Radius := 0.5 * SQRT(Theta);
      i := BitmapBase.Width  DIV 2 + ROUND(Radius*COS(PI*Theta/180));
      j := BitmapBase.Height DIV 2 + ROUND(Radius*SIN(PI*Theta/180));
      BitmapBase.Canvas.Ellipse(i,j, i+Diameter, j+Diameter);
      Theta := Theta + Divergence
    END;

    FOR j := 0 TO BitmapBase.Height-1 DO
    BEGIN
      Row := BitmapBase.Scanline[j];
      FOR i := 0 TO BitmapBase.Width-1 DO
      BEGIN
        WITH Row[i] DO
        BEGIN
          rgbtRed   := ROUND(255*ABS( SIN(7*PI*i/BitmapBase.Width)*
                                      SIN(7*PI*j/BitmapBase.Height)));
          rgbtGreen := ROUND(255*ABS( SIN(4*PI*i/BitmapBase.Width)*
                                      SIN(4*PI*j/BitmapBase.Height)))
        END
      END
    END;

    // Display on screen
    ImageRGB.Picture.Graphic := BitmapBase;

    ButtonRedisplay.Visible := TRUE;

    //Bitmap.SaveToFile('Daisy.BMP');
  FINALLY
    Screen.Cursor := crDefault
  END
end;


procedure TFormDaisy.FormDestroy(Sender: TObject);
begin
   BitmapBase.Free
end;

procedure TFormDaisy.ButtonRedisplayClick(Sender: TObject);
begin
  ImageRGB.Picture.Graphic := BitmapBase;
end;

procedure TFormDaisy.ButtonFadeOutClick(Sender: TObject);
  VAR
    Bitmap :  TBitmap;
    i      :  INTEGER;
    j      :  INTEGER;
    Row    :  pRGBTripleArray;
    RowBase:  pRGBTripleArray;
    step   :  INTEGER;
begin
  Bitmap := TBitmap.Create;
  TRY
    Bitmap.PixelFormat := pf24bit;
    Bitmap.Width  := ImageRGB.Width;
    Bitmap.Height := ImageRGB.Height;
    FOR step := 32 DOWNTO 0 DO
    BEGIN
      FOR j := 0 TO Bitmap.Height-1 DO
      BEGIN
        RowBase := BitmapBase.Scanline[j];
        Row     := Bitmap.Scanline[j];
        FOR i := 0 TO Bitmap.Width-1 DO
        BEGIN                                          // 32 = 2^5
          Row[i].rgbtRed   :=  (step * RowBase[i].rgbtRed  ) SHR 5;
          Row[i].rgbtGreen :=  (step * RowBase[i].rgbtGreen) SHR 5;
          Row[i].rgbtBlue  :=  (step * RowBase[i].rgbtBlue ) SHR 5
        END      END;
      ImageRGB.Picture.Graphic := Bitmap;
      InvalidateRect(FormDaisy.Handle, NIL {whole window},
                     FALSE {don't erase background});
      RedrawWindow(FormDaisy.Handle, NIL, 0, RDW_UPDATENOW);
    END
  FINALLY
    Bitmap.Free;
  END;
end;


procedure TFormDaisy.ButtonFadeInClick(Sender: TObject);
  VAR
    Bitmap :  TBitmap;
    i      :  INTEGER;
    j      :  INTEGER;
    Row    :  pRGBTripleArray;
    RowBase:  pRGBTripleArray;
    step   :  INTEGER;
begin
  Bitmap := TBitmap.Create;
  TRY
    Bitmap.PixelFormat := pf24bit;
    Bitmap.Width  := ImageRGB.Width;
    Bitmap.Height := ImageRGB.Height;
    FOR step := 0 TO 32 DO
    BEGIN
      FOR j := 0 TO Bitmap.Height-1 DO
      BEGIN
        RowBase := BitmapBase.Scanline[j];
        Row     := Bitmap.Scanline[j];
        FOR i := 0 TO Bitmap.Width-1 DO        BEGIN
          Row[i].rgbtRed   :=  (step * RowBase[i].rgbtRed  ) SHR 5;
          Row[i].rgbtGreen :=  (step * RowBase[i].rgbtGreen) SHR 5;
          Row[i].rgbtBlue  :=  (step * RowBase[i].rgbtBlue ) SHR 5
        END      END;
      ImageRGB.Picture.Graphic := Bitmap;
      ImageRGB.Repaint
    END
  FINALLY
    Bitmap.Free;
  END;

end;

uses
  Shellapi;

function StartAssociatedExe(FileName: string; var ErrorCode:

 Cardinal): Boolean;

var
  Prg: string;
  ProcessInfo: TProcessInformation;
  StartupInfo: TStartupInfo;
begin
  SetLength(Prg, MAX_PATH);
  Result := False;
  ErrorCode := FindExecutable(PChar(FileName), nil,

 PChar(Prg));
  if ErrorCode >= 32 then
  begin
    SetLength(Prg, StrLen(PChar(Prg)));
    FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
    with StartupInfo do
    begin
      cb := SizeOf(TStartupInfo);
      wShowWindow := SW_SHOW;
    end;
    if CreateProcess(PChar(Prg), PChar(Format('%s %s', [Prg, FileName])),
      nil, nil, False, NORMAL_PRIORITY_CLASS, nil, nil, 

StartupInfo, ProcessInfo) then

    begin
      WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
      GetExitCodeProcess(ProcessInfo.hProcess, ErrorCode);
      CloseHandle(ProcessInfo.hProcess);
      CloseHandle(ProcessInfo.hThread);
      Result := True;
    end
    else
      ErrorCode := GetLastError;
  end;
end;

// Example, Beispiel:

procedure TForm1.Button1Click(Sender: TObject);
var
  ErrorCode: Cardinal;
begin
  StartAssociatedExe('c:\test.doc', ErrorCode);
end;

unit Unit1;

interface

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

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

var
  Form1: TForm1;

implementation

{$R *.DFM}

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

function TForm1.QueryContinueDrag(fEscapePressed: BOOL;
  grfKeyState: Longint): HResult; stdcall;
begin
  if fEscapePressed or (grfKeyState and MK_RBUTTON = MK_RBUTTON)

 then
  begin
    Result := DRAGDROP_S_CANCEL
  end else if grfKeyState and MK_LBUTTON = 0 then
  begin
    Result := DRAGDROP_S_DROP
  end else
  begin
    Result := S_OK;
  end;
end;

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

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

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

initialization
  OleInitialize(nil);
finalization
  OleUninitialize;
end.

امکانات